2 -- Functions to generate VHDL from FlatFunctions
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 Control.Monad.Trans.State as State
13 import qualified Data.Monoid as Monoid
17 import qualified ForSyDe.Backend.VHDL.AST as AST
21 --import qualified Type
25 import qualified IdInfo
26 import qualified TyCon
27 import qualified DataCon
28 --import qualified CoreSubst
29 import qualified CoreUtils
30 import Outputable ( showSDoc, ppr )
39 import GlobalNameTable
42 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
43 -> [(AST.VHDLId, AST.DesignFile)]
45 createDesignFiles binds =
46 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
47 map (Arrow.second $ AST.DesignFile full_context) units
50 init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
51 (units, final_session) =
52 State.runState (createLibraryUnits binds) init_session
53 tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
54 ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
55 vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
56 tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
57 tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
58 tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
60 AST.Library $ mkVHDLBasicId "IEEE",
61 mkUseAll ["IEEE", "std_logic_1164"],
62 mkUseAll ["IEEE", "numeric_std"]
65 mkUseAll ["work", "types"]
68 type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
69 type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
70 subProgSpecs = concat (map subProgSpec tyfun_decls)
71 subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
72 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
73 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
74 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
76 -- Create a use foo.bar.all statement. Takes a list of components in the used
77 -- name. Must contain at least two components
78 mkUseAll :: [String] -> AST.ContextItem
80 AST.Use $ from AST.:.: AST.All
82 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
83 from = foldl select base_prefix (tail ss)
84 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
87 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
88 -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
90 createLibraryUnits binds = do
91 entities <- Monad.mapM createEntity binds
92 archs <- Monad.mapM createArchitecture binds
95 let AST.EntityDec id _ = ent in
96 (id, [AST.LUEntity ent, AST.LUArch arch])
100 -- | Create an entity for a given function
102 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
103 -> VHDLSession AST.EntityDec -- | The resulting entity
105 createEntity (fname, expr) = do
106 -- Strip off lambda's, these will be arguments
107 let (args, letexpr) = CoreSyn.collectBinders expr
108 args' <- Monad.mapM mkMap args
109 -- There must be a let at top level
110 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
112 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
113 let ent_decl' = createEntityAST vhdl_id args' res'
114 let AST.EntityDec entity_id _ = ent_decl'
115 let signature = Entity entity_id args' res'
116 modA vsSignatures (Map.insert fname signature)
120 --[(SignalId, SignalInfo)]
122 -> VHDLSession VHDLSignalMapElement
123 -- We only need the vsTypes element from the state
126 --info = Maybe.fromMaybe
127 -- (error $ "Signal not found in the name map? This should not happen!")
128 -- (lookup id sigmap)
129 -- Assume the bndr has a valid VHDL id already
130 id = varToVHDLId bndr
131 ty = Var.varType bndr
133 if True -- isPortSigUse $ sigUse info
135 type_mark <- vhdl_ty ty
136 return $ Just (id, type_mark)
141 -- | Create the VHDL AST for an entity
143 AST.VHDLId -- | The name of the function
144 -> [VHDLSignalMapElement] -- | The entity's arguments
145 -> VHDLSignalMapElement -- | The entity's result
146 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
148 createEntityAST vhdl_id args res =
149 AST.EntityDec vhdl_id ports
151 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
152 ports = Maybe.catMaybes $
153 map (mkIfaceSigDec AST.In) args
154 ++ [mkIfaceSigDec AST.Out res]
156 -- Add a clk port if we have state
157 clk_port = if True -- hasState hsfunc
159 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
163 -- | Create a port declaration
165 AST.Mode -- | The mode for the port (In / Out)
166 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
167 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
169 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
170 mkIfaceSigDec _ Nothing = Nothing
173 -- | Generate a VHDL entity name for the given hsfunc
175 -- TODO: This doesn't work for functions with multiple signatures!
176 -- Use a Basic Id, since using extended id's for entities throws off
177 -- precision and causes problems when generating filenames.
178 mkVHDLBasicId $ hsFuncName hsfunc
181 -- | Create an architecture for a given function
182 createArchitecture ::
183 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
184 -> VHDLSession AST.ArchBody -- ^ The architecture for this function
186 createArchitecture (fname, expr) = do
187 signaturemap <- getA vsSignatures
188 let signature = Maybe.fromMaybe
189 (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
190 (Map.lookup fname signaturemap)
191 let entity_id = ent_id signature
192 -- Strip off lambda's, these will be arguments
193 let (args, letexpr) = CoreSyn.collectBinders expr
194 -- There must be a let at top level
195 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
197 -- Create signal declarations for all binders in the let expression, except
198 -- for the output port (that will already have an output port declared in
200 sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
201 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
203 statementss <- Monad.mapM mkConcSm binds
204 let statements = concat statementss
205 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
207 procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
208 procs' = map AST.CSPSm procs
209 -- mkSigDec only uses vsTypes from the state
213 -- | Looks up all pairs of old state, new state signals, together with
214 -- the state id they represent.
215 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
216 makeStatePairs flatfunc =
217 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
218 | old_info <- map snd (flat_sigs flatfunc)
219 , new_info <- map snd (flat_sigs flatfunc)
220 -- old_info must be an old state (and, because of the next equality,
221 -- new_info must be a new state).
222 , Maybe.isJust $ oldStateId $ sigUse old_info
223 -- And the state numbers must match
224 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
226 -- Replace the second tuple element with the corresponding SignalInfo
227 --args_states = map (Arrow.second $ signalInfo sigs) args
228 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
229 mkStateProcSm (num, old, new) =
230 AST.ProcSm label [clk] [statement]
232 label = mkVHDLExtId $ "state_" ++ (show num)
233 clk = mkVHDLExtId "clk"
234 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
235 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
236 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
237 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
238 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
240 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
242 getSignalId :: SignalInfo -> AST.VHDLId
244 mkVHDLExtId $ Maybe.fromMaybe
245 (error $ "Unnamed signal? This should not happen!")
249 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
251 if True then do --isInternalSigUse use || isStateSigUse use then do
252 type_mark <- vhdl_ty $ Var.varType bndr
253 return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
257 -- | Transforms a core binding into a VHDL concurrent statement
259 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
260 -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
263 -- Ignore Cast expressions, they should not longer have any meaning as long as
264 -- the type works out.
265 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
267 -- For simple a = b assignments, just generate an unconditional signal
268 -- assignment. This should only happen for dataconstructors without arguments.
269 -- TODO: Integrate this with the below code for application (essentially this
270 -- is an application without arguments)
271 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
273 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
274 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
275 let valargs' = filter isValArg args
276 let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
277 case Var.globalIdVarDetails f of
278 IdInfo.DataConWorkId dc ->
279 -- It's a datacon. Create a record from its arguments.
280 -- First, filter out type args. TODO: Is this the best way to do this?
281 -- The types should already have been taken into acocunt when creating
282 -- the signal, so this should probably work...
283 --let valargs = filter isValArg args in
284 if all is_var valargs then do
285 labels <- getFieldLabels (CoreUtils.exprType app)
286 return $ zipWith mkassign labels valargs
288 error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
290 mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
291 mkassign label (Var arg) =
292 let sel_name = mkSelectedName bndr label in
293 mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
294 IdInfo.VanillaGlobal -> do
295 -- It's a global value imported from elsewhere. These can be builtin
297 signatures <- getA vsSignatures
298 case (Map.lookup (varToString f) globalNameTable) of
299 Just (arg_count, builder) ->
300 if length valargs == arg_count then
302 Left funBuilder -> do
303 let sigs = map (varToVHDLExpr.exprToVar) valargs
304 func <- funBuilder sigs
305 let src_wform = AST.Wform [AST.WformElem func Nothing]
306 let dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))
307 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
308 return [AST.CSSASm assign]
309 Right genBuilder -> do
310 let sigs = map exprToVar valargs
311 let signature = Maybe.fromMaybe
312 (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!")
313 (Map.lookup (head sigs) signatures)
315 genSm <- genBuilder signature (arg ++ [bndr])
316 return [AST.CSGSm genSm]
318 error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
319 Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
320 IdInfo.NotGlobalId -> do
321 signatures <- getA vsSignatures
322 -- This is a local id, so it should be a function whose definition we
323 -- have and which can be turned into a component instantiation.
325 signature = Maybe.fromMaybe
326 (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
327 (Map.lookup f signatures)
328 entity_id = ent_id signature
329 label = "comp_ins_" ++ varToString bndr
330 -- Add a clk port if we have state
331 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
332 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
333 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
334 portmaps = clk_port : mkAssocElems args bndr signature
336 return [mkComponentInst label entity_id portmaps]
337 details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
339 -- A single alt case must be a selector. This means thee scrutinee is a simple
340 -- variable, the alternative is a dataalt with a single non-wild binder that
342 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
344 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
345 case List.elemIndex sel_bndr bndrs of
347 labels <- getFieldLabels (Id.idType scrut)
348 let label = labels!!i
349 let sel_name = mkSelectedName scrut label
350 let sel_expr = AST.PrimName sel_name
351 return [mkUncondAssign (Left bndr) sel_expr]
352 Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
354 _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
356 -- Multiple case alt are be conditional assignments and have only wild
357 -- binders in the alts and only variables in the case values and a variable
358 -- for a scrutinee. We check the constructor of the second alt, since the
359 -- first is the default case, if there is any.
360 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
362 cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
363 true_expr = (varToVHDLExpr true)
364 false_expr = (varToVHDLExpr false)
366 return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
367 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
368 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
369 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr