Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project
[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / Testbench.hs
1 -- 
2 -- Functions to create a VHDL testbench from a list of test input.
3 --
4 module CLasH.VHDL.Testbench where
5
6 -- Standard modules
7 import qualified Control.Monad as Monad
8 import qualified Maybe
9 import qualified Data.Map as Map
10 import Data.Accessor
11 import qualified Data.Accessor.MonadState as MonadState
12
13 -- ForSyDe
14 import qualified Language.VHDL.AST as AST
15
16 -- GHC API
17 import CoreSyn
18 import qualified HscTypes
19 import qualified Var
20 import qualified TysWiredIn
21
22 -- Local imports
23 import CLasH.Translator.TranslatorTypes
24 import CLasH.VHDL.Constants
25 import CLasH.VHDL.Generate
26 import CLasH.VHDL.VHDLTools
27 import CLasH.VHDL.VHDLTypes
28 import CLasH.Normalize
29 import CLasH.Utils.Core.BinderTools
30 import CLasH.Utils.Core.CoreTools
31 import CLasH.Utils
32
33 createTestbench :: 
34   Maybe Int -- ^ Number of cycles to simulate
35   -> [HscTypes.CoreModule] -- ^ Compiled modules
36   -> CoreSyn.CoreExpr -- ^ Input stimuli
37   -> CoreSyn.CoreBndr -- ^ Top Entity
38   -> TranslatorSession CoreBndr -- ^ The id of the generated archictecture
39 createTestbench mCycles cores stimuli top = do
40   stimuli' <- reduceCoreListToHsList cores stimuli
41   -- Create a binder for the testbench. We use the unit type (), since the
42   -- testbench has no outputs and no inputs.
43   bndr <- mkInternalVar "testbench" TysWiredIn.unitTy
44   let entity = createTestbenchEntity bndr
45   modA tsEntities (Map.insert bndr entity)
46   arch <- createTestbenchArch mCycles stimuli' top entity
47   modA tsArchitectures (Map.insert bndr arch)
48   return bndr
49
50 createTestbenchEntity :: 
51   CoreSyn.CoreBndr
52   -> Entity
53 createTestbenchEntity bndr = entity
54   where
55     vhdl_id = mkVHDLBasicId "testbench"
56     -- Create an AST entity declaration with no ports
57     ent_decl = AST.EntityDec vhdl_id []
58     -- Create a signature with no input and no output ports
59     entity = Entity vhdl_id [] undefined ent_decl
60
61 createTestbenchArch ::
62   Maybe Int -- ^ Number of cycles to simulate
63   -> [CoreSyn.CoreExpr] -- ^ Imput stimuli
64   -> CoreSyn.CoreBndr -- ^ Top Entity
65   -> Entity -- ^ The signature to create an architecture for
66   -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
67   -- ^ The architecture and any other entities used.
68 createTestbenchArch mCycles stimuli top testent= do
69   signature <- getEntity top
70   let entId   = ent_id signature
71       iIface  = ent_args signature
72       oIface  = ent_res signature
73       iIds    = map fst iIface
74   let (oId, oDec, oProc) = case oIface of
75         Just (id, ty) -> ( id
76                          , [AST.SigDec id ty Nothing]
77                          , [createOutputProc [id]])
78         -- No output port? Just use undefined for the output id, since it won't be
79         -- used by mkAssocElems when there is no output port.
80         Nothing -> (undefined, [], [])
81   let iDecs   = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
82   let finalIDecs = iDecs ++
83                     [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
84                      AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
85   let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oId) signature
86   let mIns    = mkComponentInst "totest" entId portmaps
87   (stimuliAssigns, stimuliDecs, cycles, used) <- createStimuliAssigns mCycles stimuli (head iIds)
88   let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
89                       AST.ConWforms []
90                                     (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
91                                     Nothing)) : stimuliAssigns
92   let clkProc     = createClkProc
93   let arch = AST.ArchBody
94               (AST.unsafeVHDLBasicId "test")
95               (AST.NSimple $ ent_id testent)
96               (map AST.BDISD (finalIDecs ++ stimuliDecs ++ oDec))
97               (mIns :
98                 ( (AST.CSPSm clkProc) : (fmap AST.CSPSm oProc) ++ finalAssigns ) )
99   return (arch, top : used)
100
101 createStimuliAssigns ::
102   Maybe Int -- ^ Number of cycles to simulate
103   -> [CoreSyn.CoreExpr] -- ^ Input stimuli
104   -> AST.VHDLId -- ^ Input signal
105   -> TranslatorSession ( [AST.ConcSm]
106                        , [AST.SigDec]
107                        , Int
108                        , [CoreSyn.CoreBndr]) -- ^ (Resulting statements, Needed signals, The number of cycles to simulate, Any entities used)
109 createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles, [])
110
111 createStimuliAssigns mCycles stimuli signal = do
112   let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
113   let inputlen = length stimuli
114   assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
115   let (stimuli_sms, resvars, useds) = unzip3 assigns
116   sig_dec_maybes <- mapM mkSigDec resvars
117   let sig_decs = Maybe.catMaybes sig_dec_maybes
118   outps <- mapM (\x -> MonadState.lift tsType (varToVHDLExpr x)) resvars
119   let wformelems = zipWith genWformElem [0,10..] outps
120   let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
121   return (stimuli_sms ++ [inassign], sig_decs, inputlen, concat useds)
122
123 createStimulans ::
124   CoreSyn.CoreExpr -- ^ The stimulans
125   -> Int -- ^ The cycle for this stimulans
126   -> TranslatorSession ( AST.ConcSm
127                        , Var.Var 
128                        , [CoreSyn.CoreBndr]) -- ^ (The statement, the variable it assigns to (assumed to be available!), Any entities used by this stimulans)
129
130 createStimulans expr cycl = do 
131   -- There must be a let at top level 
132   expr <- normalizeExpr ("test input #" ++ show cycl) expr
133   -- Split the normalized expression. It can't have a function type, so match
134   -- an empty list of argument binders
135   let ([], binds, res) = splitNormalized expr
136   (stimulansbindss, useds) <- unzipM $ Monad.mapM mkConcSm binds
137   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
138   let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
139   let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
140   let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbindss)  
141   return (AST.CSBSm block, res, concat useds)
142  
143 -- | generates a clock process with a period of 10ns
144 createClkProc :: AST.ProcSm
145 createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
146  where sms = -- wait for 5 ns -- (half a cycle)
147              [AST.WaitFor $ AST.PrimLit "5 ns",
148               -- clk <= not clk;
149               AST.NSimple clockId `AST.SigAssign` 
150                  AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
151
152 -- | generate the output process
153 createOutputProc :: [AST.VHDLId] -- ^ output signal
154               -> AST.ProcSm  
155 createOutputProc outs = 
156   AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput") 
157          [clockId]
158          [AST.IfSm clkPred (writeOuts outs) [] Nothing]
159  where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) 
160                                                    (AST.NSimple $ eventId)
161                                                    Nothing          ) `AST.And` 
162                  (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
163        writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
164        writeOuts []  = []
165        writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
166        writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
167        writeOut outSig suffix = 
168          genExprPCall2 writeId
169                         (AST.PrimName $ AST.NSimple outputId)
170                         ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)