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 = 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] ++ ty_decls ++ subProgSpecs)
69 type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
70 subProgSpecs = map subProgSpec tyfun_decls
71 subProgSpec = \(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)]
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
132 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
134 type_mark <- vhdl_ty error_msg ty
135 return (id, type_mark)
138 -- | Create the VHDL AST for an entity
140 AST.VHDLId -- | The name of the function
141 -> [Port] -- | The entity's arguments
142 -> Port -- | The entity's result
143 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
145 createEntityAST vhdl_id args res =
146 AST.EntityDec vhdl_id ports
148 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
149 ports = map (mkIfaceSigDec AST.In) args
150 ++ [mkIfaceSigDec AST.Out res]
152 -- Add a clk port if we have state
153 clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
155 -- | Create a port declaration
157 AST.Mode -- | The mode for the port (In / Out)
158 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
159 -> AST.IfaceSigDec -- | The resulting port declaration
161 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
164 -- | Generate a VHDL entity name for the given hsfunc
166 -- TODO: This doesn't work for functions with multiple signatures!
167 -- Use a Basic Id, since using extended id's for entities throws off
168 -- precision and causes problems when generating filenames.
169 mkVHDLBasicId $ hsFuncName hsfunc
172 -- | Create an architecture for a given function
173 createArchitecture ::
174 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
175 -> VHDLSession AST.ArchBody -- ^ The architecture for this function
177 createArchitecture (fname, expr) = do
178 signaturemap <- getA vsSignatures
179 let signature = Maybe.fromMaybe
180 (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
181 (Map.lookup fname signaturemap)
182 let entity_id = ent_id signature
183 -- Strip off lambda's, these will be arguments
184 let (args, letexpr) = CoreSyn.collectBinders expr
185 -- There must be a let at top level
186 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
188 -- Create signal declarations for all binders in the let expression, except
189 -- for the output port (that will already have an output port declared in
191 sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
192 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
194 statementss <- Monad.mapM mkConcSm binds
195 let statements = concat statementss
196 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
198 procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
199 procs' = map AST.CSPSm procs
200 -- mkSigDec only uses vsTypes from the state
204 -- | Looks up all pairs of old state, new state signals, together with
205 -- the state id they represent.
206 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
207 makeStatePairs flatfunc =
208 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
209 | old_info <- map snd (flat_sigs flatfunc)
210 , new_info <- map snd (flat_sigs flatfunc)
211 -- old_info must be an old state (and, because of the next equality,
212 -- new_info must be a new state).
213 , Maybe.isJust $ oldStateId $ sigUse old_info
214 -- And the state numbers must match
215 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
217 -- Replace the second tuple element with the corresponding SignalInfo
218 --args_states = map (Arrow.second $ signalInfo sigs) args
219 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
220 mkStateProcSm (num, old, new) =
221 AST.ProcSm label [clk] [statement]
223 label = mkVHDLExtId $ "state_" ++ (show num)
224 clk = mkVHDLExtId "clk"
225 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
226 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
227 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
228 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
229 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
231 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
233 getSignalId :: SignalInfo -> AST.VHDLId
235 mkVHDLExtId $ Maybe.fromMaybe
236 (error $ "Unnamed signal? This should not happen!")
240 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
242 if True then do --isInternalSigUse use || isStateSigUse use then do
243 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
244 type_mark <- (vhdl_ty error_msg) $ Var.varType bndr
245 return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
249 -- | Transforms a core binding into a VHDL concurrent statement
251 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
252 -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
255 -- Ignore Cast expressions, they should not longer have any meaning as long as
256 -- the type works out.
257 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
259 -- For simple a = b assignments, just generate an unconditional signal
260 -- assignment. This should only happen for dataconstructors without arguments.
261 -- TODO: Integrate this with the below code for application (essentially this
262 -- is an application without arguments)
263 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
265 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
266 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
267 let valargs = get_val_args (Var.varType f) args
268 genApplication (Left bndr) f (map Left valargs)
270 -- A single alt case must be a selector. This means thee scrutinee is a simple
271 -- variable, the alternative is a dataalt with a single non-wild binder that
273 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
275 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
276 case List.elemIndex sel_bndr bndrs of
278 labels <- getFieldLabels (Id.idType scrut)
279 let label = labels!!i
280 let sel_name = mkSelectedName (varToVHDLName scrut) label
281 let sel_expr = AST.PrimName sel_name
282 return [mkUncondAssign (Left bndr) sel_expr]
283 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
285 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
287 -- Multiple case alt are be conditional assignments and have only wild
288 -- binders in the alts and only variables in the case values and a variable
289 -- for a scrutinee. We check the constructor of the second alt, since the
290 -- first is the default case, if there is any.
291 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
293 cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
294 true_expr = (varToVHDLExpr true)
295 false_expr = (varToVHDLExpr false)
297 return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
298 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
299 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
300 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr