2 -- Functions to generate VHDL from FlatFunctions
6 import qualified Data.Foldable as Foldable
7 import qualified Data.List as List
9 import qualified Control.Monad as Monad
10 import qualified Control.Arrow as Arrow
11 import qualified Data.Traversable as Traversable
12 import qualified Data.Monoid as Monoid
15 import qualified TysWiredIn
17 import qualified TyCon
18 import Outputable ( showSDoc, ppr )
20 import qualified ForSyDe.Backend.VHDL.AST as AST
25 import TranslatorTypes
28 getDesignFiles :: [FuncData] -> [AST.DesignFile]
29 getDesignFiles funcs =
30 map (AST.DesignFile context) units
32 units = filter (not.null) $ map getLibraryUnits funcs
34 AST.Library $ mkVHDLId "IEEE",
35 AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
37 -- | Create an entity for a given function
39 HsFunction -- | The function signature
40 -> FuncData -- | The function data collected so far
41 -> Maybe Entity -- | The resulting entity
43 createEntity hsfunc fdata =
44 case flatFunc fdata of
45 -- Skip (builtin) functions without a FlatFunction
47 -- Create an entity for all other functions
50 sigs = flat_sigs flatfunc
51 args = flat_args flatfunc
52 res = flat_res flatfunc
53 (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
54 (ty_decls', res') = Traversable.traverse (mkMap sigs) res
55 -- TODO: Unique ty_decls
56 ent_decl' = createEntityAST hsfunc args' res'
57 pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
58 pkg_decl = if null ty_decls && null ty_decls'
60 else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
61 AST.EntityDec entity_id _ = ent_decl'
63 Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl
66 [(SignalId, SignalInfo)]
68 -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
70 if isPortSigUse $ sigUse info
72 let (decs, type_mark) = vhdl_ty ty in
73 (decs, Just (mkVHDLId nm, type_mark))
75 (Monoid.mempty, Nothing)
77 info = Maybe.fromMaybe
78 (error $ "Signal not found in the name map? This should not happen!")
81 (error $ "Signal not named? This should not happen!")
85 -- | Create the VHDL AST for an entity
87 HsFunction -- | The signature of the function we're working with
88 -> [VHDLSignalMap] -- | The entity's arguments
89 -> VHDLSignalMap -- | The entity's result
90 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
92 createEntityAST hsfunc args res =
93 AST.EntityDec vhdl_id ports
95 vhdl_id = mkEntityId hsfunc
96 ports = concatMap (mapToPorts AST.In) args
97 ++ mapToPorts AST.Out res
99 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
101 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
102 -- Add a clk port if we have state
103 clk_port = if hasState hsfunc
105 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
109 -- | Create a port declaration
111 AST.Mode -- | The mode for the port (In / Out)
112 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
113 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
115 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
116 mkIfaceSigDec _ Nothing = Nothing
118 -- | Generate a VHDL entity name for the given hsfunc
120 -- TODO: This doesn't work for functions with multiple signatures!
121 mkVHDLId $ hsFuncName hsfunc
123 -- | Create an architecture for a given function
124 createArchitecture ::
125 HsFunction -- | The function signature
126 -> FuncData -- | The function data collected so far
129 createArchitecture hsfunc fdata =
130 let func = flatFunc fdata in
132 -- Skip (builtin) functions without a FlatFunction
133 Nothing -> do return ()
134 -- Create an architecture for all other functions
136 let sigs = flat_sigs flatfunc
137 let args = flat_args flatfunc
138 let res = flat_res flatfunc
139 let defs = flat_defs flatfunc
140 let entity_id = Maybe.fromMaybe
141 (error $ "Building architecture without an entity? This should not happen!")
143 -- Create signal declarations for all signals that are not in args and
145 let (ty_decls, sig_decs) = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
146 -- TODO: Unique ty_decls
147 -- TODO: Store ty_decls somewhere
148 -- Create concurrent statements for all signal definitions
149 statements <- mapM (mkConcSm sigs) defs
150 let procs = map mkStateProcSm (makeStatePairs flatfunc)
151 let procs' = map AST.CSPSm procs
152 let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
153 setArchitecture hsfunc arch
155 -- | Looks up all pairs of old state, new state signals, together with
156 -- the state id they represent.
157 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
158 makeStatePairs flatfunc =
159 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
160 | old_info <- map snd (flat_sigs flatfunc)
161 , new_info <- map snd (flat_sigs flatfunc)
162 -- old_info must be an old state (and, because of the next equality,
163 -- new_info must be a new state).
164 , Maybe.isJust $ oldStateId $ sigUse old_info
165 -- And the state numbers must match
166 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
168 -- Replace the second tuple element with the corresponding SignalInfo
169 --args_states = map (Arrow.second $ signalInfo sigs) args
170 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
171 mkStateProcSm (num, old, new) =
172 AST.ProcSm label [clk] [statement]
174 label = mkVHDLId $ "state_" ++ (show num)
176 rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
177 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
178 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
179 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
180 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
182 mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
184 let use = sigUse info in
185 if isInternalSigUse use || isStateSigUse use then
186 let (ty_decls, type_mark) = vhdl_ty ty in
187 (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
193 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
195 getSignalId :: SignalInfo -> AST.VHDLId
197 mkVHDLId $ Maybe.fromMaybe
198 (error $ "Unnamed signal? This should not happen!")
201 -- | Transforms a signal definition into a VHDL concurrent statement
203 [(SignalId, SignalInfo)] -- | The signals in the current architecture
204 -> SigDef -- | The signal definition
205 -> VHDLState AST.ConcSm -- | The corresponding VHDL component instantiation.
207 mkConcSm sigs (FApp hsfunc args res) = do
208 fdata_maybe <- getFunc hsfunc
209 let fdata = Maybe.fromMaybe
210 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
212 let entity = Maybe.fromMaybe
213 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
215 let entity_id = ent_id entity
216 label <- uniqueName (AST.fromVHDLId entity_id)
217 -- Add a clk port if we have state
218 let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
219 let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
220 return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
222 mkConcSm sigs (UncondDef src dst) = do
223 let src_expr = vhdl_expr src
224 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
225 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
226 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
227 return $ AST.CSSASm assign
229 vhdl_expr (Left id) = mkIdExpr sigs id
230 vhdl_expr (Right expr) =
233 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
237 (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
239 mkConcSm sigs (CondDef cond true false dst) = do
240 let cond_expr = mkIdExpr sigs cond
241 let true_expr = mkIdExpr sigs true
242 let false_expr = mkIdExpr sigs false
243 let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
244 let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
245 let whenelse = AST.WhenElse true_wform cond_expr
246 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
247 let assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
248 return $ AST.CSSASm assign
250 -- | Turn a SignalId into a VHDL Expr
251 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
253 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
254 AST.PrimName src_name
257 [(SignalId, SignalInfo)] -- | The signals in the current architecture
258 -> [SignalMap] -- | The signals that are applied to function
259 -> SignalMap -- | the signals in which to store the function result
260 -> Entity -- | The entity to map against.
261 -> [AST.AssocElem] -- | The resulting port maps
263 mkAssocElems sigmap args res entity =
264 -- Create the actual AssocElems
265 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
267 -- Turn the ports and signals from a map into a flat list. This works,
268 -- since the maps must have an identical form by definition. TODO: Check
270 arg_ports = concat (map Foldable.toList (ent_args entity))
271 res_ports = Foldable.toList (ent_res entity)
272 arg_sigs = (concat (map Foldable.toList args))
273 res_sigs = Foldable.toList res
274 -- Extract the id part from the (id, type) tuple
275 ports = (map (fmap fst) (arg_ports ++ res_ports))
276 -- Translate signal numbers into names
277 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
279 -- | Look up a signal in the signal name map
280 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
281 lookupSigName sigs sig = name
283 info = Maybe.fromMaybe
284 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
286 name = Maybe.fromMaybe
287 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
290 -- | Create an VHDL port -> signal association
291 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
292 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
293 mkAssocElem Nothing _ = Nothing
295 -- | Extracts the generated entity id from the given funcdata
296 getEntityId :: FuncData -> Maybe AST.VHDLId
298 case funcEntity fdata of
300 Just e -> case ent_decl e of
302 Just (AST.EntityDec id _) -> Just id
305 FuncData -- | A function from the session
306 -> [AST.LibraryUnit] -- | The entity, architecture and optional package for the function
308 getLibraryUnits fdata =
309 case funcEntity fdata of
315 case funcArch fdata of
318 [AST.LUEntity decl, AST.LUArch arch]
319 ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
321 -- | The VHDL Bit type
322 bit_ty :: AST.TypeMark
323 bit_ty = AST.unsafeVHDLBasicId "Bit"
325 -- | The VHDL Boolean type
326 bool_ty :: AST.TypeMark
327 bool_ty = AST.unsafeVHDLBasicId "Boolean"
329 -- | The VHDL std_logic
330 std_logic_ty :: AST.TypeMark
331 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
333 -- Translate a Haskell type to a VHDL type
334 vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
335 vhdl_ty ty = Maybe.fromMaybe
336 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
339 -- Translate a Haskell type to a VHDL type, optionally generating a type
340 -- declaration for the type.
341 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
343 if Type.coreEqType ty TysWiredIn.boolTy
347 case Type.splitTyConApp_maybe ty of
348 Just (tycon, args) ->
349 let name = TyCon.tyConName tycon in
350 -- TODO: Do something more robust than string matching
351 case Name.getOccString name of
352 "Bit" -> Just ([], std_logic_ty)
356 -- TODO: Find actual number
357 ty_id = mkVHDLId ("vector_" ++ (show len))
359 range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
360 ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
361 ty_dec = AST.TypeDec ty_id ty_def
363 Just ([ty_dec], ty_id)
368 mkVHDLId :: String -> AST.VHDLId
370 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
372 -- Strip invalid characters.
373 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
374 -- Strip multiple adjacent underscores
375 strip_multiscore = concat . map (\cs ->