Caching converted tfp integers to speedup translation
[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 Data.Accessor.MonadState as MonadState
16 import Debug.Trace
17
18 -- ForSyDe
19 import qualified ForSyDe.Backend.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 VHDLTypes
36 import VHDLTools
37 import Pretty
38 import CoreTools
39 import Constants
40 import Generate
41
42 createDesignFiles ::
43   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
44   -> [(AST.VHDLId, AST.DesignFile)]
45
46 createDesignFiles binds =
47   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
48   map (Arrow.second $ AST.DesignFile full_context) units
49   
50   where
51     init_session = VHDLState emptyTypeState Map.empty
52     (units, final_session) = 
53       State.runState (createLibraryUnits binds) init_session
54     tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
55     ty_decls = final_session ^. vsType ^. vsTypeDecls
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] ++ 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
73 -- Create a use foo.bar.all statement. Takes a list of components in the used
74 -- name. Must contain at least two components
75 mkUseAll :: [String] -> AST.ContextItem
76 mkUseAll ss = 
77   AST.Use $ from AST.:.: AST.All
78   where
79     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
80     from = foldl select base_prefix (tail ss)
81     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
82       
83 createLibraryUnits ::
84   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
85   -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
86
87 createLibraryUnits binds = do
88   entities <- Monad.mapM createEntity binds
89   archs <- Monad.mapM createArchitecture binds
90   return $ zipWith 
91     (\ent arch -> 
92       let AST.EntityDec id _ = ent in 
93       (id, [AST.LUEntity ent, AST.LUArch arch])
94     )
95     entities archs
96
97 -- | Create an entity for a given function
98 createEntity ::
99   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
100   -> VHDLSession AST.EntityDec -- | The resulting entity
101
102 createEntity (fname, expr) = do
103       -- Strip off lambda's, these will be arguments
104       let (args, letexpr) = CoreSyn.collectBinders expr
105       args' <- Monad.mapM mkMap args
106       -- There must be a let at top level 
107       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
108       res' <- mkMap res
109       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
110       let ent_decl' = createEntityAST vhdl_id args' res'
111       let AST.EntityDec entity_id _ = ent_decl' 
112       let signature = Entity entity_id args' res'
113       modA vsSignatures (Map.insert fname signature)
114       return ent_decl'
115   where
116     mkMap ::
117       --[(SignalId, SignalInfo)] 
118       CoreSyn.CoreBndr 
119       -> VHDLSession Port
120     -- We only need the vsTypes element from the state
121     mkMap = (\bndr ->
122       let
123         --info = Maybe.fromMaybe
124         --  (error $ "Signal not found in the name map? This should not happen!")
125         --  (lookup id sigmap)
126         --  Assume the bndr has a valid VHDL id already
127         id = varToVHDLId bndr
128         ty = Var.varType bndr
129         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr 
130       in do
131         type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
132         return (id, type_mark)
133      )
134
135   -- | Create the VHDL AST for an entity
136 createEntityAST ::
137   AST.VHDLId                   -- | The name of the function
138   -> [Port]                    -- | The entity's arguments
139   -> Port                      -- | The entity's result
140   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
141
142 createEntityAST vhdl_id args res =
143   AST.EntityDec vhdl_id ports
144   where
145     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
146     ports = map (mkIfaceSigDec AST.In) args
147               ++ [mkIfaceSigDec AST.Out res]
148               ++ [clk_port]
149     -- Add a clk port if we have state
150     clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
151
152 -- | Create a port declaration
153 mkIfaceSigDec ::
154   AST.Mode                         -- | The mode for the port (In / Out)
155   -> (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
156   -> AST.IfaceSigDec               -- | The resulting port declaration
157
158 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
159
160 {-
161 -- | Generate a VHDL entity name for the given hsfunc
162 mkEntityId hsfunc =
163   -- TODO: This doesn't work for functions with multiple signatures!
164   -- Use a Basic Id, since using extended id's for entities throws off
165   -- precision and causes problems when generating filenames.
166   mkVHDLBasicId $ hsFuncName hsfunc
167 -}
168
169 -- | Create an architecture for a given function
170 createArchitecture ::
171   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
172   -> VHDLSession AST.ArchBody -- ^ The architecture for this function
173
174 createArchitecture (fname, expr) = do
175   signaturemap <- getA vsSignatures
176   let signature = Maybe.fromMaybe 
177         (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
178         (Map.lookup fname signaturemap)
179   let entity_id = ent_id signature
180   -- Strip off lambda's, these will be arguments
181   let (args, letexpr) = CoreSyn.collectBinders expr
182   -- There must be a let at top level 
183   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
184
185   -- Create signal declarations for all binders in the let expression, except
186   -- for the output port (that will already have an output port declared in
187   -- the entity).
188   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
189   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
190
191   statementss <- Monad.mapM mkConcSm binds
192   let statements = concat statementss
193   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
194   where
195     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
196     procs' = map AST.CSPSm procs
197     -- mkSigDec only uses vsTypes from the state
198     mkSigDec' = mkSigDec
199
200 {-
201 -- | Looks up all pairs of old state, new state signals, together with
202 --   the state id they represent.
203 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
204 makeStatePairs flatfunc =
205   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info) 
206     | old_info <- map snd (flat_sigs flatfunc)
207     , new_info <- map snd (flat_sigs flatfunc)
208         -- old_info must be an old state (and, because of the next equality,
209         -- new_info must be a new state).
210         , Maybe.isJust $ oldStateId $ sigUse old_info
211         -- And the state numbers must match
212     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
213
214     -- Replace the second tuple element with the corresponding SignalInfo
215     --args_states = map (Arrow.second $ signalInfo sigs) args
216 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
217 mkStateProcSm (num, old, new) =
218   AST.ProcSm label [clk] [statement]
219   where
220     label       = mkVHDLExtId $ "state_" ++ (show num)
221     clk         = mkVHDLExtId "clk"
222     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
223     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
224     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
225     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
226     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
227
228 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
229 --   is not named.
230 getSignalId :: SignalInfo -> AST.VHDLId
231 getSignalId info =
232   mkVHDLExtId $ Maybe.fromMaybe
233     (error $ "Unnamed signal? This should not happen!")
234     (sigName info)
235 -}
236    
237 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
238 mkSigDec bndr =
239   if True then do --isInternalSigUse use || isStateSigUse use then do
240     let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
241     type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
242     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
243   else
244     return Nothing
245
246 -- | Transforms a core binding into a VHDL concurrent statement
247 mkConcSm ::
248   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
249   -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
250
251
252 -- Ignore Cast expressions, they should not longer have any meaning as long as
253 -- the type works out.
254 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
255
256 -- For simple a = b assignments, just generate an unconditional signal
257 -- assignment. This should only happen for dataconstructors without arguments.
258 -- TODO: Integrate this with the below code for application (essentially this
259 -- is an application without arguments)
260 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
261
262 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
263   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
264   let valargs = get_val_args (Var.varType f) args
265   genApplication (Left bndr) f (map Left valargs)
266
267 -- A single alt case must be a selector. This means thee scrutinee is a simple
268 -- variable, the alternative is a dataalt with a single non-wild binder that
269 -- is also returned.
270 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
271   case alt of
272     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
273       case List.elemIndex sel_bndr bndrs of
274         Just i -> do
275           labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
276           let label = labels!!i
277           let sel_name = mkSelectedName (varToVHDLName scrut) label
278           let sel_expr = AST.PrimName sel_name
279           return [mkUncondAssign (Left bndr) sel_expr]
280         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
281       
282     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
283
284 -- Multiple case alt are be conditional assignments and have only wild
285 -- binders in the alts and only variables in the case values and a variable
286 -- for a scrutinee. We check the constructor of the second alt, since the
287 -- first is the default case, if there is any.
288 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
289   let
290     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
291     true_expr  = (varToVHDLExpr true)
292     false_expr  = (varToVHDLExpr false)
293   in
294     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
295 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
296 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
297 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr