2 -- Functions to generate VHDL from FlatFunctions
6 import qualified Data.Foldable as Foldable
7 import qualified Data.List as List
8 import qualified Data.Map as Map
10 import qualified Control.Monad as Monad
11 import qualified Control.Arrow as Arrow
12 import qualified Data.Traversable as Traversable
13 import qualified Data.Monoid as Monoid
16 import qualified TysWiredIn
18 import qualified TyCon
19 import Outputable ( showSDoc, ppr )
21 import qualified ForSyDe.Backend.VHDL.AST as AST
26 import TranslatorTypes
29 getDesignFiles :: [FuncData] -> [AST.DesignFile]
30 getDesignFiles funcs =
31 map (AST.DesignFile context) units
33 units = filter (not.null) $ map getLibraryUnits funcs
35 AST.Library $ mkVHDLId "IEEE",
36 AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
38 -- | Create an entity for a given function
40 HsFunction -- | The function signature
41 -> FuncData -- | The function data collected so far
42 -> Maybe Entity -- | The resulting entity. Should return the existing
43 --- Entity for builtin functions.
45 createEntity hsfunc fdata =
46 case flatFunc fdata of
47 -- Skip (builtin) functions without a FlatFunction
48 Nothing -> funcEntity fdata
49 -- Create an entity for all other functions
52 sigs = flat_sigs flatfunc
53 args = flat_args flatfunc
54 res = flat_res flatfunc
55 (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
56 (ty_decls', res') = Traversable.traverse (mkMap sigs) res
57 -- TODO: Unique ty_decls
58 ent_decl' = createEntityAST hsfunc args' res'
59 pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
60 pkg_decl = if null ty_decls && null ty_decls'
62 else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
63 AST.EntityDec entity_id _ = ent_decl'
65 Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl
68 [(SignalId, SignalInfo)]
70 -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
72 if isPortSigUse $ sigUse info
74 let (decs, type_mark) = vhdl_ty ty in
75 (decs, Just (mkVHDLId nm, type_mark))
77 (Monoid.mempty, Nothing)
79 info = Maybe.fromMaybe
80 (error $ "Signal not found in the name map? This should not happen!")
83 (error $ "Signal not named? This should not happen!")
87 -- | Create the VHDL AST for an entity
89 HsFunction -- | The signature of the function we're working with
90 -> [VHDLSignalMap] -- | The entity's arguments
91 -> VHDLSignalMap -- | The entity's result
92 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
94 createEntityAST hsfunc args res =
95 AST.EntityDec vhdl_id ports
97 vhdl_id = mkEntityId hsfunc
98 ports = concatMap (mapToPorts AST.In) args
99 ++ mapToPorts AST.Out res
101 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
103 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
104 -- Add a clk port if we have state
105 clk_port = if hasState hsfunc
107 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
111 -- | Create a port declaration
113 AST.Mode -- | The mode for the port (In / Out)
114 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
115 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
117 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
118 mkIfaceSigDec _ Nothing = Nothing
120 -- | Generate a VHDL entity name for the given hsfunc
122 -- TODO: This doesn't work for functions with multiple signatures!
123 mkVHDLId $ hsFuncName hsfunc
125 -- | Create an architecture for a given function
126 createArchitecture ::
127 FuncMap -- ^ The functions in the current session
128 -> HsFunction -- ^ The function signature
129 -> FuncData -- ^ The function data collected so far
130 -> Maybe AST.ArchBody -- ^ The architecture for this function
132 createArchitecture funcs hsfunc fdata =
133 case flatFunc fdata of
134 -- Skip (builtin) functions without a FlatFunction
135 Nothing -> funcArch fdata
136 -- Create an architecture for all other functions
139 sigs = flat_sigs flatfunc
140 args = flat_args flatfunc
141 res = flat_res flatfunc
142 defs = flat_defs flatfunc
143 entity_id = Maybe.fromMaybe
144 (error $ "Building architecture without an entity? This should not happen!")
146 -- Create signal declarations for all signals that are not in args and
148 (ty_decls, sig_decs) = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
149 -- TODO: Unique ty_decls
150 -- TODO: Store ty_decls somewhere
151 -- Create concurrent statements for all signal definitions
152 statements = zipWith (mkConcSm funcs sigs) defs [0..]
153 procs = map mkStateProcSm (makeStatePairs flatfunc)
154 procs' = map AST.CSPSm procs
156 Just $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
158 -- | Looks up all pairs of old state, new state signals, together with
159 -- the state id they represent.
160 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
161 makeStatePairs flatfunc =
162 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
163 | old_info <- map snd (flat_sigs flatfunc)
164 , new_info <- map snd (flat_sigs flatfunc)
165 -- old_info must be an old state (and, because of the next equality,
166 -- new_info must be a new state).
167 , Maybe.isJust $ oldStateId $ sigUse old_info
168 -- And the state numbers must match
169 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
171 -- Replace the second tuple element with the corresponding SignalInfo
172 --args_states = map (Arrow.second $ signalInfo sigs) args
173 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
174 mkStateProcSm (num, old, new) =
175 AST.ProcSm label [clk] [statement]
177 label = mkVHDLId $ "state_" ++ (show num)
179 rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
180 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
181 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
182 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
183 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
185 mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
187 let use = sigUse info in
188 if isInternalSigUse use || isStateSigUse use then
189 let (ty_decls, type_mark) = vhdl_ty ty in
190 (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
196 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
198 getSignalId :: SignalInfo -> AST.VHDLId
200 mkVHDLId $ Maybe.fromMaybe
201 (error $ "Unnamed signal? This should not happen!")
204 -- | Transforms a signal definition into a VHDL concurrent statement
206 FuncMap -- ^ The functions in the current session
207 -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
208 -> SigDef -- ^ The signal definition
209 -> Int -- ^ A number that will be unique for all
210 -- concurrent statements in the architecture.
211 -> AST.ConcSm -- ^ The corresponding VHDL component instantiation.
213 mkConcSm funcs sigs (FApp hsfunc args res) num =
215 fdata_maybe = Map.lookup hsfunc funcs
216 fdata = Maybe.fromMaybe
217 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
219 entity = Maybe.fromMaybe
220 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
222 entity_id = ent_id entity
223 label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
224 -- Add a clk port if we have state
225 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
226 portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
228 AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
230 mkConcSm _ sigs (UncondDef src dst) _ =
232 src_expr = vhdl_expr src
233 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
234 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
235 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
239 vhdl_expr (Left id) = mkIdExpr sigs id
240 vhdl_expr (Right expr) =
243 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
247 (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
249 mkConcSm _ sigs (CondDef cond true false dst) _ =
251 cond_expr = mkIdExpr sigs cond
252 true_expr = mkIdExpr sigs true
253 false_expr = mkIdExpr sigs false
254 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
255 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
256 whenelse = AST.WhenElse true_wform cond_expr
257 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
258 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
262 -- | Turn a SignalId into a VHDL Expr
263 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
265 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
266 AST.PrimName src_name
269 [(SignalId, SignalInfo)] -- | The signals in the current architecture
270 -> [SignalMap] -- | The signals that are applied to function
271 -> SignalMap -- | the signals in which to store the function result
272 -> Entity -- | The entity to map against.
273 -> [AST.AssocElem] -- | The resulting port maps
275 mkAssocElems sigmap args res entity =
276 -- Create the actual AssocElems
277 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
279 -- Turn the ports and signals from a map into a flat list. This works,
280 -- since the maps must have an identical form by definition. TODO: Check
282 arg_ports = concat (map Foldable.toList (ent_args entity))
283 res_ports = Foldable.toList (ent_res entity)
284 arg_sigs = (concat (map Foldable.toList args))
285 res_sigs = Foldable.toList res
286 -- Extract the id part from the (id, type) tuple
287 ports = (map (fmap fst) (arg_ports ++ res_ports))
288 -- Translate signal numbers into names
289 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
291 -- | Look up a signal in the signal name map
292 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
293 lookupSigName sigs sig = name
295 info = Maybe.fromMaybe
296 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
298 name = Maybe.fromMaybe
299 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
302 -- | Create an VHDL port -> signal association
303 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
304 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
305 mkAssocElem Nothing _ = Nothing
307 -- | Extracts the generated entity id from the given funcdata
308 getEntityId :: FuncData -> Maybe AST.VHDLId
310 case funcEntity fdata of
312 Just e -> case ent_decl e of
314 Just (AST.EntityDec id _) -> Just id
317 FuncData -- | A function from the session
318 -> [AST.LibraryUnit] -- | The entity, architecture and optional package for the function
320 getLibraryUnits fdata =
321 case funcEntity fdata of
327 case funcArch fdata of
330 [AST.LUEntity decl, AST.LUArch arch]
331 ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
333 -- | The VHDL Bit type
334 bit_ty :: AST.TypeMark
335 bit_ty = AST.unsafeVHDLBasicId "Bit"
337 -- | The VHDL Boolean type
338 bool_ty :: AST.TypeMark
339 bool_ty = AST.unsafeVHDLBasicId "Boolean"
341 -- | The VHDL std_logic
342 std_logic_ty :: AST.TypeMark
343 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
345 -- Translate a Haskell type to a VHDL type
346 vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
347 vhdl_ty ty = Maybe.fromMaybe
348 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
351 -- Translate a Haskell type to a VHDL type, optionally generating a type
352 -- declaration for the type.
353 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
355 if Type.coreEqType ty TysWiredIn.boolTy
359 case Type.splitTyConApp_maybe ty of
360 Just (tycon, args) ->
361 let name = TyCon.tyConName tycon in
362 -- TODO: Do something more robust than string matching
363 case Name.getOccString name of
364 "Bit" -> Just ([], std_logic_ty)
368 -- TODO: Find actual number
369 ty_id = mkVHDLId ("vector_" ++ (show len))
371 range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
372 ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
373 ty_dec = AST.TypeDec ty_id ty_def
375 Just ([ty_dec], ty_id)
380 mkVHDLId :: String -> AST.VHDLId
382 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
384 -- Strip invalid characters.
385 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
386 -- Strip multiple adjacent underscores
387 strip_multiscore = concat . map (\cs ->