fd83899cee622a7ddc501afa598a87cc227e9eac
[matthijs/master-project/cλash.git] / VHDL.hs
1 --
2 -- Functions to generate VHDL from FlatFunctions
3 --
4 module CLasH.VHDL where
5
6 -- Standard modules
7 import qualified Data.List as List
8 import qualified Data.Map as Map
9 import qualified Maybe
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
14 import Data.Accessor
15 import Data.Accessor.MonadState as MonadState
16 import Debug.Trace
17
18 -- ForSyDe
19 import qualified Language.VHDL.AST as AST
20
21 -- GHC API
22 import CoreSyn
23 --import qualified Type
24 import qualified Name
25 import qualified Var
26 import qualified Id
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 )
33
34 -- Local imports
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
42
43 createDesignFiles ::
44   TypeState
45   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
46   -> CoreSyn.CoreBndr -- ^ Top binder
47   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Test Input
48   -> [(AST.VHDLId, AST.DesignFile)]
49
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])
53   
54   where
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 = mkBuiltInShow ++ (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) (AST.NSimple $ highId) Nothing)
64     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
65     ieee_context = [
66         AST.Library $ mkVHDLBasicId "IEEE",
67         mkUseAll ["IEEE", "std_logic_1164"],
68         mkUseAll ["IEEE", "numeric_std"],
69         mkUseAll ["std", "textio"]
70       ]
71     full_context =
72       mkUseAll ["work", "types"]
73       : (mkUseAll ["work"]
74       : ieee_context)
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
79
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
83 mkUseAll ss = 
84   AST.Use $ from AST.:.: AST.All
85   where
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)
89       
90 createLibraryUnits ::
91   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
92   -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
93
94 createLibraryUnits binds = do
95   entities <- Monad.mapM createEntity binds
96   archs <- Monad.mapM createArchitecture binds
97   return $ zipWith 
98     (\ent arch -> 
99       let AST.EntityDec id _ = ent in 
100       (id, [AST.LUEntity ent, AST.LUArch arch])
101     )
102     entities archs
103
104 -- | Create an entity for a given function
105 createEntity ::
106   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
107   -> VHDLSession AST.EntityDec -- ^ The resulting entity
108
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
115       res' <- mkMap res
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)
121       return ent_decl'
122   where
123     mkMap ::
124       --[(SignalId, SignalInfo)] 
125       CoreSyn.CoreBndr 
126       -> VHDLSession Port
127     -- We only need the vsTypes element from the state
128     mkMap = (\bndr ->
129       let
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 
137       in do
138         type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
139         return (id, type_mark)
140      )
141
142 -- | Create the VHDL AST for an entity
143 createEntityAST ::
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
148
149 createEntityAST vhdl_id args res =
150   AST.EntityDec vhdl_id ports
151   where
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]
155               ++ [clk_port]
156     -- Add a clk port if we have state
157     clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
158
159 -- | Create a port declaration
160 mkIfaceSigDec ::
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
164
165 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
166
167 {-
168 -- | Generate a VHDL entity name for the given hsfunc
169 mkEntityId 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
174 -}
175
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
180
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
191
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
194   -- the entity).
195   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
196   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
197
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')
201   where
202     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
203     procs' = map AST.CSPSm procs
204     -- mkSigDec only uses vsTypes from the state
205     mkSigDec' = mkSigDec
206
207 {-
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)]
220
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]
226   where
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
234
235 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
236 --   is not named.
237 getSignalId :: SignalInfo -> AST.VHDLId
238 getSignalId info =
239   mkVHDLExtId $ Maybe.fromMaybe
240     (error $ "Unnamed signal? This should not happen!")
241     (sigName info)
242 -}
243
244 -- | Transforms a core binding into a VHDL concurrent statement
245 mkConcSm ::
246   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
247   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
248
249
250 -- Ignore Cast expressions, they should not longer have any meaning as long as
251 -- the type works out.
252 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
253
254 -- Simple a = b assignments are just like applications, but without arguments.
255 -- We can't just generate an unconditional assignment here, since b might be a
256 -- top level binding (e.g., a function with no arguments).
257 mkConcSm (bndr, Var v) = do
258   genApplication (Left bndr) v []
259
260 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
261   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
262   let valargs = get_val_args (Var.varType f) args
263   genApplication (Left bndr) f (map Left valargs)
264
265 -- A single alt case must be a selector. This means thee scrutinee is a simple
266 -- variable, the alternative is a dataalt with a single non-wild binder that
267 -- is also returned.
268 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
269   case alt of
270     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
271       case List.elemIndex sel_bndr bndrs of
272         Just i -> do
273           labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
274           let label = labels!!i
275           let sel_name = mkSelectedName (varToVHDLName scrut) label
276           let sel_expr = AST.PrimName sel_name
277           return [mkUncondAssign (Left bndr) sel_expr]
278         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
279       
280     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
281
282 -- Multiple case alt are be conditional assignments and have only wild
283 -- binders in the alts and only variables in the case values and a variable
284 -- for a scrutinee. We check the constructor of the second alt, since the
285 -- first is the default case, if there is any.
286 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
287   scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
288   let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
289   true_expr <- MonadState.lift vsType $ varToVHDLExpr true
290   false_expr <- MonadState.lift vsType $ varToVHDLExpr false
291   return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
292
293 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
294 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
295 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
296
297
298 createTestBench :: 
299   Maybe Int -- ^ Number of cycles to simulate
300   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
301   -> CoreSyn.CoreBndr -- ^ Top Entity
302   -> VHDLSession (AST.VHDLId, [AST.LibraryUnit]) -- ^ Testbench
303 createTestBench mCycles stimuli topEntity = do
304   ent@(AST.EntityDec id _) <- createTestBenchEntity topEntity
305   arch <- createTestBenchArch mCycles stimuli topEntity
306   return (id, [AST.LUEntity ent, AST.LUArch arch])
307   
308
309 createTestBenchEntity ::
310   CoreSyn.CoreBndr -- ^ Top Entity
311   -> VHDLSession AST.EntityDec -- ^ TB Entity
312 createTestBenchEntity topEntity = do
313   signaturemap <- getA vsSignatures
314   let signature = Maybe.fromMaybe 
315         (error $ "\nTestbench.createTestBenchEntity: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
316         (Map.lookup topEntity signaturemap)
317   let signaturename = ent_id signature
318   return $ AST.EntityDec (AST.unsafeIdAppend signaturename "_tb") []
319   
320 createTestBenchArch ::
321   Maybe Int -- ^ Number of cycles to simulate
322   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Imput stimulie
323   -> CoreSyn.CoreBndr -- ^ Top Entity
324   -> VHDLSession AST.ArchBody
325 createTestBenchArch mCycles stimuli topEntity = do
326   signaturemap <- getA vsSignatures
327   let signature = Maybe.fromMaybe 
328         (error $ "\nTestbench.createTestBenchArch: Generating testbench for function \n" ++ (pprString topEntity) ++ "\nwithout signature? This should not happen!")
329         (Map.lookup topEntity signaturemap)
330   let entId   = ent_id signature
331       iIface  = ent_args signature
332       oIface  = ent_res signature
333       iIds    = map fst iIface
334       oIds    = fst oIface
335   let iDecs   = map (\(vId, tm) -> AST.SigDec vId tm Nothing) iIface
336   let finalIDecs = iDecs ++
337                     [AST.SigDec clockId std_logicTM (Just $ AST.PrimLit "'0'"),
338                      AST.SigDec resetId std_logicTM (Just $ AST.PrimLit "'0'")]
339   let oDecs   = AST.SigDec (fst oIface) (snd oIface) Nothing
340   let portmaps = mkAssocElems (map idToVHDLExpr iIds) (AST.NSimple oIds) signature
341   let mIns    = mkComponentInst "totest" entId portmaps
342   (stimuliAssigns, stimuliDecs, cycles) <- createStimuliAssigns mCycles stimuli (head iIds)
343   let finalAssigns = (AST.CSSASm (AST.NSimple resetId AST.:<==:
344                       AST.ConWforms []
345                                     (AST.Wform [AST.WformElem (AST.PrimLit "'1'") (Just $ AST.PrimLit "3 ns")])
346                                     Nothing)) : stimuliAssigns
347   let clkProc     = createClkProc
348   let outputProc  = createOutputProc [oIds]
349   return $ (AST.ArchBody
350               (AST.unsafeVHDLBasicId "test")
351               (AST.NSimple $ AST.unsafeIdAppend entId "_tb")
352               (map AST.BDISD (finalIDecs ++ stimuliDecs ++ [oDecs]))
353               (mIns :
354                 ( (AST.CSPSm clkProc) : (AST.CSPSm outputProc) : finalAssigns ) ) )
355
356 createStimuliAssigns ::
357   Maybe Int -- ^ Number of cycles to simulate
358   -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ Input stimuli
359   -> AST.VHDLId -- ^ Input signal
360   -> VHDLSession ([AST.ConcSm], [AST.SigDec], Int)
361 createStimuliAssigns mCycles [] _ = return ([], [], Maybe.maybe 0 id mCycles)
362
363 createStimuliAssigns mCycles stimuli signal = do
364   let genWformElem time stim = (AST.WformElem stim (Just $ AST.PrimLit (show time ++ " ns")))
365   let inputlen = length stimuli
366   assigns <- Monad.zipWithM createStimulans stimuli [0..inputlen]
367   let resvars = (map snd assigns)
368   sig_dec_maybes <- mapM mkSigDec resvars
369   let sig_decs = Maybe.catMaybes sig_dec_maybes
370   outps <- mapM (\x -> MonadState.lift vsType (varToVHDLExpr x)) resvars
371   let wformelems = zipWith genWformElem [0,10..] outps
372   let inassign = AST.CSSASm $ AST.NSimple signal AST.:<==: AST.ConWforms [] (AST.Wform wformelems) Nothing
373   return ((map fst assigns) ++ [inassign], sig_decs, inputlen)
374
375 createStimulans :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> Int -> VHDLSession (AST.ConcSm, Var.Var)
376 createStimulans (bndr, expr) cycl = do 
377   -- There must be a let at top level 
378   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = expr
379   stimulansbinds <- Monad.mapM mkConcSm binds
380   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
381   let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
382   let block_label = mkVHDLExtId ("testcycle_" ++ (show cycl))
383   let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (concat stimulansbinds)  
384   return (AST.CSBSm block, res)
385   
386 -- | generates a clock process with a period of 10ns
387 createClkProc :: AST.ProcSm
388 createClkProc = AST.ProcSm (AST.unsafeVHDLBasicId "clkproc") [] sms
389  where sms = -- wait for 5 ns -- (half a cycle)
390              [AST.WaitFor $ AST.PrimLit "5 ns",
391               -- clk <= not clk;
392               AST.NSimple clockId `AST.SigAssign` 
393                  AST.Wform [AST.WformElem (AST.Not (AST.PrimName $ AST.NSimple clockId)) Nothing]]
394
395 -- | generate the output process
396 createOutputProc :: [AST.VHDLId] -- ^ output signal
397               -> AST.ProcSm  
398 createOutputProc outs = 
399   AST.ProcSm (AST.unsafeVHDLBasicId "writeoutput") 
400          [clockId]
401          [AST.IfSm clkPred (writeOuts outs) [] Nothing]
402  where clkPred = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple clockId) 
403                                                    (AST.NSimple $ eventId)
404                                                    Nothing          ) `AST.And` 
405                  (AST.PrimName (AST.NSimple clockId) AST.:=: AST.PrimLit "'1'")
406        writeOuts :: [AST.VHDLId] -> [AST.SeqSm]
407        writeOuts []  = []
408        writeOuts [i] = [writeOut i (AST.PrimLit "LF")]
409        writeOuts (i:is) = writeOut i (AST.PrimLit "HT") : writeOuts is
410        writeOut outSig suffix = 
411          genExprPCall2 writeId
412                         (AST.PrimName $ AST.NSimple outputId)
413                         ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)