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