2 -- Functions to generate VHDL from FlatFunctions
4 module CLasH.VHDL where
7 import qualified Data.Map as Map
9 import qualified Control.Monad as Monad
10 import qualified Control.Arrow as Arrow
11 import qualified Control.Monad.Trans.State as State
12 import qualified Data.Monoid as Monoid
14 import Data.Accessor.MonadState as MonadState
18 import qualified Language.VHDL.AST as AST
22 --import qualified Type
25 import qualified IdInfo
26 import qualified TyCon
27 import qualified DataCon
28 --import qualified CoreSubst
29 import qualified CoreUtils
30 import Outputable ( showSDoc, ppr )
33 import CLasH.Translator.TranslatorTypes
34 import CLasH.VHDL.VHDLTypes
35 import CLasH.VHDL.VHDLTools
36 import CLasH.Utils.Pretty
37 import CLasH.Utils.Core.CoreTools
38 import CLasH.VHDL.Constants
39 import CLasH.VHDL.Generate
40 -- import CLasH.VHDL.Testbench
43 [CoreSyn.CoreBndr] -- ^ Top binders
44 -> TranslatorSession [(AST.VHDLId, AST.DesignFile)]
46 createDesignFiles topbndrs = do
47 bndrss <- mapM recurseArchitectures topbndrs
48 let bndrs = concat bndrss
49 lunits <- mapM createLibraryUnit bndrs
50 typepackage <- createTypesPackage
51 let files = map (Arrow.second $ AST.DesignFile full_context) lunits
52 return $ typepackage : files
55 mkUseAll ["work", "types"]
60 AST.Library $ mkVHDLBasicId "IEEE",
61 mkUseAll ["IEEE", "std_logic_1164"],
62 mkUseAll ["IEEE", "numeric_std"],
63 mkUseAll ["std", "textio"]
66 -- | Find out which entities are needed for the given top level binders.
67 recurseArchitectures ::
68 CoreSyn.CoreBndr -- ^ The top level binder
69 -> TranslatorSession [CoreSyn.CoreBndr]
70 -- ^ The binders of all needed functions.
71 recurseArchitectures bndr = do
72 -- See what this binder directly uses
73 (_, used) <- getArchitecture bndr
74 -- Recursively check what each of the used functions uses
75 useds <- mapM recurseArchitectures used
76 -- And return all of them
77 return $ bndr : (concat useds)
79 -- | Creates the types package, based on the current type state.
81 TranslatorSession (AST.VHDLId, AST.DesignFile)
82 -- ^ The id and content of the types package
84 createTypesPackage = do
85 tyfuns <- getA (tsType .> tsTypeFuns)
86 let tyfun_decls = mkBuiltInShow ++ (map snd $ Map.elems tyfuns)
87 ty_decls <- getA (tsType .> tsTypeDecls)
88 let subProgSpecs = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) tyfun_decls
89 let type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
90 let type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
91 return $ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body])
93 tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
94 tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) (AST.NSimple $ highId) Nothing)
95 tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
97 -- Create a use foo.bar.all statement. Takes a list of components in the used
98 -- name. Must contain at least two components
99 mkUseAll :: [String] -> AST.ContextItem
101 AST.Use $ from AST.:.: AST.All
103 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
104 from = foldl select base_prefix (tail ss)
105 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
109 -> TranslatorSession (AST.VHDLId, [AST.LibraryUnit])
111 createLibraryUnit bndr = do
112 entity <- getEntity bndr
113 (arch, _) <- getArchitecture bndr
114 return (ent_id entity, [AST.LUEntity (ent_dec entity), AST.LUArch arch])
117 -- | Looks up all pairs of old state, new state signals, together with
118 -- the state id they represent.
119 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
120 makeStatePairs flatfunc =
121 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
122 | old_info <- map snd (flat_sigs flatfunc)
123 , new_info <- map snd (flat_sigs flatfunc)
124 -- old_info must be an old state (and, because of the next equality,
125 -- new_info must be a new state).
126 , Maybe.isJust $ oldStateId $ sigUse old_info
127 -- And the state numbers must match
128 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
130 -- Replace the second tuple element with the corresponding SignalInfo
131 --args_states = map (Arrow.second $ signalInfo sigs) args
132 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
133 mkStateProcSm (num, old, new) =
134 AST.ProcSm label [clk] [statement]
136 label = mkVHDLExtId $ "state_" ++ (show num)
137 clk = mkVHDLExtId "clk"
138 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
139 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
140 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
141 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
142 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
144 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
146 getSignalId :: SignalInfo -> AST.VHDLId
148 mkVHDLExtId $ Maybe.fromMaybe
149 (error $ "Unnamed signal? This should not happen!")
155 Maybe Int -- ^ Number of cycles to simulate
156 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
157 -> CoreSyn.CoreBndr -- ^ Top Entity
158 -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench
159 createTestBench mCycles stimuli topEntity = do
160 ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity
161 arch <- createTestBenchArch mCycles stimuli topEntity
162 return (id, [AST.LUEntity ent, AST.LUArch arch])
165 createTestBenchEntity ::
166 CoreSyn.CoreBndr -- ^ Top Entity
167 -> VHDLSession AST.EntityDec -- ^ TB Entity
168 createTestBenchEntity topEntity = do
169 signaturemap <- getA vsSignatures
170 let signature = Maybe.fromMaybe
171 (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
172 (Map.lookup topEntity signaturemap)
173 let signaturename = ent_id signature
174 return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") []
176 createTestBenchArch ::
177 Maybe Int -- ^ Number of cycles to simulate
178 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie
179 -> CoreSyn.CoreBndr -- ^ Top Entity
180 -> VHDLSession AST.ArchBody
181 createTestBenchArch mCycles stimuli topEntity = do
182 signaturemap <- getA vsSignatures
183 let signature = Maybe.fromMaybe
184 (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
185 (Map.lookup topEntity signaturemap)
186 let entId = ent_id signature
187 iIface = ent_args signature
188 oIface = ent_res signature
189 iIds = map fst iIface
191 let iDecs = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
192 let finalIDecs = iDecs ++
193 [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
194 AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
195 let oDecs = AST.SigDec (fst oIface) (snd oIface) Nothing
196 let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature
197 let mIns = mkComponentInst "totest" entId portmaps
198 (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds)
199 let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
201 (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
202 Nothing)) : stimuliAssigns
203 let clkProc = createClkProc
204 let outputProc = createOutputProc [oIds]
205 return $ (AST.ArchBody
206 (AST.unsafeVHDLBasicId "test")
207 (AST.NSimple $ AST.unsafeIdAppend entId "_tb")
208 (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
210 ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) )
212 createStimuliAssigns ::
213 Maybe Int -- ^ Number of cycles to simulate
214 -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
215 -> AST.VHDLId -- ^ Input signal
216 -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int)
217 createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles)
219 createStimuliAssigns mCycles stimuli signal = do
220 let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
221 let inputlen = length stimuli
222 assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
223 let resvars = (map snd assigns)
224 sig_dec_maybes <- mapM mkSigDec resvars
225 let sig_decs = Maybe.catMaybes sig_dec_maybes
226 outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars
227 let wformelems = zipWith genWformElem [0,10..] outps
228 let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
229 return ((map fst assigns) ++ [inassign], sig_decs, inputlen)
231 createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var)
232 createStimulans (bndr, expr) cycl = do
233 -- There must be a let at top level
234 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr
235 stimulansbinds <- Monad.mapM mkConcSm binds
236 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
237 let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
238 let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
239 let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds)
240 return (AST.CSBSm block, res)
242 -- | generates a clock process with a period of 10ns
243 createClkProc :: AST.ProcSm
244 createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
245 where sms = -- wait for 5 ns -- (half a cycle)
246 [AST.WaitFor $ AST.PrimLit "5 ns",
248 AST.NSimple clockId `AST.SigAssign`
249 AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
251 -- | generate the output process
252 createOutputProc :: [AST.VHDLId] -- ^ output signal
254 createOutputProc outs =
255 AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput")
257 [AST.IfSm clkPred (writeOuts outs) [] Nothing]
258 where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId)
259 (AST.NSimple $ eventId)
261 (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
262 writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
264 writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
265 writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
266 writeOut outSig suffix =
267 genExprPCall2 writeId
268 (AST.PrimName $ AST.NSimple outputId)
269 ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)