636634e131eaccdcf808c9d4baa29bef2d9f3e7e
[matthijs/master-project/cλash.git] / VHDL.hs
1 --
2 -- Functions to generate VHDL from FlatFunctions
3 --
4 module 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
16 -- ForSyDe
17 import qualified ForSyDe.Backend.VHDL.AST as AST
18
19 -- GHC API
20 import CoreSyn
21 --import qualified Type
22 import qualified Name
23 import qualified Var
24 import qualified Id
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 )
31
32 -- Local imports
33 import VHDLTypes
34 import VHDLTools
35 import Pretty
36 import CoreTools
37 import Constants
38 import Generate
39 import GlobalNameTable
40
41 createDesignFiles ::
42   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
43   -> [(AST.VHDLId, AST.DesignFile)]
44
45 createDesignFiles binds =
46   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
47   map (Arrow.second $ AST.DesignFile full_context) units
48   
49   where
50     init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
51     (units, final_session) = 
52       State.runState (createLibraryUnits binds) init_session
53     tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
54     ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
55     vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
56     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
57     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
58     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
59     ieee_context = [
60         AST.Library $ mkVHDLBasicId "IEEE",
61         mkUseAll ["IEEE", "std_logic_1164"],
62         mkUseAll ["IEEE", "numeric_std"]
63       ]
64     full_context =
65       mkUseAll ["work", "types"]
66       : (mkUseAll ["work"]
67       : ieee_context)
68     type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
69     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
70     subProgSpecs = concat (map subProgSpec tyfun_decls)
71     subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
72     mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
73     mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
74     mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
75
76 -- Create a use foo.bar.all statement. Takes a list of components in the used
77 -- name. Must contain at least two components
78 mkUseAll :: [String] -> AST.ContextItem
79 mkUseAll ss = 
80   AST.Use $ from AST.:.: AST.All
81   where
82     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
83     from = foldl select base_prefix (tail ss)
84     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
85       
86 createLibraryUnits ::
87   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
88   -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
89
90 createLibraryUnits binds = do
91   entities <- Monad.mapM createEntity binds
92   archs <- Monad.mapM createArchitecture binds
93   return $ zipWith 
94     (\ent arch -> 
95       let AST.EntityDec id _ = ent in 
96       (id, [AST.LUEntity ent, AST.LUArch arch])
97     )
98     entities archs
99
100 -- | Create an entity for a given function
101 createEntity ::
102   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
103   -> VHDLSession AST.EntityDec -- | The resulting entity
104
105 createEntity (fname, expr) = do
106       -- Strip off lambda's, these will be arguments
107       let (args, letexpr) = CoreSyn.collectBinders expr
108       args' <- Monad.mapM mkMap args
109       -- There must be a let at top level 
110       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
111       res' <- mkMap res
112       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
113       let ent_decl' = createEntityAST vhdl_id args' res'
114       let AST.EntityDec entity_id _ = ent_decl' 
115       let signature = Entity entity_id args' res'
116       modA vsSignatures (Map.insert fname signature)
117       return ent_decl'
118   where
119     mkMap ::
120       --[(SignalId, SignalInfo)] 
121       CoreSyn.CoreBndr 
122       -> VHDLSession VHDLSignalMapElement
123     -- We only need the vsTypes element from the state
124     mkMap = (\bndr ->
125       let
126         --info = Maybe.fromMaybe
127         --  (error $ "Signal not found in the name map? This should not happen!")
128         --  (lookup id sigmap)
129         --  Assume the bndr has a valid VHDL id already
130         id = varToVHDLId bndr
131         ty = Var.varType bndr
132       in
133         if True -- isPortSigUse $ sigUse info
134           then do
135             type_mark <- vhdl_ty ty
136             return $ Just (id, type_mark)
137           else
138             return $ Nothing
139        )
140
141   -- | Create the VHDL AST for an entity
142 createEntityAST ::
143   AST.VHDLId                   -- | The name of the function
144   -> [VHDLSignalMapElement]    -- | The entity's arguments
145   -> VHDLSignalMapElement      -- | The entity's result
146   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
147
148 createEntityAST vhdl_id args res =
149   AST.EntityDec vhdl_id ports
150   where
151     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
152     ports = Maybe.catMaybes $ 
153               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 = if True -- hasState hsfunc
158       then
159         Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
160       else
161         Nothing
162
163 -- | Create a port declaration
164 mkIfaceSigDec ::
165   AST.Mode                         -- | The mode for the port (In / Out)
166   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
167   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
168
169 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
170 mkIfaceSigDec _ Nothing = Nothing
171
172 {-
173 -- | Generate a VHDL entity name for the given hsfunc
174 mkEntityId hsfunc =
175   -- TODO: This doesn't work for functions with multiple signatures!
176   -- Use a Basic Id, since using extended id's for entities throws off
177   -- precision and causes problems when generating filenames.
178   mkVHDLBasicId $ hsFuncName hsfunc
179 -}
180
181 -- | Create an architecture for a given function
182 createArchitecture ::
183   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
184   -> VHDLSession AST.ArchBody -- ^ The architecture for this function
185
186 createArchitecture (fname, expr) = do
187   signaturemap <- getA vsSignatures
188   let signature = Maybe.fromMaybe 
189         (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
190         (Map.lookup fname signaturemap)
191   let entity_id = ent_id signature
192   -- Strip off lambda's, these will be arguments
193   let (args, letexpr) = CoreSyn.collectBinders expr
194   -- There must be a let at top level 
195   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
196
197   -- Create signal declarations for all binders in the let expression, except
198   -- for the output port (that will already have an output port declared in
199   -- the entity).
200   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
201   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
202
203   statementss <- Monad.mapM mkConcSm binds
204   let statements = concat statementss
205   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
206   where
207     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
208     procs' = map AST.CSPSm procs
209     -- mkSigDec only uses vsTypes from the state
210     mkSigDec' = mkSigDec
211
212 {-
213 -- | Looks up all pairs of old state, new state signals, together with
214 --   the state id they represent.
215 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
216 makeStatePairs flatfunc =
217   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info) 
218     | old_info <- map snd (flat_sigs flatfunc)
219     , new_info <- map snd (flat_sigs flatfunc)
220         -- old_info must be an old state (and, because of the next equality,
221         -- new_info must be a new state).
222         , Maybe.isJust $ oldStateId $ sigUse old_info
223         -- And the state numbers must match
224     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
225
226     -- Replace the second tuple element with the corresponding SignalInfo
227     --args_states = map (Arrow.second $ signalInfo sigs) args
228 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
229 mkStateProcSm (num, old, new) =
230   AST.ProcSm label [clk] [statement]
231   where
232     label       = mkVHDLExtId $ "state_" ++ (show num)
233     clk         = mkVHDLExtId "clk"
234     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
235     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
236     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
237     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
238     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
239
240 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
241 --   is not named.
242 getSignalId :: SignalInfo -> AST.VHDLId
243 getSignalId info =
244   mkVHDLExtId $ Maybe.fromMaybe
245     (error $ "Unnamed signal? This should not happen!")
246     (sigName info)
247 -}
248    
249 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
250 mkSigDec bndr =
251   if True then do --isInternalSigUse use || isStateSigUse use then do
252     type_mark <- vhdl_ty $ Var.varType bndr
253     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
254   else
255     return Nothing
256
257 -- | Transforms a core binding into a VHDL concurrent statement
258 mkConcSm ::
259   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
260   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
261
262
263 -- Ignore Cast expressions, they should not longer have any meaning as long as
264 -- the type works out.
265 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
266
267 -- For simple a = b assignments, just generate an unconditional signal
268 -- assignment. This should only happen for dataconstructors without arguments.
269 -- TODO: Integrate this with the below code for application (essentially this
270 -- is an application without arguments)
271 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
272
273 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
274   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
275   let valargs' = filter isValArg args
276   let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
277   case Var.globalIdVarDetails f of
278     IdInfo.DataConWorkId dc ->
279         -- It's a datacon. Create a record from its arguments.
280         -- First, filter out type args. TODO: Is this the best way to do this?
281         -- The types should already have been taken into acocunt when creating
282         -- the signal, so this should probably work...
283         --let valargs = filter isValArg args in
284         if all is_var valargs then do
285           labels <- getFieldLabels (CoreUtils.exprType app)
286           return $ zipWith mkassign labels valargs
287         else
288           error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
289       where
290         mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
291         mkassign label (Var arg) =
292           let sel_name = mkSelectedName bndr label in
293           mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
294     IdInfo.VanillaGlobal -> do
295       -- It's a global value imported from elsewhere. These can be builtin
296       -- functions.
297       signatures <- getA vsSignatures
298       case (Map.lookup (varToString f) globalNameTable) of
299         Just (arg_count, builder) ->
300           if length valargs == arg_count then
301             case builder of
302               Left funBuilder ->
303                 let
304                   sigs = map (varToVHDLExpr.exprToVar) valargs
305                   func = funBuilder sigs
306                   src_wform = AST.Wform [AST.WformElem func Nothing]
307                   dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))
308                   assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
309                 in
310                   return [AST.CSSASm assign]
311               Right genBuilder ->
312                 let
313                   sigs = map exprToVar valargs
314                   signature = Maybe.fromMaybe
315                     (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!") 
316                     (Map.lookup (head sigs) signatures)
317                   arg = tail sigs
318                   genSm = genBuilder signature (arg ++ [bndr])  
319                 in return [AST.CSGSm genSm]
320           else
321             error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
322         Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
323     IdInfo.NotGlobalId -> do
324       signatures <- getA vsSignatures
325       -- This is a local id, so it should be a function whose definition we
326       -- have and which can be turned into a component instantiation.
327       let  
328         signature = Maybe.fromMaybe 
329           (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") 
330           (Map.lookup f signatures)
331         entity_id = ent_id signature
332         label = "comp_ins_" ++ varToString bndr
333         -- Add a clk port if we have state
334         --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
335         clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
336         --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
337         portmaps = clk_port : mkAssocElems args bndr signature
338         in
339           return [mkComponentInst label entity_id portmaps]
340     details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
341
342 -- A single alt case must be a selector. This means thee scrutinee is a simple
343 -- variable, the alternative is a dataalt with a single non-wild binder that
344 -- is also returned.
345 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
346   case alt of
347     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
348       case List.elemIndex sel_bndr bndrs of
349         Just i -> do
350           labels <- getFieldLabels (Id.idType scrut)
351           let label = labels!!i
352           let sel_name = mkSelectedName scrut label
353           let sel_expr = AST.PrimName sel_name
354           return [mkUncondAssign (Left bndr) sel_expr]
355         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
356       
357     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
358
359 -- Multiple case alt are be conditional assignments and have only wild
360 -- binders in the alts and only variables in the case values and a variable
361 -- for a scrutinee. We check the constructor of the second alt, since the
362 -- first is the default case, if there is any.
363 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
364   let
365     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
366     true_expr  = (varToVHDLExpr true)
367     false_expr  = (varToVHDLExpr false)
368   in
369     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
370 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
371 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
372 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr