2 -- Functions to generate VHDL from FlatFunctions
4 module CLasH.VHDL where
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 Language.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 )
35 import CLasH.VHDL.VHDLTypes
36 import CLasH.VHDL.VHDLTools
37 import CLasH.Utils.Pretty
38 import CLasH.Utils.Core.CoreTools
39 import CLasH.VHDL.Constants
40 import CLasH.VHDL.Generate
44 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
45 -> [(AST.VHDLId, AST.DesignFile)]
47 createDesignFiles init_typestate binds =
48 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
49 map (Arrow.second $ AST.DesignFile full_context) units
52 init_session = VHDLState init_typestate Map.empty
53 (units, final_session) =
54 State.runState (createLibraryUnits binds) init_session
55 tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
56 ty_decls = final_session ^. vsType ^. vsTypeDecls
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] ++ 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
74 -- Create a use foo.bar.all statement. Takes a list of components in the used
75 -- name. Must contain at least two components
76 mkUseAll :: [String] -> AST.ContextItem
78 AST.Use $ from AST.:.: AST.All
80 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
81 from = foldl select base_prefix (tail ss)
82 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
85 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
86 -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
88 createLibraryUnits binds = do
89 entities <- Monad.mapM createEntity binds
90 archs <- Monad.mapM createArchitecture binds
93 let AST.EntityDec id _ = ent in
94 (id, [AST.LUEntity ent, AST.LUArch arch])
98 -- | Create an entity for a given function
100 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
101 -> VHDLSession AST.EntityDec -- | The resulting entity
103 createEntity (fname, expr) = do
104 -- Strip off lambda's, these will be arguments
105 let (args, letexpr) = CoreSyn.collectBinders expr
106 args' <- Monad.mapM mkMap args
107 -- There must be a let at top level
108 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
110 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
111 let ent_decl' = createEntityAST vhdl_id args' res'
112 let AST.EntityDec entity_id _ = ent_decl'
113 let signature = Entity entity_id args' res'
114 modA vsSignatures (Map.insert fname signature)
118 --[(SignalId, SignalInfo)]
121 -- We only need the vsTypes element from the state
124 --info = Maybe.fromMaybe
125 -- (error $ "Signal not found in the name map? This should not happen!")
126 -- (lookup id sigmap)
127 -- Assume the bndr has a valid VHDL id already
128 id = varToVHDLId bndr
129 ty = Var.varType bndr
130 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
132 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
133 return (id, type_mark)
136 -- | Create the VHDL AST for an entity
138 AST.VHDLId -- | The name of the function
139 -> [Port] -- | The entity's arguments
140 -> Port -- | The entity's result
141 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
143 createEntityAST vhdl_id args res =
144 AST.EntityDec vhdl_id ports
146 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
147 ports = map (mkIfaceSigDec AST.In) args
148 ++ [mkIfaceSigDec AST.Out res]
150 -- Add a clk port if we have state
151 clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
153 -- | Create a port declaration
155 AST.Mode -- | The mode for the port (In / Out)
156 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
157 -> AST.IfaceSigDec -- | The resulting port declaration
159 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
162 -- | Generate a VHDL entity name for the given hsfunc
164 -- TODO: This doesn't work for functions with multiple signatures!
165 -- Use a Basic Id, since using extended id's for entities throws off
166 -- precision and causes problems when generating filenames.
167 mkVHDLBasicId $ hsFuncName hsfunc
170 -- | Create an architecture for a given function
171 createArchitecture ::
172 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
173 -> VHDLSession AST.ArchBody -- ^ The architecture for this function
175 createArchitecture (fname, expr) = do
176 signaturemap <- getA vsSignatures
177 let signature = Maybe.fromMaybe
178 (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
179 (Map.lookup fname signaturemap)
180 let entity_id = ent_id signature
181 -- Strip off lambda's, these will be arguments
182 let (args, letexpr) = CoreSyn.collectBinders expr
183 -- There must be a let at top level
184 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
186 -- Create signal declarations for all binders in the let expression, except
187 -- for the output port (that will already have an output port declared in
189 sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
190 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
192 statementss <- Monad.mapM mkConcSm binds
193 let statements = concat statementss
194 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
196 procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
197 procs' = map AST.CSPSm procs
198 -- mkSigDec only uses vsTypes from the state
202 -- | Looks up all pairs of old state, new state signals, together with
203 -- the state id they represent.
204 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
205 makeStatePairs flatfunc =
206 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
207 | old_info <- map snd (flat_sigs flatfunc)
208 , new_info <- map snd (flat_sigs flatfunc)
209 -- old_info must be an old state (and, because of the next equality,
210 -- new_info must be a new state).
211 , Maybe.isJust $ oldStateId $ sigUse old_info
212 -- And the state numbers must match
213 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
215 -- Replace the second tuple element with the corresponding SignalInfo
216 --args_states = map (Arrow.second $ signalInfo sigs) args
217 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
218 mkStateProcSm (num, old, new) =
219 AST.ProcSm label [clk] [statement]
221 label = mkVHDLExtId $ "state_" ++ (show num)
222 clk = mkVHDLExtId "clk"
223 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
224 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
225 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
226 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
227 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
229 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
231 getSignalId :: SignalInfo -> AST.VHDLId
233 mkVHDLExtId $ Maybe.fromMaybe
234 (error $ "Unnamed signal? This should not happen!")
238 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
240 if True then do --isInternalSigUse use || isStateSigUse use then do
241 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
242 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (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 -- Simple a = b assignments are just like applications, but without arguments.
258 -- We can't just generate an unconditional assignment here, since b might be a
259 -- top level binding (e.g., a function with no arguments).
260 mkConcSm (bndr, Var v) = do
261 genApplication (Left bndr) 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 <- MonadState.lift vsType $ 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 $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
283 _ -> error $ "\nVHDL.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)])) = do
290 scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
291 let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
292 true_expr <- MonadState.lift vsType $ varToVHDLExpr true
293 false_expr <- MonadState.lift vsType $ varToVHDLExpr false
294 return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
296 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
297 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
298 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr