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
41 -- import CLasH.VHDL.Testbench
45 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
46 -> CoreSyn.CoreBndr -- ^ Top binder
47 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Test Input
48 -> [(AST.VHDLId, AST.DesignFile)]
50 createDesignFiles init_typestate binds topbind testinput =
51 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
52 map (Arrow.second $ AST.DesignFile full_context) (units ++ [testbench])
55 init_session = VHDLState init_typestate Map.empty
56 (units, final_session') =
57 State.runState (createLibraryUnits binds) init_session
58 (testbench, final_session) =
59 State.runState (createTestBench Nothing testinput topbind) final_session'
60 tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
61 ty_decls = final_session ^. vsType ^. vsTypeDecls
62 tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
63 tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
64 tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
66 AST.Library $ mkVHDLBasicId "IEEE",
67 mkUseAll ["IEEE", "std_logic_1164"],
68 mkUseAll ["IEEE", "numeric_std"],
69 mkUseAll ["std", "textio"]
72 mkUseAll ["work", "types"]
75 type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
76 type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
77 subProgSpecs = map subProgSpec tyfun_decls
78 subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
80 -- Create a use foo.bar.all statement. Takes a list of components in the used
81 -- name. Must contain at least two components
82 mkUseAll :: [String] -> AST.ContextItem
84 AST.Use $ from AST.:.: AST.All
86 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
87 from = foldl select base_prefix (tail ss)
88 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
91 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
92 -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
94 createLibraryUnits binds = do
95 entities <- Monad.mapM createEntity binds
96 archs <- Monad.mapM createArchitecture binds
99 let AST.EntityDec id _ = ent in
100 (id, [AST.LUEntity ent, AST.LUArch arch])
104 -- | Create an entity for a given function
106 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
107 -> VHDLSession AST.EntityDec -- | The resulting entity
109 createEntity (fname, expr) = do
110 -- Strip off lambda's, these will be arguments
111 let (args, letexpr) = CoreSyn.collectBinders expr
112 args' <- Monad.mapM mkMap args
113 -- There must be a let at top level
114 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
116 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
117 let ent_decl' = createEntityAST vhdl_id args' res'
118 let AST.EntityDec entity_id _ = ent_decl'
119 let signature = Entity entity_id args' res'
120 modA vsSignatures (Map.insert fname signature)
124 --[(SignalId, SignalInfo)]
127 -- We only need the vsTypes element from the state
130 --info = Maybe.fromMaybe
131 -- (error $ "Signal not found in the name map? This should not happen!")
132 -- (lookup id sigmap)
133 -- Assume the bndr has a valid VHDL id already
134 id = varToVHDLId bndr
135 ty = Var.varType bndr
136 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
138 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
139 return (id, type_mark)
142 -- | Create the VHDL AST for an entity
144 AST.VHDLId -- | The name of the function
145 -> [Port] -- | The entity's arguments
146 -> Port -- | The entity's result
147 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
149 createEntityAST vhdl_id args res =
150 AST.EntityDec vhdl_id ports
152 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
153 ports = map (mkIfaceSigDec AST.In) args
154 ++ [mkIfaceSigDec AST.Out res]
156 -- Add a clk port if we have state
157 clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
159 -- | Create a port declaration
161 AST.Mode -- | The mode for the port (In / Out)
162 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
163 -> AST.IfaceSigDec -- | The resulting port declaration
165 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
168 -- | Generate a VHDL entity name for the given hsfunc
170 -- TODO: This doesn't work for functions with multiple signatures!
171 -- Use a Basic Id, since using extended id's for entities throws off
172 -- precision and causes problems when generating filenames.
173 mkVHDLBasicId $ hsFuncName hsfunc
176 -- | Create an architecture for a given function
177 createArchitecture ::
178 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
179 -> VHDLSession AST.ArchBody -- ^ The architecture for this function
181 createArchitecture (fname, expr) = do
182 signaturemap <- getA vsSignatures
183 let signature = Maybe.fromMaybe
184 (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
185 (Map.lookup fname signaturemap)
186 let entity_id = ent_id signature
187 -- Strip off lambda's, these will be arguments
188 let (args, letexpr) = CoreSyn.collectBinders expr
189 -- There must be a let at top level
190 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
192 -- Create signal declarations for all binders in the let expression, except
193 -- for the output port (that will already have an output port declared in
195 sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
196 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
198 statementss <- Monad.mapM mkConcSm binds
199 let statements = concat statementss
200 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
202 procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
203 procs' = map AST.CSPSm procs
204 -- mkSigDec only uses vsTypes from the state
208 -- | Looks up all pairs of old state, new state signals, together with
209 -- the state id they represent.
210 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
211 makeStatePairs flatfunc =
212 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
213 | old_info <- map snd (flat_sigs flatfunc)
214 , new_info <- map snd (flat_sigs flatfunc)
215 -- old_info must be an old state (and, because of the next equality,
216 -- new_info must be a new state).
217 , Maybe.isJust $ oldStateId $ sigUse old_info
218 -- And the state numbers must match
219 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
221 -- Replace the second tuple element with the corresponding SignalInfo
222 --args_states = map (Arrow.second $ signalInfo sigs) args
223 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
224 mkStateProcSm (num, old, new) =
225 AST.ProcSm label [clk] [statement]
227 label = mkVHDLExtId $ "state_" ++ (show num)
228 clk = mkVHDLExtId "clk"
229 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
230 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
231 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
232 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
233 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
235 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
237 getSignalId :: SignalInfo -> AST.VHDLId
239 mkVHDLExtId $ Maybe.fromMaybe
240 (error $ "Unnamed signal? This should not happen!")
244 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
246 if True then do --isInternalSigUse use || isStateSigUse use then do
247 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
248 type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
249 return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
253 -- | Transforms a core binding into a VHDL concurrent statement
255 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
256 -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
259 -- Ignore Cast expressions, they should not longer have any meaning as long as
260 -- the type works out.
261 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
263 -- Simple a = b assignments are just like applications, but without arguments.
264 -- We can't just generate an unconditional assignment here, since b might be a
265 -- top level binding (e.g., a function with no arguments).
266 mkConcSm (bndr, Var v) = do
267 genApplication (Left bndr) v []
269 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
270 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
271 let valargs = get_val_args (Var.varType f) args
272 genApplication (Left bndr) f (map Left valargs)
274 -- A single alt case must be a selector. This means thee scrutinee is a simple
275 -- variable, the alternative is a dataalt with a single non-wild binder that
277 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
279 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
280 case List.elemIndex sel_bndr bndrs of
282 labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
283 let label = labels!!i
284 let sel_name = mkSelectedName (varToVHDLName scrut) label
285 let sel_expr = AST.PrimName sel_name
286 return [mkUncondAssign (Left bndr) sel_expr]
287 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
289 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
291 -- Multiple case alt are be conditional assignments and have only wild
292 -- binders in the alts and only variables in the case values and a variable
293 -- for a scrutinee. We check the constructor of the second alt, since the
294 -- first is the default case, if there is any.
295 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
296 scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
297 let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
298 true_expr <- MonadState.lift vsType $ varToVHDLExpr true
299 false_expr <- MonadState.lift vsType $ varToVHDLExpr false
300 return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
302 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
303 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
304 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
308 Maybe Int -- ^ Number of cycles to simulate
309 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
310 -> CoreSyn.CoreBndr -- ^ Top Entity
311 -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench
312 createTestBench mCycles stimuli topEntity = do
313 ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity
314 arch <- createTestBenchArch mCycles stimuli topEntity
315 return (id, [AST.LUEntity ent, AST.LUArch arch])
318 createTestBenchEntity ::
319 CoreSyn.CoreBndr -- ^ Top Entity
320 -> VHDLSession AST.EntityDec -- ^ TB Entity
321 createTestBenchEntity topEntity = do
322 signaturemap <- getA vsSignatures
323 let signature = Maybe.fromMaybe
324 (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
325 (Map.lookup topEntity signaturemap)
326 let signaturename = ent_id signature
327 return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") []
329 createTestBenchArch ::
330 Maybe Int -- ^ Number of cycles to simulate
331 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie
332 -> CoreSyn.CoreBndr -- ^ Top Entity
333 -> VHDLSession AST.ArchBody
334 createTestBenchArch mCycles stimuli topEntity = do
335 signaturemap <- getA vsSignatures
336 let signature = Maybe.fromMaybe
337 (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
338 (Map.lookup topEntity signaturemap)
339 let entId = ent_id signature
340 iIface = ent_args signature
341 oIface = ent_res signature
342 iIds = map fst iIface
344 let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
345 let finalIDecs = iDecs ++
346 [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
347 AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
348 let oDecs = AST.SigDec (fst oIface) (snd oIface) Nothing
349 let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature
350 let mIns = mkComponentInst "totest" entId portmaps
351 (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds)
352 let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
354 (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
355 Nothing)) : stimuliAssigns
356 let clkProc = createClkProc
357 let outputProc = createOutputProc [oIds]
358 return $ (AST.ArchBody
359 (AST.unsafeVHDLBasicId "test")
360 (AST.NSimple $ AST.unsafeIdAppend entId "_tb")
361 (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
363 ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) )
365 createStimuliAssigns ::
366 Maybe Int -- ^ Number of cycles to simulate
367 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
368 -> AST.VHDLId -- ^ Input signal
369 -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int)
370 createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles)
372 createStimuliAssigns mCycles stimuli signal = do
373 let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
374 let inputlen = length stimuli
375 assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
376 let resvars = (map snd assigns)
377 sig_dec_maybes <- mapM mkSigDec resvars
378 let sig_decs = Maybe.catMaybes sig_dec_maybes
379 outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars
380 let wformelems = zipWith genWformElem [0,10..] outps
381 let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
382 return ((map fst assigns) ++ [inassign], sig_decs, inputlen)
384 createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var)
385 createStimulans (bndr, expr) cycl = do
386 -- There must be a let at top level
387 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr
388 stimulansbinds <- Monad.mapM mkConcSm binds
389 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
390 let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
391 let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
392 let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds)
393 return (AST.CSBSm block, res)
395 -- | generates a clock process with a period of 10ns
396 createClkProc :: AST.ProcSm
397 createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
398 where sms = -- wait for 5 ns -- (half a cycle)
399 [AST.WaitFor $ AST.PrimLit "5 ns",
401 AST.NSimple clockId `AST.SigAssign`
402 AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
404 -- | generate the output process
405 createOutputProc :: [AST.VHDLId] -- ^ output signal
407 createOutputProc outs =
408 AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
410 [AST.IfSm clkPred (writeOuts outs) [] Nothing]
411 where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
414 (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
415 writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
417 writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
418 writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
419 writeOut outSig suffix =
420 genExprFCall2 writeId
421 (AST.PrimName $ AST.NSimple outputId)
422 (genExprFCall1 showId ((AST.PrimName $ AST.NSimple outSig) AST.:&: suffix))
423 genExprFCall2 entid arg1 arg2 =
424 AST.ProcCall (AST.NSimple entid) $
425 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
426 genExprFCall1 entid arg =
427 AST.PrimFCall $ AST.FCall (AST.NSimple entid) $
428 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg]