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
15 import Data.Accessor.MonadState as MonadState
19 import qualified ForSyDe.Backend.VHDL.AST as AST
23 --import qualified Type
27 import qualified IdInfo
28 import qualified TyCon
29 import qualified DataCon
30 --import qualified CoreSubst
31 import qualified CoreUtils
32 import Outputable ( showSDoc, ppr )
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 emptyTypeState Map.empty
52 (units, final_session) =
53 State.runState (createLibraryUnits binds) init_session
54 tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
55 ty_decls = final_session ^. vsType ^. vsTypeDecls
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
73 -- Create a use foo.bar.all statement. Takes a list of components in the used
74 -- name. Must contain at least two components
75 mkUseAll :: [String] -> AST.ContextItem
77 AST.Use $ from AST.:.: AST.All
79 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
80 from = foldl select base_prefix (tail ss)
81 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
84 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
85 -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
87 createLibraryUnits binds = do
88 entities <- Monad.mapM createEntity binds
89 archs <- Monad.mapM createArchitecture binds
92 let AST.EntityDec id _ = ent in
93 (id, [AST.LUEntity ent, AST.LUArch arch])
97 -- | Create an entity for a given function
99 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
100 -> VHDLSession AST.EntityDec -- | The resulting entity
102 createEntity (fname, expr) = do
103 -- Strip off lambda's, these will be arguments
104 let (args, letexpr) = CoreSyn.collectBinders expr
105 args' <- Monad.mapM mkMap args
106 -- There must be a let at top level
107 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
109 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
110 let ent_decl' = createEntityAST vhdl_id args' res'
111 let AST.EntityDec entity_id _ = ent_decl'
112 let signature = Entity entity_id args' res'
113 modA vsSignatures (Map.insert fname signature)
117 --[(SignalId, SignalInfo)]
120 -- We only need the vsTypes element from the state
123 --info = Maybe.fromMaybe
124 -- (error $ "Signal not found in the name map? This should not happen!")
125 -- (lookup id sigmap)
126 -- Assume the bndr has a valid VHDL id already
127 id = varToVHDLId bndr
128 ty = Var.varType bndr
129 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
131 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
132 return (id, type_mark)
135 -- | Create the VHDL AST for an entity
137 AST.VHDLId -- | The name of the function
138 -> [Port] -- | The entity's arguments
139 -> Port -- | The entity's result
140 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
142 createEntityAST vhdl_id args res =
143 AST.EntityDec vhdl_id ports
145 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
146 ports = map (mkIfaceSigDec AST.In) args
147 ++ [mkIfaceSigDec AST.Out res]
149 -- Add a clk port if we have state
150 clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
152 -- | Create a port declaration
154 AST.Mode -- | The mode for the port (In / Out)
155 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
156 -> AST.IfaceSigDec -- | The resulting port declaration
158 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
161 -- | Generate a VHDL entity name for the given hsfunc
163 -- TODO: This doesn't work for functions with multiple signatures!
164 -- Use a Basic Id, since using extended id's for entities throws off
165 -- precision and causes problems when generating filenames.
166 mkVHDLBasicId $ hsFuncName hsfunc
169 -- | Create an architecture for a given function
170 createArchitecture ::
171 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
172 -> VHDLSession AST.ArchBody -- ^ The architecture for this function
174 createArchitecture (fname, expr) = do
175 signaturemap <- getA vsSignatures
176 let signature = Maybe.fromMaybe
177 (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
178 (Map.lookup fname signaturemap)
179 let entity_id = ent_id signature
180 -- Strip off lambda's, these will be arguments
181 let (args, letexpr) = CoreSyn.collectBinders expr
182 -- There must be a let at top level
183 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
185 -- Create signal declarations for all binders in the let expression, except
186 -- for the output port (that will already have an output port declared in
188 sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
189 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
191 statementss <- Monad.mapM mkConcSm binds
192 let statements = concat statementss
193 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
195 procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
196 procs' = map AST.CSPSm procs
197 -- mkSigDec only uses vsTypes from the state
201 -- | Looks up all pairs of old state, new state signals, together with
202 -- the state id they represent.
203 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
204 makeStatePairs flatfunc =
205 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
206 | old_info <- map snd (flat_sigs flatfunc)
207 , new_info <- map snd (flat_sigs flatfunc)
208 -- old_info must be an old state (and, because of the next equality,
209 -- new_info must be a new state).
210 , Maybe.isJust $ oldStateId $ sigUse old_info
211 -- And the state numbers must match
212 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
214 -- Replace the second tuple element with the corresponding SignalInfo
215 --args_states = map (Arrow.second $ signalInfo sigs) args
216 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
217 mkStateProcSm (num, old, new) =
218 AST.ProcSm label [clk] [statement]
220 label = mkVHDLExtId $ "state_" ++ (show num)
221 clk = mkVHDLExtId "clk"
222 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
223 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
224 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
225 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
226 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
228 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
230 getSignalId :: SignalInfo -> AST.VHDLId
232 mkVHDLExtId $ Maybe.fromMaybe
233 (error $ "Unnamed signal? This should not happen!")
237 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
239 if True then do --isInternalSigUse use || isStateSigUse use then do
240 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
241 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
242 return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
246 -- | Transforms a core binding into a VHDL concurrent statement
248 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
249 -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
252 -- Ignore Cast expressions, they should not longer have any meaning as long as
253 -- the type works out.
254 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
256 -- For simple a = b assignments, just generate an unconditional signal
257 -- assignment. This should only happen for dataconstructors without arguments.
258 -- TODO: Integrate this with the below code for application (essentially this
259 -- is an application without arguments)
260 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
262 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
263 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
264 let valargs = get_val_args (Var.varType f) args
265 genApplication (Left bndr) f (map Left valargs)
267 -- A single alt case must be a selector. This means thee scrutinee is a simple
268 -- variable, the alternative is a dataalt with a single non-wild binder that
270 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
272 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
273 case List.elemIndex sel_bndr bndrs of
275 labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
276 let label = labels!!i
277 let sel_name = mkSelectedName (varToVHDLName scrut) label
278 let sel_expr = AST.PrimName sel_name
279 return [mkUncondAssign (Left bndr) sel_expr]
280 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
282 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
284 -- Multiple case alt are be conditional assignments and have only wild
285 -- binders in the alts and only variables in the case values and a variable
286 -- for a scrutinee. We check the constructor of the second alt, since the
287 -- first is the default case, if there is any.
288 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
290 cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
291 true_expr = (varToVHDLExpr true)
292 false_expr = (varToVHDLExpr false)
294 return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
295 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
296 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
297 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr