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