412e0c4a2dfa26193b33777f19282b169c3be8c0
[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / VHDLTools.hs
1 module CLasH.VHDL.VHDLTools where
2
3 -- Standard modules
4 import qualified Maybe
5 import qualified Data.Either as Either
6 import qualified Data.List as List
7 import qualified Data.Map as Map
8 import qualified Control.Monad as Monad
9 import qualified Control.Arrow as Arrow
10 import qualified Control.Monad.Trans.State as State
11 import qualified Data.Monoid as Monoid
12 import Data.Accessor
13 import Data.Accessor.MonadState as MonadState
14 import Debug.Trace
15
16 -- ForSyDe
17 import qualified Language.VHDL.AST as AST
18
19 -- GHC API
20 import CoreSyn
21 import qualified Name
22 import qualified OccName
23 import qualified Var
24 import qualified Id
25 import qualified IdInfo
26 import qualified TyCon
27 import qualified Type
28 import qualified DataCon
29 import qualified CoreSubst
30
31 -- Local imports
32 import CLasH.VHDL.VHDLTypes
33 import CLasH.Utils.Core.CoreTools
34 import CLasH.Utils.Pretty
35 import CLasH.VHDL.Constants
36
37 -----------------------------------------------------------------------------
38 -- Functions to generate concurrent statements
39 -----------------------------------------------------------------------------
40
41 -- Create an unconditional assignment statement
42 mkUncondAssign ::
43   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
44   -> AST.Expr -- ^ The expression to assign
45   -> AST.ConcSm -- ^ The resulting concurrent statement
46 mkUncondAssign dst expr = mkAssign dst Nothing expr
47
48 -- Create a conditional assignment statement
49 mkCondAssign ::
50   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
51   -> AST.Expr -- ^ The condition
52   -> AST.Expr -- ^ The value when true
53   -> AST.Expr -- ^ The value when false
54   -> AST.ConcSm -- ^ The resulting concurrent statement
55 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
56
57 -- Create a conditional or unconditional assignment statement
58 mkAssign ::
59   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
60   -> Maybe (AST.Expr , AST.Expr) -- ^ Optionally, the condition to test for
61                                  -- and the value to assign when true.
62   -> AST.Expr -- ^ The value to assign when false or no condition
63   -> AST.ConcSm -- ^ The resulting concurrent statement
64 mkAssign dst cond false_expr =
65   let
66     -- I'm not 100% how this assignment AST works, but this gets us what we
67     -- want...
68     whenelse = case cond of
69       Just (cond_expr, true_expr) -> 
70         let 
71           true_wform = AST.Wform [AST.WformElem true_expr Nothing] 
72         in
73           [AST.WhenElse true_wform cond_expr]
74       Nothing -> []
75     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
76     dst_name  = case dst of
77       Left bndr -> AST.NSimple (varToVHDLId bndr)
78       Right name -> name
79     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
80   in
81     AST.CSSASm assign
82
83 mkAssocElems :: 
84   [AST.Expr]                    -- ^ The argument that are applied to function
85   -> AST.VHDLName               -- ^ The binder in which to store the result
86   -> Entity                     -- ^ The entity to map against.
87   -> [AST.AssocElem]            -- ^ The resulting port maps
88 mkAssocElems args res entity =
89     -- Create the actual AssocElems
90     zipWith mkAssocElem ports sigs
91   where
92     -- Turn the ports and signals from a map into a flat list. This works,
93     -- since the maps must have an identical form by definition. TODO: Check
94     -- the similar form?
95     arg_ports = ent_args entity
96     res_port  = ent_res entity
97     -- Extract the id part from the (id, type) tuple
98     ports     = map fst (res_port : arg_ports)
99     -- Translate signal numbers into names
100     sigs      = (vhdlNameToVHDLExpr res : args)
101
102 -- | Create an VHDL port -> signal association
103 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
104 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
105
106 -- | Create an VHDL port -> signal association
107 mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
108 mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName 
109                       (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
110
111 mkComponentInst ::
112   String -- ^ The portmap label
113   -> AST.VHDLId -- ^ The entity name
114   -> [AST.AssocElem] -- ^ The port assignments
115   -> AST.ConcSm
116 mkComponentInst label entity_id portassigns = AST.CSISm compins
117   where
118     -- We always have a clock port, so no need to map it anywhere but here
119     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
120     compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
121
122 -----------------------------------------------------------------------------
123 -- Functions to generate VHDL Exprs
124 -----------------------------------------------------------------------------
125
126 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
127 varToVHDLExpr var = do
128   case Id.isDataConWorkId_maybe var of
129     Just dc -> return $ dataconToVHDLExpr dc
130     -- This is a dataconstructor.
131     -- Not a datacon, just another signal. Perhaps we should check for
132     -- local/global here as well?
133     -- Sadly so.. tfp decimals are types, not data constructors, but instances
134     -- should still be translated to integer literals. It is probebly not the
135     -- best solution to translate them here.
136     -- FIXME: Find a better solution for translating instances of tfp integers
137     Nothing -> do
138         let ty  = Var.varType var
139         case Type.splitTyConApp_maybe ty of
140                 Just (tycon, args) ->
141                   case Name.getOccString (TyCon.tyConName tycon) of
142                     "Dec" -> do
143                       len <- tfp_to_int ty
144                       return $ AST.PrimLit $ (show len)
145                     otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
146
147 -- Turn a VHDLName into an AST expression
148 vhdlNameToVHDLExpr = AST.PrimName
149
150 -- Turn a VHDL Id into an AST expression
151 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
152
153 -- Turn a Core expression into an AST expression
154 exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
155
156 -- Turn a alternative constructor into an AST expression. For
157 -- dataconstructors, this is only the constructor itself, not any arguments it
158 -- has. Should not be called with a DEFAULT constructor.
159 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
160 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
161
162 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
163 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
164
165 -- Turn a datacon (without arguments!) into a VHDL expression.
166 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
167 dataconToVHDLExpr dc = AST.PrimLit lit
168   where
169     tycon = DataCon.dataConTyCon dc
170     tyname = TyCon.tyConName tycon
171     dcname = DataCon.dataConName dc
172     lit = case Name.getOccString tyname of
173       -- TODO: Do something more robust than string matching
174       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
175       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
176
177 -----------------------------------------------------------------------------
178 -- Functions dealing with names, variables and ids
179 -----------------------------------------------------------------------------
180
181 -- Creates a VHDL Id from a binder
182 varToVHDLId ::
183   CoreSyn.CoreBndr
184   -> AST.VHDLId
185 varToVHDLId = mkVHDLExtId . varToString
186
187 -- Creates a VHDL Name from a binder
188 varToVHDLName ::
189   CoreSyn.CoreBndr
190   -> AST.VHDLName
191 varToVHDLName = AST.NSimple . varToVHDLId
192
193 -- Extracts the binder name as a String
194 varToString ::
195   CoreSyn.CoreBndr
196   -> String
197 varToString = OccName.occNameString . Name.nameOccName . Var.varName
198
199 -- Get the string version a Var's unique
200 varToStringUniq :: Var.Var -> String
201 varToStringUniq = show . Var.varUnique
202
203 -- Extracts the string version of the name
204 nameToString :: Name.Name -> String
205 nameToString = OccName.occNameString . Name.nameOccName
206
207 -- Shortcut for Basic VHDL Ids.
208 -- Can only contain alphanumerics and underscores. The supplied string must be
209 -- a valid basic id, otherwise an error value is returned. This function is
210 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
211 -- that.
212 mkVHDLBasicId :: String -> AST.VHDLId
213 mkVHDLBasicId s = 
214   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
215   where
216     -- Strip invalid characters.
217     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
218     -- Strip leading numbers and underscores
219     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
220     -- Strip multiple adjacent underscores
221     strip_multiscore = concat . map (\cs -> 
222         case cs of 
223           ('_':_) -> "_"
224           _ -> cs
225       ) . List.group
226
227 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
228 -- different characters than basic ids, but can never be used to refer to
229 -- basic ids.
230 -- Use extended Ids for any values that are taken from the source file.
231 mkVHDLExtId :: String -> AST.VHDLId
232 mkVHDLExtId s = 
233   AST.unsafeVHDLExtId $ strip_invalid s
234   where 
235     -- Allowed characters, taken from ForSyde's mkVHDLExtId
236     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
237     strip_invalid = filter (`elem` allowed)
238
239 -- Create a record field selector that selects the given label from the record
240 -- stored in the given binder.
241 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
242 mkSelectedName name label =
243    AST.NSelected $ name AST.:.: (AST.SSimple label) 
244
245 -- Create an indexed name that selects a given element from a vector.
246 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
247 -- Special case for already indexed names. Just add an index
248 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
249  AST.NIndexed (AST.IndexedName name (indexes++[index]))
250 -- General case for other names
251 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
252
253 -----------------------------------------------------------------------------
254 -- Functions dealing with VHDL types
255 -----------------------------------------------------------------------------
256
257 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
258 -- for a few builtin types.
259 builtin_types = 
260   Map.fromList [
261     ("Bit", std_logicTM),
262     ("Bool", booleanTM), -- TysWiredIn.boolTy
263     ("Dec", integerTM)
264   ]
265
266 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
267 -- Returns an error value, using the given message, when no type could be
268 -- created.
269 vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
270 vhdl_ty msg ty = do
271   tm_either <- vhdl_ty_either ty
272   case tm_either of
273     Right tm -> return tm
274     Left err -> error $ msg ++ "\n" ++ err
275
276 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
277 -- Returns either an error message or the resulting type.
278 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
279 vhdl_ty_either ty = do
280   typemap <- getA vsTypes
281   htype_either <- mkHType ty
282   case htype_either of
283     -- No errors
284     Right htype -> do
285       let builtin_ty = do -- See if this is a tycon and lookup its name
286             (tycon, args) <- Type.splitTyConApp_maybe ty
287             let name = Name.getOccString (TyCon.tyConName tycon)
288             Map.lookup name builtin_types
289       -- If not a builtin type, try the custom types
290       let existing_ty = (fmap fst) $ Map.lookup htype typemap
291       case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
292         -- Found a type, return it
293         Just t -> return (Right t)
294         -- No type yet, try to construct it
295         Nothing -> do
296           newty_maybe <- (construct_vhdl_ty ty)
297           case newty_maybe of
298             Right (ty_id, ty_def) -> do
299               -- TODO: Check name uniqueness
300               modA vsTypes (Map.insert htype (ty_id, ty_def))
301               modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
302               return (Right ty_id)
303             Left err -> return $ Left $
304               "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
305               ++ err
306     -- Error when constructing htype
307     Left err -> return $ Left err 
308
309 -- Construct a new VHDL type for the given Haskell type. Returns an error
310 -- message or the resulting typemark and typedef.
311 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
312 construct_vhdl_ty ty = do
313   case Type.splitTyConApp_maybe ty of
314     Just (tycon, args) -> do
315       let name = Name.getOccString (TyCon.tyConName tycon)
316       case name of
317         "TFVec" -> mk_vector_ty ty
318         "SizedWord" -> mk_unsigned_ty ty
319         "SizedInt"  -> mk_signed_ty ty
320         "RangedWord" -> do 
321           bound <- tfp_to_int (ranged_word_bound_ty ty)
322           mk_natural_ty 0 bound
323         -- Create a custom type from this tycon
324         otherwise -> mk_tycon_ty ty tycon args
325     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
326
327 -- | Create VHDL type for a custom tycon
328 mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
329 mk_tycon_ty ty tycon args =
330   case TyCon.tyConDataCons tycon of
331     -- Not an algebraic type
332     [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
333     [dc] -> do
334       let arg_tys = DataCon.dataConRepArgTys dc
335       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
336       -- violation? Or does it only mean not to apply it again to the same
337       -- subject?
338       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
339       elem_tys_either <- mapM vhdl_ty_either real_arg_tys
340       case Either.partitionEithers elem_tys_either of
341         -- No errors in element types
342         ([], elem_tys) -> do
343           let elems = zipWith AST.ElementDec recordlabels elem_tys
344           -- For a single construct datatype, build a record with one field for
345           -- each argument.
346           -- TODO: Add argument type ids to this, to ensure uniqueness
347           -- TODO: Special handling for tuples?
348           let elem_names = concat $ map prettyShow elem_tys
349           let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
350           let ty_def = AST.TDR $ AST.RecordTypeDef elems
351           let tupshow = mkTupleShow elem_tys ty_id
352           modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
353           return $ Right (ty_id, Left ty_def)
354         -- There were errors in element types
355         (errors, _) -> return $ Left $
356           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
357           ++ (concat errors)
358     dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
359   where
360     -- Create a subst that instantiates all types passed to the tycon
361     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
362     -- to work so far, though..
363     tyvars = TyCon.tyConTyVars tycon
364     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
365     -- Generate a bunch of labels for fields of a record
366     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
367
368 -- | Create a VHDL vector type
369 mk_vector_ty ::
370   Type.Type -- ^ The Haskell type of the Vector
371   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
372       -- ^ An error message or The typemark created.
373
374 mk_vector_ty ty = do
375   types_map <- getA vsTypes
376   env <- getA vsHscEnv
377   let (nvec_l, nvec_el) = Type.splitAppTy ty
378   let (nvec, leng) = Type.splitAppTy nvec_l
379   let vec_ty = Type.mkAppTy nvec nvec_el
380   len <- tfp_to_int (tfvec_len_ty ty)
381   let el_ty = tfvec_elem ty
382   el_ty_tm_either <- vhdl_ty_either el_ty
383   case el_ty_tm_either of
384     -- Could create element type
385     Right el_ty_tm -> do
386       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
387       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
388       let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
389       case existing_elem_ty of
390         Just t -> do
391           let ty_def = AST.SubtypeIn t (Just range)
392           return (Right (ty_id, Right ty_def))
393         Nothing -> do
394           let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
395           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
396           modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
397           modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
398           let vecShowFuns = mkVectorShow el_ty_tm vec_id
399           mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
400           let ty_def = AST.SubtypeIn vec_id (Just range)
401           return (Right (ty_id, Right ty_def))
402     -- Could not create element type
403     Left err -> return $ Left $ 
404       "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
405       ++ err
406
407 mk_natural_ty ::
408   Int -- ^ The minimum bound (> 0)
409   -> Int -- ^ The maximum bound (> minimum bound)
410   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
411       -- ^ An error message or The typemark created.
412 mk_natural_ty min_bound max_bound = do
413   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
414   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
415   let ty_def = AST.SubtypeIn naturalTM (Just range)
416   return (Right (ty_id, Right ty_def))
417
418 mk_unsigned_ty ::
419   Type.Type -- ^ Haskell type of the unsigned integer
420   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
421 mk_unsigned_ty ty = do
422   size <- tfp_to_int (sized_word_len_ty ty)
423   let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
424   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
425   let ty_def = AST.SubtypeIn unsignedTM (Just range)
426   let unsignedshow = mkIntegerShow ty_id
427   modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
428   return (Right (ty_id, Right ty_def))
429   
430 mk_signed_ty ::
431   Type.Type -- ^ Haskell type of the signed integer
432   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
433 mk_signed_ty ty = do
434   size <- tfp_to_int (sized_int_len_ty ty)
435   let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
436   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
437   let ty_def = AST.SubtypeIn signedTM (Just range)
438   let signedshow = mkIntegerShow ty_id
439   modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
440   return (Right (ty_id, Right ty_def))
441
442 -- Finds the field labels for VHDL type generated for the given Core type,
443 -- which must result in a record type.
444 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
445 getFieldLabels ty = do
446   -- Ensure that the type is generated (but throw away it's VHDLId)
447   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
448   vhdl_ty error_msg ty
449   -- Get the types map, lookup and unpack the VHDL TypeDef
450   types <- getA vsTypes
451   -- Assume the type for which we want labels is really translatable
452   Right htype <- mkHType ty
453   case Map.lookup htype types of
454     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
455     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
456     
457 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
458 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
459 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
460
461 mkHType :: Type.Type -> TypeSession (Either String HType)
462 mkHType ty = do
463   -- FIXME: Do we really need to do this here again?
464   let builtin_ty = do -- See if this is a tycon and lookup its name
465         (tycon, args) <- Type.splitTyConApp_maybe ty
466         let name = Name.getOccString (TyCon.tyConName tycon)
467         Map.lookup name builtin_types
468   case builtin_ty of
469     Just typ ->
470       return $ Right $ BuiltinType $ prettyShow typ
471     Nothing ->
472       case Type.splitTyConApp_maybe ty of
473         Just (tycon, args) -> do
474           let name = Name.getOccString (TyCon.tyConName tycon)
475           case name of
476             "TFVec" -> do
477               let el_ty = tfvec_elem ty
478               elem_htype_either <- mkHType el_ty
479               case elem_htype_either of
480                 -- Could create element type
481                 Right elem_htype -> do
482                   len <- tfp_to_int (tfvec_len_ty ty)
483                   return $ Right $ VecType len elem_htype
484                 -- Could not create element type
485                 Left err -> return $ Left $ 
486                   "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
487                   ++ err
488             "SizedWord" -> do
489               len <- tfp_to_int (sized_word_len_ty ty)
490               return $ Right $ SizedWType len
491             "SizedInt" -> do
492               len <- tfp_to_int (sized_word_len_ty ty)
493               return $ Right $ SizedIType len
494             "RangedWord" -> do
495               bound <- tfp_to_int (ranged_word_bound_ty ty)
496               return $ Right $ RangedWType bound
497             otherwise -> do
498               mkTyConHType tycon args
499         Nothing -> return $ Right $ StdType $ OrdType ty
500
501 -- FIXME: Do we really need to do this here again?
502 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
503 mkTyConHType tycon args =
504   case TyCon.tyConDataCons tycon of
505     -- Not an algebraic type
506     [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
507     [dc] -> do
508       let arg_tys = DataCon.dataConRepArgTys dc
509       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
510       elem_htys_either <- mapM mkHType real_arg_tys
511       case Either.partitionEithers elem_htys_either of
512         -- No errors in element types
513         ([], elem_htys) -> do
514           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
515         -- There were errors in element types
516         (errors, _) -> return $ Left $
517           "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
518           ++ (concat errors)
519     dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
520   where
521     tyvars = TyCon.tyConTyVars tycon
522     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
523
524 -- Is the given type representable at runtime?
525 isReprType :: Type.Type -> TypeSession Bool
526 isReprType ty = do
527   ty_either <- vhdl_ty_either ty
528   return $ case ty_either of
529     Left _ -> False
530     Right _ -> True
531
532
533 tfp_to_int :: Type.Type -> TypeSession Int
534 tfp_to_int ty = do
535   hscenv <- getA vsHscEnv
536   let norm_ty = normalise_tfp_int hscenv ty
537   case Type.splitTyConApp_maybe norm_ty of
538     Just (tycon, args) -> do
539       let name = Name.getOccString (TyCon.tyConName tycon)
540       case name of
541         "Dec" -> do
542           len <- tfp_to_int' ty
543           return len
544         otherwise -> do
545           modA vsTfpInts (Map.insert (OrdType norm_ty) (-1))
546           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
547     Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
548
549 tfp_to_int' :: Type.Type -> TypeSession Int
550 tfp_to_int' ty = do
551   lens <- getA vsTfpInts
552   hscenv <- getA vsHscEnv
553   let norm_ty = normalise_tfp_int hscenv ty
554   let existing_len = Map.lookup (OrdType norm_ty) lens
555   case existing_len of
556     Just len -> return len
557     Nothing -> do
558       let new_len = eval_tfp_int hscenv ty
559       modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
560       return new_len
561       
562 mkTupleShow :: 
563   [AST.TypeMark] -- ^ type of each tuple element
564   -> AST.TypeMark -- ^ type of the tuple
565   -> AST.SubProgBody
566 mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
567   where
568     tupPar    = AST.unsafeVHDLBasicId "tup"
569     showSpec  = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM
570     showExpr  = AST.ReturnSm (Just $
571                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
572       where
573         showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
574           map ((genExprFCall showId).
575                 AST.PrimName .
576                 AST.NSelected .
577                 (AST.NSimple tupPar AST.:.:).
578                 tupVHDLSuffix)
579               (take tupSize recordlabels)
580     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
581     tupSize = length elemTMs
582
583 mkVectorShow ::
584   AST.TypeMark -- ^ elemtype
585   -> AST.TypeMark -- ^ vectype
586   -> [(String,AST.SubProgBody)]
587 mkVectorShow elemTM vectorTM = 
588   [ (headId, AST.SubProgBody headSpec []                   [headExpr])
589   , (tailId, AST.SubProgBody tailSpec [AST.SPVD tailVar]   [tailExpr, tailRet])
590   , (showIdString, AST.SubProgBody showSpec [AST.SPSB doShowDef] [showRet])
591   ]
592   where
593     vecPar  = AST.unsafeVHDLBasicId "vec"
594     resId   = AST.unsafeVHDLBasicId "res"
595     headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
596     -- return vec(0);
597     headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName 
598                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
599     vecSlice init last =  AST.PrimName (AST.NSlice 
600                                       (AST.SliceName 
601                                             (AST.NSimple vecPar) 
602                                             (AST.ToRange init last)))
603     tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
604        -- variable res : fsvec_x (0 to vec'length-2); 
605     tailVar = 
606          AST.VarDec resId 
607                 (AST.SubtypeIn vectorTM
608                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
609                    [AST.ToRange (AST.PrimLit "0")
610                             (AST.PrimName (AST.NAttribute $ 
611                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
612                                 (AST.PrimLit "2"))   ]))
613                 Nothing       
614        -- res AST.:= vec(1 to vec'length-1)
615     tailExpr = AST.NSimple resId AST.:= (vecSlice 
616                                (AST.PrimLit "1") 
617                                (AST.PrimName (AST.NAttribute $ 
618                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
619                                                              AST.:-: AST.PrimLit "1"))
620     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
621     showSpec  = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM
622     doShowId  = AST.unsafeVHDLExtId "doshow"
623     doShowDef = AST.SubProgBody doShowSpec [] [doShowRet]
624       where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] 
625                                            stringTM
626             -- case vec'len is
627             --  when  0 => return "";
628             --  when  1 => return head(vec);
629             --  when others => return show(head(vec)) & ',' &
630             --                        doshow (tail(vec));
631             -- end case;
632             doShowRet = 
633               AST.CaseSm (AST.PrimName (AST.NAttribute $ 
634                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
635               [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "0"] 
636                          [AST.ReturnSm (Just $ AST.PrimLit "\"\"")],
637                AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"] 
638                          [AST.ReturnSm (Just $ 
639                           genExprFCall showId 
640                                (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],
641                AST.CaseSmAlt [AST.Others] 
642                          [AST.ReturnSm (Just $ 
643                            genExprFCall showId 
644                              (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:
645                            AST.PrimLit "','" AST.:&:
646                            genExprFCall doShowId 
647                              (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]
648     -- return '<' & doshow(vec) & '>';
649     showRet =  AST.ReturnSm (Just $ AST.PrimLit "'<'" AST.:&:
650                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
651                                AST.PrimLit "'>'" )
652
653 mkIntegerShow ::
654   AST.TypeMark -- ^ The specific signed
655   -> AST.SubProgBody
656 mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
657   where
658     signedPar = AST.unsafeVHDLBasicId "sint"
659     showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
660     showExpr = AST.ReturnSm (Just $
661                 AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
662                   (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
663       where
664         signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
665
666 mkBuiltInShow :: [AST.SubProgBody]
667 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
668                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
669                 ]
670   where
671     bitPar    = AST.unsafeVHDLBasicId "s"
672     boolPar    = AST.unsafeVHDLBasicId "b"
673     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
674     -- if s = '1' then return "'1'" else return "'0'"
675     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
676                         [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")]
677                         []
678                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])
679     showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM
680     -- if b then return "True" else return "False"
681     showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar))
682                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
683                         []
684                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
685   
686 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
687 genExprFCall fName args = 
688    AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
689              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args] 
690
691 genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm             
692 genExprPCall2 entid arg1 arg2 =
693         AST.ProcCall (AST.NSimple entid) $
694          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
695
696 mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
697 mkSigDec bndr =
698   if True then do --isInternalSigUse use || isStateSigUse use then do
699     let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
700     type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
701     return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
702   else
703     return Nothing