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