15eb4c59330327e7f82fac05e5aa4391c50b1fbe
[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.Foldable as Foldable
8 import qualified Data.List as List
9 import qualified Data.Map as Map
10 import qualified Maybe
11 import qualified Control.Monad as Monad
12 import qualified Control.Arrow as Arrow
13 import qualified Control.Monad.Trans.State as State
14 import qualified Data.Traversable as Traversable
15 import qualified Data.Monoid as Monoid
16 import Data.Accessor
17 import qualified Data.Accessor.MonadState as MonadState
18 import Text.Regex.Posix
19 import Debug.Trace
20
21 -- ForSyDe
22 import qualified ForSyDe.Backend.VHDL.AST as AST
23
24 -- GHC API
25 import CoreSyn
26 import qualified Type
27 import qualified Name
28 import qualified OccName
29 import qualified Var
30 import qualified Id
31 import qualified IdInfo
32 import qualified TyCon
33 import qualified TcType
34 import qualified DataCon
35 import qualified CoreSubst
36 import qualified CoreUtils
37 import Outputable ( showSDoc, ppr )
38
39 -- Local imports
40 import VHDLTypes
41 import Flatten
42 import FlattenTypes
43 import TranslatorTypes
44 import HsValueMap
45 import Pretty
46 import CoreTools
47 import Constants
48 import Generate
49 import GlobalNameTable
50
51 createDesignFiles ::
52   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
53   -> [(AST.VHDLId, AST.DesignFile)]
54
55 createDesignFiles binds =
56   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
57   map (Arrow.second $ AST.DesignFile full_context) units
58   
59   where
60     init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable
61     (units, final_session) = 
62       State.runState (createLibraryUnits binds) init_session
63     tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
64     ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
65     vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
66     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
67     tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
68     tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
69     ieee_context = [
70         AST.Library $ mkVHDLBasicId "IEEE",
71         mkUseAll ["IEEE", "std_logic_1164"],
72         mkUseAll ["IEEE", "numeric_std"]
73       ]
74     full_context =
75       mkUseAll ["work", "types"]
76       : ieee_context
77     type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
78     type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
79     subProgSpecs = concat (map subProgSpec tyfun_decls)
80     subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
81     mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
82     mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
83     mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
84
85 -- Create a use foo.bar.all statement. Takes a list of components in the used
86 -- name. Must contain at least two components
87 mkUseAll :: [String] -> AST.ContextItem
88 mkUseAll ss = 
89   AST.Use $ from AST.:.: AST.All
90   where
91     base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
92     from = foldl select base_prefix (tail ss)
93     select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
94       
95 createLibraryUnits ::
96   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
97   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
98
99 createLibraryUnits binds = do
100   entities <- Monad.mapM createEntity binds
101   archs <- Monad.mapM createArchitecture binds
102   return $ zipWith 
103     (\ent arch -> 
104       let AST.EntityDec id _ = ent in 
105       (id, [AST.LUEntity ent, AST.LUArch arch])
106     )
107     entities archs
108
109 -- | Create an entity for a given function
110 createEntity ::
111   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
112   -> VHDLState AST.EntityDec -- | The resulting entity
113
114 createEntity (fname, expr) = do
115       -- Strip off lambda's, these will be arguments
116       let (args, letexpr) = CoreSyn.collectBinders expr
117       args' <- Monad.mapM mkMap args
118       -- There must be a let at top level 
119       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
120       res' <- mkMap res
121       let vhdl_id = mkVHDLBasicId $ bndrToString fname ++ "_" ++ varToStringUniq fname
122       let ent_decl' = createEntityAST vhdl_id args' res'
123       let AST.EntityDec entity_id _ = ent_decl' 
124       let signature = Entity entity_id args' res'
125       modA vsSignatures (Map.insert fname signature)
126       return ent_decl'
127   where
128     mkMap ::
129       --[(SignalId, SignalInfo)] 
130       CoreSyn.CoreBndr 
131       -> VHDLState VHDLSignalMapElement
132     -- We only need the vsTypes element from the state
133     mkMap = (\bndr ->
134       let
135         --info = Maybe.fromMaybe
136         --  (error $ "Signal not found in the name map? This should not happen!")
137         --  (lookup id sigmap)
138         --  Assume the bndr has a valid VHDL id already
139         id = bndrToVHDLId bndr
140         ty = Var.varType bndr
141       in
142         if True -- isPortSigUse $ sigUse info
143           then do
144             type_mark <- vhdl_ty ty
145             return $ Just (id, type_mark)
146           else
147             return $ Nothing
148        )
149
150   -- | Create the VHDL AST for an entity
151 createEntityAST ::
152   AST.VHDLId                   -- | The name of the function
153   -> [VHDLSignalMapElement]    -- | The entity's arguments
154   -> VHDLSignalMapElement      -- | The entity's result
155   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
156
157 createEntityAST vhdl_id args res =
158   AST.EntityDec vhdl_id ports
159   where
160     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
161     ports = Maybe.catMaybes $ 
162               map (mkIfaceSigDec AST.In) args
163               ++ [mkIfaceSigDec AST.Out res]
164               ++ [clk_port]
165     -- Add a clk port if we have state
166     clk_port = if True -- hasState hsfunc
167       then
168         Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
169       else
170         Nothing
171
172 -- | Create a port declaration
173 mkIfaceSigDec ::
174   AST.Mode                         -- | The mode for the port (In / Out)
175   -> Maybe (AST.VHDLId, AST.TypeMark)    -- | The id and type for the port
176   -> Maybe AST.IfaceSigDec               -- | The resulting port declaration
177
178 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
179 mkIfaceSigDec _ Nothing = Nothing
180
181 -- | Generate a VHDL entity name for the given hsfunc
182 mkEntityId hsfunc =
183   -- TODO: This doesn't work for functions with multiple signatures!
184   -- Use a Basic Id, since using extended id's for entities throws off
185   -- precision and causes problems when generating filenames.
186   mkVHDLBasicId $ hsFuncName hsfunc
187
188 -- | Create an architecture for a given function
189 createArchitecture ::
190   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
191   -> VHDLState AST.ArchBody -- ^ The architecture for this function
192
193 createArchitecture (fname, expr) = do
194   signaturemap <- getA vsSignatures
195   let signature = Maybe.fromMaybe 
196         (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
197         (Map.lookup fname signaturemap)
198   let entity_id = ent_id signature
199   -- Strip off lambda's, these will be arguments
200   let (args, letexpr) = CoreSyn.collectBinders expr
201   -- There must be a let at top level 
202   let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
203
204   -- Create signal declarations for all binders in the let expression, except
205   -- for the output port (that will already have an output port declared in
206   -- the entity).
207   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
208   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
209
210   statementss <- Monad.mapM mkConcSm binds
211   let statements = concat statementss
212   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
213   where
214     procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
215     procs' = map AST.CSPSm procs
216     -- mkSigDec only uses vsTypes from the state
217     mkSigDec' = mkSigDec
218
219 -- | Looks up all pairs of old state, new state signals, together with
220 --   the state id they represent.
221 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
222 makeStatePairs flatfunc =
223   [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info) 
224     | old_info <- map snd (flat_sigs flatfunc)
225     , new_info <- map snd (flat_sigs flatfunc)
226         -- old_info must be an old state (and, because of the next equality,
227         -- new_info must be a new state).
228         , Maybe.isJust $ oldStateId $ sigUse old_info
229         -- And the state numbers must match
230     , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
231
232     -- Replace the second tuple element with the corresponding SignalInfo
233     --args_states = map (Arrow.second $ signalInfo sigs) args
234 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
235 mkStateProcSm (num, old, new) =
236   AST.ProcSm label [clk] [statement]
237   where
238     label       = mkVHDLExtId $ "state_" ++ (show num)
239     clk         = mkVHDLExtId "clk"
240     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
241     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
242     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
243     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
244     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
245
246 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
247 mkSigDec bndr =
248   if True then do --isInternalSigUse use || isStateSigUse use then do
249     type_mark <- vhdl_ty $ Var.varType bndr
250     return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
251   else
252     return Nothing
253
254 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
255 --   is not named.
256 getSignalId :: SignalInfo -> AST.VHDLId
257 getSignalId info =
258     mkVHDLExtId $ Maybe.fromMaybe
259       (error $ "Unnamed signal? This should not happen!")
260       (sigName info)
261
262 -- | Transforms a core binding into a VHDL concurrent statement
263 mkConcSm ::
264   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
265   -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
266
267
268 -- Ignore Cast expressions, they should not longer have any meaning as long as
269 -- the type works out.
270 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
271
272 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
273   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
274   let valargs' = filter isValArg args
275   let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
276   case Var.globalIdVarDetails f of
277     IdInfo.DataConWorkId dc ->
278         -- It's a datacon. Create a record from its arguments.
279         -- First, filter out type args. TODO: Is this the best way to do this?
280         -- The types should already have been taken into acocunt when creating
281         -- the signal, so this should probably work...
282         --let valargs = filter isValArg args in
283         if all is_var valargs then do
284           labels <- getFieldLabels (CoreUtils.exprType app)
285           return $ zipWith mkassign labels valargs
286         else
287           error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
288       where
289         mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
290         mkassign label (Var arg) =
291           let sel_name = mkSelectedName bndr label in
292           mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
293     IdInfo.VanillaGlobal -> do
294       -- It's a global value imported from elsewhere. These can be builtin
295       -- functions.
296       funSignatures <- getA vsNameTable
297       case (Map.lookup (bndrToString f) funSignatures) of
298         Just (arg_count, builder) ->
299           if length valargs == arg_count then
300             let
301               sigs = map (varToVHDLExpr.varBndr) valargs
302               func = builder sigs
303               src_wform = AST.Wform [AST.WformElem func Nothing]
304               dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
305               assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
306             in
307               return [AST.CSSASm assign]
308           else
309             error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
310         Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
311     IdInfo.NotGlobalId -> do
312       signatures <- getA vsSignatures
313       -- This is a local id, so it should be a function whose definition we
314       -- have and which can be turned into a component instantiation.
315       let  
316         signature = Maybe.fromMaybe 
317           (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 
318           (Map.lookup f signatures)
319         entity_id = ent_id signature
320         label = "comp_ins_" ++ bndrToString bndr
321         -- Add a clk port if we have state
322         --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
323         clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
324         --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
325         portmaps = clk_port : mkAssocElems args bndr signature
326         in
327           return [AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)]
328     details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
329
330 -- A single alt case must be a selector. This means thee scrutinee is a simple
331 -- variable, the alternative is a dataalt with a single non-wild binder that
332 -- is also returned.
333 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
334   case alt of
335     (DataAlt dc, bndrs, (Var sel_bndr)) -> do
336       case List.elemIndex sel_bndr bndrs of
337         Just i -> do
338           labels <- getFieldLabels (Id.idType scrut)
339           let label = labels!!i
340           let sel_name = mkSelectedName scrut label
341           let sel_expr = AST.PrimName sel_name
342           return [mkUncondAssign (Left bndr) sel_expr]
343         Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
344       
345     _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
346
347 -- Multiple case alt are be conditional assignments and have only wild
348 -- binders in the alts and only variables in the case values and a variable
349 -- for a scrutinee. We check the constructor of the second alt, since the
350 -- first is the default case, if there is any.
351 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
352   let
353     cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
354     true_expr  = (varToVHDLExpr true)
355     false_expr  = (varToVHDLExpr false)
356   in
357     return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
358 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
359 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
360 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
361
362 -- Create an unconditional assignment statement
363 mkUncondAssign ::
364   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
365   -> AST.Expr -- ^ The expression to assign
366   -> AST.ConcSm -- ^ The resulting concurrent statement
367 mkUncondAssign dst expr = mkAssign dst Nothing expr
368
369 -- Create a conditional assignment statement
370 mkCondAssign ::
371   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
372   -> AST.Expr -- ^ The condition
373   -> AST.Expr -- ^ The value when true
374   -> AST.Expr -- ^ The value when false
375   -> AST.ConcSm -- ^ The resulting concurrent statement
376 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
377
378 -- Create a conditional or unconditional assignment statement
379 mkAssign ::
380   Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
381   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
382                                  -- and the value to assign when true.
383   AST.Expr -> -- ^ The value to assign when false or no condition
384   AST.ConcSm -- ^ The resulting concurrent statement
385
386 mkAssign dst cond false_expr =
387   let
388     -- I'm not 100% how this assignment AST works, but this gets us what we
389     -- want...
390     whenelse = case cond of
391       Just (cond_expr, true_expr) -> 
392         let 
393           true_wform = AST.Wform [AST.WformElem true_expr Nothing] 
394         in
395           [AST.WhenElse true_wform cond_expr]
396       Nothing -> []
397     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
398     dst_name  = case dst of
399       Left bndr -> AST.NSimple (bndrToVHDLId bndr)
400       Right name -> name
401     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
402   in
403     AST.CSSASm assign
404
405 -- Create a record field selector that selects the given label from the record
406 -- stored in the given binder.
407 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
408 mkSelectedName bndr label =
409   let 
410     sel_prefix = AST.NSimple $ bndrToVHDLId bndr
411     sel_suffix = AST.SSimple $ label
412   in
413     AST.NSelected $ sel_prefix AST.:.: sel_suffix 
414
415 -- Finds the field labels for VHDL type generated for the given Core type,
416 -- which must result in a record type.
417 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
418 getFieldLabels ty = do
419   -- Ensure that the type is generated (but throw away it's VHDLId)
420   vhdl_ty ty
421   -- Get the types map, lookup and unpack the VHDL TypeDef
422   types <- getA vsTypes
423   case Map.lookup (OrdType ty) types of
424     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
425     _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
426
427 -- Turn a variable reference into a AST expression
428 varToVHDLExpr :: Var.Var -> AST.Expr
429 varToVHDLExpr var = 
430   case Id.isDataConWorkId_maybe var of
431     Just dc -> dataconToVHDLExpr dc
432     -- This is a dataconstructor.
433     -- Not a datacon, just another signal. Perhaps we should check for
434     -- local/global here as well?
435     Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var
436
437 -- Turn a alternative constructor into an AST expression. For
438 -- dataconstructors, this is only the constructor itself, not any arguments it
439 -- has. Should not be called with a DEFAULT constructor.
440 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
441 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
442
443 altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
444 altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
445
446 -- Turn a datacon (without arguments!) into a VHDL expression.
447 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
448 dataconToVHDLExpr dc = AST.PrimLit lit
449   where
450     tycon = DataCon.dataConTyCon dc
451     tyname = TyCon.tyConName tycon
452     dcname = DataCon.dataConName dc
453     lit = case Name.getOccString tyname of
454       -- TODO: Do something more robust than string matching
455       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
456       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
457
458
459 {-
460 mkConcSm sigs (UncondDef src dst) _ = do
461   src_expr <- vhdl_expr src
462   let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
463   let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
464   let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
465   return $ AST.CSSASm assign
466   where
467     vhdl_expr (Left id) = return $ mkIdExpr sigs id
468     vhdl_expr (Right expr) =
469       case expr of
470         (EqLit id lit) ->
471           return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
472         (Literal lit Nothing) ->
473           return $ AST.PrimLit lit
474         (Literal lit (Just ty)) -> do
475           -- Create a cast expression, which is just a function call using the
476           -- type name as the function name.
477           let litexpr = AST.PrimLit lit
478           ty_id <- vhdl_ty ty
479           let ty_name = AST.NSimple ty_id
480           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] 
481           return $ AST.PrimFCall $ AST.FCall ty_name args
482         (Eq a b) ->
483          return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
484
485 mkConcSm sigs (CondDef cond true false dst) _ =
486   let
487     cond_expr  = mkIdExpr sigs cond
488     true_expr  = mkIdExpr sigs true
489     false_expr  = mkIdExpr sigs false
490     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
491     true_wform = AST.Wform [AST.WformElem true_expr Nothing]
492     whenelse = AST.WhenElse true_wform cond_expr
493     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
494     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
495   in
496     return $ AST.CSSASm assign
497 -}
498 -- | Turn a SignalId into a VHDL Expr
499 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
500 mkIdExpr sigs id =
501   let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
502   AST.PrimName src_name
503
504 mkAssocElems :: 
505   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
506   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
507   -> Entity                     -- | The entity to map against.
508   -> [AST.AssocElem]            -- | The resulting port maps
509
510 mkAssocElems args res entity =
511     -- Create the actual AssocElems
512     Maybe.catMaybes $ zipWith mkAssocElem ports sigs
513   where
514     -- Turn the ports and signals from a map into a flat list. This works,
515     -- since the maps must have an identical form by definition. TODO: Check
516     -- the similar form?
517     arg_ports = ent_args entity
518     res_port  = ent_res entity
519     -- Extract the id part from the (id, type) tuple
520     ports     = map (Monad.liftM fst) (res_port : arg_ports)
521     -- Translate signal numbers into names
522     sigs      = (bndrToString res : map (bndrToString.varBndr) args)
523
524 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
525 -- simple Var CoreExprs, not complexer ones.
526 varBndr :: CoreSyn.CoreExpr -> Var.Id
527 varBndr (CoreSyn.Var id) = id
528
529 -- | Look up a signal in the signal name map
530 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
531 lookupSigName sigs sig = name
532   where
533     info = Maybe.fromMaybe
534       (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
535       (lookup sig sigs)
536     name = Maybe.fromMaybe
537       (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
538       (sigName info)
539
540 -- | Create an VHDL port -> signal association
541 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
542 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal))) 
543 mkAssocElem Nothing _ = Nothing
544
545 -- | The VHDL Bit type
546 bit_ty :: AST.TypeMark
547 bit_ty = AST.unsafeVHDLBasicId "Bit"
548
549 -- | The VHDL Boolean type
550 bool_ty :: AST.TypeMark
551 bool_ty = AST.unsafeVHDLBasicId "Boolean"
552
553 -- | The VHDL std_logic
554 std_logic_ty :: AST.TypeMark
555 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
556
557 -- Translate a Haskell type to a VHDL type
558 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
559 vhdl_ty ty = do
560   typemap <- getA vsTypes
561   let builtin_ty = do -- See if this is a tycon and lookup its name
562         (tycon, args) <- Type.splitTyConApp_maybe ty
563         let name = Name.getOccString (TyCon.tyConName tycon)
564         Map.lookup name builtin_types
565   -- If not a builtin type, try the custom types
566   let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
567   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
568     -- Found a type, return it
569     Just t -> return t
570     -- No type yet, try to construct it
571     Nothing -> do
572       newty_maybe <- (construct_vhdl_ty ty)
573       case newty_maybe of
574         Just (ty_id, ty_def) -> do
575           -- TODO: Check name uniqueness
576           modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
577           return ty_id
578         Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
579
580 -- Construct a new VHDL type for the given Haskell type.
581 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
582 construct_vhdl_ty ty = do
583   case Type.splitTyConApp_maybe ty of
584     Just (tycon, args) -> do
585       let name = Name.getOccString (TyCon.tyConName tycon)
586       case name of
587         "TFVec" -> do
588           res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
589           return $ Just $ (Arrow.second Right) res
590         -- "SizedWord" -> do
591         --   res <- mk_vector_ty (sized_word_len ty) ty
592         --   return $ Just $ (Arrow.second Left) res
593         "RangedWord" -> do 
594           res <- mk_natural_ty 0 (ranged_word_bound ty)
595           return $ Just $ (Arrow.second Right) res
596         -- Create a custom type from this tycon
597         otherwise -> mk_tycon_ty tycon args
598     Nothing -> return $ Nothing
599
600 -- | Create VHDL type for a custom tycon
601 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
602 mk_tycon_ty tycon args =
603   case TyCon.tyConDataCons tycon of
604     -- Not an algebraic type
605     [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
606     [dc] -> do
607       let arg_tys = DataCon.dataConRepArgTys dc
608       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
609       -- violation? Or does it only mean not to apply it again to the same
610       -- subject?
611       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
612       elem_tys <- mapM vhdl_ty real_arg_tys
613       let elems = zipWith AST.ElementDec recordlabels elem_tys
614       -- For a single construct datatype, build a record with one field for
615       -- each argument.
616       -- TODO: Add argument type ids to this, to ensure uniqueness
617       -- TODO: Special handling for tuples?
618       let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
619       let ty_def = AST.TDR $ AST.RecordTypeDef elems
620       return $ Just (ty_id, Left ty_def)
621     dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
622   where
623     -- Create a subst that instantiates all types passed to the tycon
624     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
625     -- to work so far, though..
626     tyvars = TyCon.tyConTyVars tycon
627     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
628
629 -- | Create a VHDL vector type
630 mk_vector_ty ::
631   Int -- ^ The length of the vector
632   -> Type.Type -- ^ The Haskell element type of the Vector
633   -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
634
635 mk_vector_ty len el_ty = do
636   elem_types_map <- getA vsElemTypes
637   el_ty_tm <- vhdl_ty el_ty
638   let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
639   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
640   let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
641   case existing_elem_ty of
642     Just t -> do
643       let ty_def = AST.SubtypeIn t (Just range)
644       return (ty_id, ty_def)
645     Nothing -> do
646       let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
647       let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
648       modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
649       modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id)) 
650       let ty_def = AST.SubtypeIn vec_id (Just range)
651       return (ty_id, ty_def)
652
653 mk_natural_ty ::
654   Int -- ^ The minimum bound (> 0)
655   -> Int -- ^ The maximum bound (> minimum bound)
656   -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
657 mk_natural_ty min_bound max_bound = do
658   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
659   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
660   let ty_def = AST.SubtypeIn naturalTM (Just range)
661   return (ty_id, ty_def)
662   
663 builtin_types = 
664   Map.fromList [
665     ("Bit", std_logic_ty),
666     ("Bool", bool_ty) -- TysWiredIn.boolTy
667   ]
668
669 -- Shortcut for 
670 -- Can only contain alphanumerics and underscores. The supplied string must be
671 -- a valid basic id, otherwise an error value is returned. This function is
672 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
673 -- that.
674 mkVHDLBasicId :: String -> AST.VHDLId
675 mkVHDLBasicId s = 
676   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
677   where
678     -- Strip invalid characters.
679     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
680     -- Strip leading numbers and underscores
681     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
682     -- Strip multiple adjacent underscores
683     strip_multiscore = concat . map (\cs -> 
684         case cs of 
685           ('_':_) -> "_"
686           _ -> cs
687       ) . List.group
688
689 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
690 -- different characters than basic ids, but can never be used to refer to
691 -- basic ids.
692 -- Use extended Ids for any values that are taken from the source file.
693 mkVHDLExtId :: String -> AST.VHDLId
694 mkVHDLExtId s = 
695   AST.unsafeVHDLExtId $ strip_invalid s
696   where 
697     -- Allowed characters, taken from ForSyde's mkVHDLExtId
698     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
699     strip_invalid = filter (`elem` allowed)
700
701 -- Creates a VHDL Id from a binder
702 bndrToVHDLId ::
703   CoreSyn.CoreBndr
704   -> AST.VHDLId
705
706 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
707
708 -- Extracts the binder name as a String
709 bndrToString ::
710   CoreSyn.CoreBndr
711   -> String
712 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
713
714 -- Get the string version a Var's unique
715 varToStringUniq = show . Var.varUnique
716
717 -- Extracts the string version of the name
718 nameToString :: Name.Name -> String
719 nameToString = OccName.occNameString . Name.nameOccName
720
721 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
722
723 -- | Map a port specification of a builtin function to a VHDL Signal to put in
724 --   a VHDLSignalMap
725 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
726 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)