Add mkIndexedName utility function.
[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 import Debug.Trace
16
17 -- ForSyDe
18 import qualified ForSyDe.Backend.VHDL.AST as AST
19
20 -- GHC API
21 import CoreSyn
22 --import qualified Type
23 import qualified Name
24 import qualified Var
25 import qualified Id
26 import qualified IdInfo
27 import qualified TyCon
28 import qualified DataCon
29 --import qualified CoreSubst
30 import qualified CoreUtils
31 import Outputable ( showSDoc, ppr )
32
33 -- Local imports
34 import VHDLTypes
35 import VHDLTools
36 import Pretty
37 import CoreTools
38 import Constants
39 import Generate
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 snd $ 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 tyfun_decls
70     subProgSpecs = map subProgSpec tyfun_decls
71     subProgSpec = \(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   genApplication (Left bndr) f (map Left valargs)
278
279 -- A single alt case must be a selector. This means thee scrutinee is a simple
280 -- variable, the alternative is a dataalt with a single non-wild binder that
281 -- is also returned.
282 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
283   case alt of
284     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
285       case List.elemIndex sel_bndr bndrs of
286         Just i -> do
287           labels <- getFieldLabels (Id.idType scrut)
288           let label = labels!!i
289           let sel_name = mkSelectedName (varToVHDLName scrut) label
290           let sel_expr = AST.PrimName sel_name
291           return [mkUncondAssign (Left bndr) sel_expr]
292         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
293       
294     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
295
296 -- Multiple case alt are be conditional assignments and have only wild
297 -- binders in the alts and only variables in the case values and a variable
298 -- for a scrutinee. We check the constructor of the second alt, since the
299 -- first is the default case, if there is any.
300 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
301   let
302     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
303     true_expr  = (varToVHDLExpr true)
304     false_expr  = (varToVHDLExpr false)
305   in
306     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
307 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
308 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
309 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr