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 )
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
51 (units, final_session) =
52 State.runState (createLibraryUnits binds) init_session
53 tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns)
54 ty_decls = final_session ^.vsTypeDecls
55 tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
56 tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
57 tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
59 AST.Library $ mkVHDLBasicId "IEEE",
60 mkUseAll ["IEEE", "std_logic_1164"],
61 mkUseAll ["IEEE", "numeric_std"]
64 mkUseAll ["work", "types"]
67 type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
68 type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
69 subProgSpecs = map subProgSpec tyfun_decls
70 subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
72 -- Create a use foo.bar.all statement. Takes a list of components in the used
73 -- name. Must contain at least two components
74 mkUseAll :: [String] -> AST.ContextItem
76 AST.Use $ from AST.:.: AST.All
78 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
79 from = foldl select base_prefix (tail ss)
80 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
83 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
84 -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
86 createLibraryUnits binds = do
87 entities <- Monad.mapM createEntity binds
88 archs <- Monad.mapM createArchitecture binds
91 let AST.EntityDec id _ = ent in
92 (id, [AST.LUEntity ent, AST.LUArch arch])
96 -- | Create an entity for a given function
98 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
99 -> VHDLSession AST.EntityDec -- | The resulting entity
101 createEntity (fname, expr) = do
102 -- Strip off lambda's, these will be arguments
103 let (args, letexpr) = CoreSyn.collectBinders expr
104 args' <- Monad.mapM mkMap args
105 -- There must be a let at top level
106 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
108 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
109 let ent_decl' = createEntityAST vhdl_id args' res'
110 let AST.EntityDec entity_id _ = ent_decl'
111 let signature = Entity entity_id args' res'
112 modA vsSignatures (Map.insert fname signature)
116 --[(SignalId, SignalInfo)]
119 -- We only need the vsTypes element from the state
122 --info = Maybe.fromMaybe
123 -- (error $ "Signal not found in the name map? This should not happen!")
124 -- (lookup id sigmap)
125 -- Assume the bndr has a valid VHDL id already
126 id = varToVHDLId bndr
127 ty = Var.varType bndr
128 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
130 type_mark <- vhdl_ty error_msg ty
131 return (id, type_mark)
134 -- | Create the VHDL AST for an entity
136 AST.VHDLId -- | The name of the function
137 -> [Port] -- | The entity's arguments
138 -> Port -- | The entity's result
139 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
141 createEntityAST vhdl_id args res =
142 AST.EntityDec vhdl_id ports
144 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
145 ports = map (mkIfaceSigDec AST.In) args
146 ++ [mkIfaceSigDec AST.Out res]
148 -- Add a clk port if we have state
149 clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
151 -- | Create a port declaration
153 AST.Mode -- | The mode for the port (In / Out)
154 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
155 -> AST.IfaceSigDec -- | The resulting port declaration
157 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
160 -- | Generate a VHDL entity name for the given hsfunc
162 -- TODO: This doesn't work for functions with multiple signatures!
163 -- Use a Basic Id, since using extended id's for entities throws off
164 -- precision and causes problems when generating filenames.
165 mkVHDLBasicId $ hsFuncName hsfunc
168 -- | Create an architecture for a given function
169 createArchitecture ::
170 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
171 -> VHDLSession AST.ArchBody -- ^ The architecture for this function
173 createArchitecture (fname, expr) = do
174 signaturemap <- getA vsSignatures
175 let signature = Maybe.fromMaybe
176 (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
177 (Map.lookup fname signaturemap)
178 let entity_id = ent_id signature
179 -- Strip off lambda's, these will be arguments
180 let (args, letexpr) = CoreSyn.collectBinders expr
181 -- There must be a let at top level
182 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
184 -- Create signal declarations for all binders in the let expression, except
185 -- for the output port (that will already have an output port declared in
187 sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
188 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
190 statementss <- Monad.mapM mkConcSm binds
191 let statements = concat statementss
192 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
194 procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
195 procs' = map AST.CSPSm procs
196 -- mkSigDec only uses vsTypes from the state
200 -- | Looks up all pairs of old state, new state signals, together with
201 -- the state id they represent.
202 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
203 makeStatePairs flatfunc =
204 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
205 | old_info <- map snd (flat_sigs flatfunc)
206 , new_info <- map snd (flat_sigs flatfunc)
207 -- old_info must be an old state (and, because of the next equality,
208 -- new_info must be a new state).
209 , Maybe.isJust $ oldStateId $ sigUse old_info
210 -- And the state numbers must match
211 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
213 -- Replace the second tuple element with the corresponding SignalInfo
214 --args_states = map (Arrow.second $ signalInfo sigs) args
215 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
216 mkStateProcSm (num, old, new) =
217 AST.ProcSm label [clk] [statement]
219 label = mkVHDLExtId $ "state_" ++ (show num)
220 clk = mkVHDLExtId "clk"
221 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
222 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
223 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
224 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
225 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
227 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
229 getSignalId :: SignalInfo -> AST.VHDLId
231 mkVHDLExtId $ Maybe.fromMaybe
232 (error $ "Unnamed signal? This should not happen!")
236 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
238 if True then do --isInternalSigUse use || isStateSigUse use then do
239 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
240 type_mark <- (vhdl_ty error_msg) $ Var.varType bndr
241 return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
245 -- | Transforms a core binding into a VHDL concurrent statement
247 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
248 -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
251 -- Ignore Cast expressions, they should not longer have any meaning as long as
252 -- the type works out.
253 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
255 -- For simple a = b assignments, just generate an unconditional signal
256 -- assignment. This should only happen for dataconstructors without arguments.
257 -- TODO: Integrate this with the below code for application (essentially this
258 -- is an application without arguments)
259 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
261 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
262 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
263 let valargs = get_val_args (Var.varType f) args
264 genApplication (Left bndr) f (map Left valargs)
266 -- A single alt case must be a selector. This means thee scrutinee is a simple
267 -- variable, the alternative is a dataalt with a single non-wild binder that
269 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
271 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
272 case List.elemIndex sel_bndr bndrs of
274 labels <- getFieldLabels (Id.idType scrut)
275 let label = labels!!i
276 let sel_name = mkSelectedName (varToVHDLName scrut) label
277 let sel_expr = AST.PrimName sel_name
278 return [mkUncondAssign (Left bndr) sel_expr]
279 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
281 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
283 -- Multiple case alt are be conditional assignments and have only wild
284 -- binders in the alts and only variables in the case values and a variable
285 -- for a scrutinee. We check the constructor of the second alt, since the
286 -- first is the default case, if there is any.
287 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
289 cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
290 true_expr = (varToVHDLExpr true)
291 false_expr = (varToVHDLExpr false)
293 return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
294 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
295 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
296 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr