2 -- Functions to generate VHDL from FlatFunctions
6 import qualified Data.Foldable as Foldable
8 import qualified Control.Monad as Monad
9 import qualified Control.Arrow as Arrow
10 import qualified Data.Traversable as Traversable
11 import qualified Data.Monoid as Monoid
14 import qualified TysWiredIn
16 import qualified TyCon
17 import Outputable ( showSDoc, ppr )
19 import qualified ForSyDe.Backend.VHDL.AST as AST
24 import TranslatorTypes
27 getDesignFiles :: VHDLState [AST.DesignFile]
29 -- Extract the library units generated from all the functions in the
32 let units = Maybe.mapMaybe getLibraryUnits funcs
34 AST.Library $ mkVHDLId "IEEE",
35 AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
36 return $ map (AST.DesignFile context) units
38 -- | Create an entity for a given function
40 HsFunction -- | The function signature
41 -> FuncData -- | The function data collected so far
44 createEntity hsfunc fdata =
45 let func = flatFunc fdata in
47 -- Skip (builtin) functions without a FlatFunction
48 Nothing -> do return ()
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'
64 entity' = Entity entity_id args' res' (Just ent_decl') pkg_decl
66 setEntity hsfunc entity'
69 [(SignalId, SignalInfo)]
71 -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
73 if isPortSigUse $ sigUse info
75 let (decs, type_mark) = vhdl_ty ty in
76 (decs, Just (mkVHDLId nm, type_mark))
78 (Monoid.mempty, Nothing)
80 info = Maybe.fromMaybe
81 (error $ "Signal not found in the name map? This should not happen!")
84 (error $ "Signal not named? This should not happen!")
88 -- | Create the VHDL AST for an entity
90 HsFunction -- | The signature of the function we're working with
91 -> [VHDLSignalMap] -- | The entity's arguments
92 -> VHDLSignalMap -- | The entity's result
93 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
95 createEntityAST hsfunc args res =
96 AST.EntityDec vhdl_id ports
98 vhdl_id = mkEntityId hsfunc
99 ports = concatMap (mapToPorts AST.In) args
100 ++ mapToPorts AST.Out res
102 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
104 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
105 -- Add a clk port if we have state
106 clk_port = if hasState hsfunc
108 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
112 -- | Create a port declaration
114 AST.Mode -- | The mode for the port (In / Out)
115 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
116 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
118 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
119 mkIfaceSigDec _ Nothing = Nothing
121 -- | Generate a VHDL entity name for the given hsfunc
123 -- TODO: This doesn't work for functions with multiple signatures!
124 mkVHDLId $ hsFuncName hsfunc
126 -- | Create an architecture for a given function
127 createArchitecture ::
128 HsFunction -- | The function signature
129 -> FuncData -- | The function data collected so far
132 createArchitecture hsfunc fdata =
133 let func = flatFunc fdata in
135 -- Skip (builtin) functions without a FlatFunction
136 Nothing -> do return ()
137 -- Create an architecture for all other functions
139 let sigs = flat_sigs flatfunc
140 let args = flat_args flatfunc
141 let res = flat_res flatfunc
142 let defs = flat_defs flatfunc
143 let 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 let (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 <- mapM (mkConcSm sigs) defs
153 let procs = map mkStateProcSm (makeStatePairs flatfunc)
154 let procs' = map AST.CSPSm procs
155 let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
156 setArchitecture hsfunc arch
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 [(SignalId, SignalInfo)] -- | The signals in the current architecture
207 -> SigDef -- | The signal definition
208 -> VHDLState AST.ConcSm -- | The corresponding VHDL component instantiation.
210 mkConcSm sigs (FApp hsfunc args res) = do
211 fdata_maybe <- getFunc hsfunc
212 let fdata = Maybe.fromMaybe
213 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
215 let entity = Maybe.fromMaybe
216 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
218 let entity_id = ent_id entity
219 label <- uniqueName (AST.fromVHDLId entity_id)
220 -- Add a clk port if we have state
221 let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
222 let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
223 return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
225 mkConcSm sigs (UncondDef src dst) = do
226 let src_expr = vhdl_expr src
227 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
228 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
229 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
230 return $ AST.CSSASm assign
232 vhdl_expr (Left id) = mkIdExpr sigs id
233 vhdl_expr (Right expr) =
236 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
240 (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
242 mkConcSm sigs (CondDef cond true false dst) = do
243 let cond_expr = mkIdExpr sigs cond
244 let true_expr = mkIdExpr sigs true
245 let false_expr = mkIdExpr sigs false
246 let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
247 let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
248 let whenelse = AST.WhenElse true_wform cond_expr
249 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
250 let assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
251 return $ AST.CSSASm assign
253 -- | Turn a SignalId into a VHDL Expr
254 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
256 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
257 AST.PrimName src_name
260 [(SignalId, SignalInfo)] -- | The signals in the current architecture
261 -> [SignalMap] -- | The signals that are applied to function
262 -> SignalMap -- | the signals in which to store the function result
263 -> Entity -- | The entity to map against.
264 -> [AST.AssocElem] -- | The resulting port maps
266 mkAssocElems sigmap args res entity =
267 -- Create the actual AssocElems
268 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
270 -- Turn the ports and signals from a map into a flat list. This works,
271 -- since the maps must have an identical form by definition. TODO: Check
273 arg_ports = concat (map Foldable.toList (ent_args entity))
274 res_ports = Foldable.toList (ent_res entity)
275 arg_sigs = (concat (map Foldable.toList args))
276 res_sigs = Foldable.toList res
277 -- Extract the id part from the (id, type) tuple
278 ports = (map (fmap fst) (arg_ports ++ res_ports))
279 -- Translate signal numbers into names
280 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
282 -- | Look up a signal in the signal name map
283 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
284 lookupSigName sigs sig = name
286 info = Maybe.fromMaybe
287 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
289 name = Maybe.fromMaybe
290 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
293 -- | Create an VHDL port -> signal association
294 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
295 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
296 mkAssocElem Nothing _ = Nothing
298 -- | Extracts the generated entity id from the given funcdata
299 getEntityId :: FuncData -> Maybe AST.VHDLId
301 case funcEntity fdata of
303 Just e -> case ent_decl e of
305 Just (AST.EntityDec id _) -> Just id
308 (HsFunction, FuncData) -- | A function from the session
309 -> Maybe [AST.LibraryUnit] -- | The entity, architecture and optional package for the function
311 getLibraryUnits (hsfunc, fdata) =
312 case funcEntity fdata of
318 case funcArch fdata of
322 [AST.LUEntity decl, AST.LUArch arch]
323 ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
325 -- | The VHDL Bit type
326 bit_ty :: AST.TypeMark
327 bit_ty = AST.unsafeVHDLBasicId "Bit"
329 -- | The VHDL Boolean type
330 bool_ty :: AST.TypeMark
331 bool_ty = AST.unsafeVHDLBasicId "Boolean"
333 -- | The VHDL std_logic
334 std_logic_ty :: AST.TypeMark
335 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
337 -- Translate a Haskell type to a VHDL type
338 vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
339 vhdl_ty ty = Maybe.fromMaybe
340 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
343 -- Translate a Haskell type to a VHDL type, optionally generating a type
344 -- declaration for the type.
345 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
347 if Type.coreEqType ty TysWiredIn.boolTy
351 case Type.splitTyConApp_maybe ty of
352 Just (tycon, args) ->
353 let name = TyCon.tyConName tycon in
354 -- TODO: Do something more robust than string matching
355 case Name.getOccString name of
356 "Bit" -> Just ([], std_logic_ty)
360 -- TODO: Find actual number
361 ty_id = mkVHDLId ("vector_" ++ (show len))
363 range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
364 ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
365 ty_dec = AST.TypeDec ty_id ty_def
367 Just ([ty_dec], ty_id)
372 mkVHDLId :: String -> AST.VHDLId
374 AST.unsafeVHDLBasicId s'
376 -- Strip invalid characters.
377 s' = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.") s