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