Add support for multiple alts in case statements

[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / VHDLTools.hs

diff --git a/cλash/CLasH/VHDL/VHDLTools.hs b/cλash/CLasH/VHDL/VHDLTools.hs
index a8fe23941f15c36e0c686d23db0b4d203a8345bf..785b528afb1140db80655c62a7346b6a3bdc2f88 100644 (file)
--- a/cλash/CLasH/VHDL/VHDLTools.hs
+++ b/cλash/CLasH/VHDL/VHDLTools.hs
@@ -1,9 +1,11 @@
+{-# LANGUAGE RelaxedPolyRec #-} -- Needed for vhdl_ty_either', for some reason...

 module CLasH.VHDL.VHDLTools where
 
 -- Standard modules
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.List as List
 module CLasH.VHDL.VHDLTools where
 
 -- Standard modules
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.List as List

+import qualified Data.Char as Char

 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow


@@ -27,11 +29,13 @@ import qualified TyCon
 import qualified Type
 import qualified DataCon
 import qualified CoreSubst
 import qualified Type
 import qualified DataCon
 import qualified CoreSubst

+import qualified Outputable

 
 -- Local imports
 import CLasH.VHDL.VHDLTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils.Core.CoreTools
 
 -- Local imports
 import CLasH.VHDL.VHDLTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Utils.Core.CoreTools

+import CLasH.Utils

 import CLasH.Utils.Pretty
 import CLasH.VHDL.Constants
 
 import CLasH.Utils.Pretty
 import CLasH.VHDL.Constants
 


@@ -69,7 +73,7 @@ mkAssign dst cond false_expr =
     whenelse = case cond of
       Just (cond_expr, true_expr) -> 
         let 
     whenelse = case cond of
       Just (cond_expr, true_expr) -> 
         let 

-          true_wform = AST.Wform [AST.WformElem true_expr Nothing] 
+          true_wform = AST.Wform [AST.WformElem true_expr Nothing]

         in
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []
         in
           [AST.WhenElse true_wform cond_expr]
       Nothing -> []


@@ -81,24 +85,47 @@ mkAssign dst cond false_expr =
   in
     AST.CSSASm assign
 
   in
     AST.CSSASm assign
 

+mkAltsAssign ::
+  Either CoreBndr AST.VHDLName            -- ^ The signal to assign to
+  -> [AST.Expr]       -- ^ The conditions
+  -> [AST.Expr]       -- ^ The expressions
+  -> AST.ConcSm   -- ^ The Alt assigns
+mkAltsAssign dst conds exprs
+        | (length conds) /= ((length exprs) - 1) = error $ "\nVHDLTools.mkAltsAssign: conditions expression mismatch"
+        | otherwise =
+  let
+    whenelses   = zipWith mkWhenElse conds exprs
+    false_wform = AST.Wform [AST.WformElem (last exprs) Nothing]
+    dst_name  = case dst of
+      Left bndr -> AST.NSimple (varToVHDLId bndr)
+      Right name -> name
+    assign    = dst_name AST.:<==: (AST.ConWforms whenelses false_wform Nothing)
+  in
+    AST.CSSASm assign
+  where
+    mkWhenElse :: AST.Expr -> AST.Expr -> AST.WhenElse
+    mkWhenElse cond true_expr =
+      let
+        true_wform = AST.Wform [AST.WformElem true_expr Nothing]
+      in
+        AST.WhenElse true_wform cond
+

 mkAssocElems :: 
   [AST.Expr]                    -- ^ The argument that are applied to function
   -> AST.VHDLName               -- ^ The binder in which to store the result
   -> Entity                     -- ^ The entity to map against.
   -> [AST.AssocElem]            -- ^ The resulting port maps
 mkAssocElems args res entity =
 mkAssocElems :: 
   [AST.Expr]                    -- ^ The argument that are applied to function
   -> AST.VHDLName               -- ^ The binder in which to store the result
   -> Entity                     -- ^ The entity to map against.
   -> [AST.AssocElem]            -- ^ The resulting port maps
 mkAssocElems args res entity =

-    -- Create the actual AssocElems
-    zipWith mkAssocElem ports sigs
+    arg_maps ++ (Maybe.maybeToList res_map_maybe)

   where
   where

-    -- Turn the ports and signals from a map into a flat list. This works,
-    -- since the maps must have an identical form by definition. TODO: Check
-    -- the similar form?

     arg_ports = ent_args entity
     arg_ports = ent_args entity

-    res_port  = ent_res entity
-    -- Extract the id part from the (id, type) tuple
-    ports     = map fst (res_port : arg_ports)
-    -- Translate signal numbers into names
-    sigs      = (vhdlNameToVHDLExpr res : args)
+    res_port_maybe = ent_res entity
+    -- Create an expression of res to map against the output port
+    res_expr = vhdlNameToVHDLExpr res
+    -- Map each of the input ports
+    arg_maps = zipWith mkAssocElem (map fst arg_ports) args
+    -- Map the output port, if present
+    res_map_maybe = fmap (\port -> mkAssocElem (fst port) res_expr) res_port_maybe

 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem


@@ -117,7 +144,8 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
   where
     -- We always have a clock port, so no need to map it anywhere but here
     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)
   where
     -- We always have a clock port, so no need to map it anywhere but here
     clk_port = mkAssocElem clockId (idToVHDLExpr clockId)

-    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
+    resetn_port = mkAssocElem resetId (idToVHDLExpr resetId)
+    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port,resetn_port]))

 
 -----------------------------------------------------------------------------
 -- Functions to generate VHDL Exprs
 
 -----------------------------------------------------------------------------
 -- Functions to generate VHDL Exprs


@@ -126,7 +154,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of

-    Just dc -> return $ dataconToVHDLExpr dc
+    Just dc -> dataconToVHDLExpr dc

     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?


@@ -156,23 +184,37 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.

-altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr

 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"

-altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
+altconToVHDLExpr DEFAULT = return $ AST.PrimLit "undefined" -- error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"

 
 -- Turn a datacon (without arguments!) into a VHDL expression.
 
 -- Turn a datacon (without arguments!) into a VHDL expression.

-dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
-dataconToVHDLExpr dc = AST.PrimLit lit
-  where
-    tycon = DataCon.dataConTyCon dc
-    tyname = TyCon.tyConName tycon
-    dcname = DataCon.dataConName dc
-    lit = case Name.getOccString tyname of
-      -- TODO: Do something more robust than string matching
-      "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
-      "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
+dataconToVHDLExpr dc = do
+  typemap <- getA tsTypes
+  htype_either <- mkHType (DataCon.dataConRepType dc)
+  case htype_either of
+    -- No errors
+    Right htype -> do
+      let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
+      case existing_ty of
+        Just ty -> do
+          let dcname = DataCon.dataConName dc
+          let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
+          return lit
+        Nothing -> do
+          let tycon = DataCon.dataConTyCon dc
+          let tyname = TyCon.tyConName tycon
+          let dcname = DataCon.dataConName dc
+          let lit = case Name.getOccString tyname of
+              -- TODO: Do something more robust than string matching
+                "Bit"  -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+                "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+          return $ AST.PrimLit lit
+    -- Error when constructing htype
+    Left err -> error err

 
 -----------------------------------------------------------------------------
 -- Functions dealing with names, variables and ids
 
 -----------------------------------------------------------------------------
 -- Functions dealing with names, variables and ids


@@ -182,7 +224,10 @@ dataconToVHDLExpr dc = AST.PrimLit lit
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId

-varToVHDLId = mkVHDLExtId . varToString
+varToVHDLId var = mkVHDLExtId $ (varToString var ++ varToStringUniq var ++ (show $ lowers $ varToStringUniq var))
+  where
+    lowers :: String -> Int
+    lowers xs = length [x | x <- xs, Char.isLower x]

 
 -- Creates a VHDL Name from a binder
 varToVHDLName ::
 
 -- Creates a VHDL Name from a binder
 varToVHDLName ::


@@ -233,7 +278,7 @@ mkVHDLExtId s =
   AST.unsafeVHDLExtId $ strip_invalid s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId
   AST.unsafeVHDLExtId $ strip_invalid s
   where 
     -- Allowed characters, taken from ForSyde's mkVHDLExtId

-    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-"

     strip_invalid = filter (`elem` allowed)
 
 -- Create a record field selector that selects the given label from the record
     strip_invalid = filter (`elem` allowed)
 
 -- Create a record field selector that selects the given label from the record


@@ -266,7 +311,8 @@ builtin_types =
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 -- Returns an error value, using the given message, when no type could be
 -- created. Returns Nothing when the type is valid, but empty.
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 -- Returns an error value, using the given message, when no type could be
 -- created. Returns Nothing when the type is valid, but empty.

-vhdl_ty :: String -> Type.Type -> TypeSession (Maybe AST.TypeMark)
+vhdl_ty :: (TypedThing t, Outputable.Outputable t) => 
+  String -> t -> TypeSession (Maybe AST.TypeMark)

 vhdl_ty msg ty = do
   tm_either <- vhdl_ty_either ty
   case tm_either of
 vhdl_ty msg ty = do
   tm_either <- vhdl_ty_either ty
   case tm_either of


@@ -275,8 +321,16 @@ vhdl_ty msg ty = do
 
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 -- Returns either an error message or the resulting type.
 
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
 -- Returns either an error message or the resulting type.

-vhdl_ty_either :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
-vhdl_ty_either ty = do
+vhdl_ty_either :: (TypedThing t, Outputable.Outputable t) => 
+  t -> TypeSession (Either String (Maybe AST.TypeMark))
+vhdl_ty_either tything =
+  case getType tything of
+    Nothing -> return $ Left $ "VHDLTools.vhdl_ty: Typed thing without a type: " ++ pprString tything
+    Just ty -> vhdl_ty_either' ty
+
+vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark))
+vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty
+                   | otherwise = do

   typemap <- getA tsTypes
   htype_either <- mkHType ty
   case htype_either of
   typemap <- getA tsTypes
   htype_either <- mkHType ty
   case htype_either of


@@ -365,7 +419,19 @@ mk_tycon_ty ty tycon args =
         (errors, _) -> return $ Left $
           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)
         (errors, _) -> return $ Left $
           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)

-    dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+    dcs -> do
+      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      case real_arg_tys of
+        [] -> do
+          let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs
+          let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+          let ty_def = AST.TDE $ AST.EnumTypeDef elems
+          let enumShow = mkEnumShow elems ty_id
+          modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, enumShow)
+          return $ Right $ Just (ty_id, Left ty_def)
+        xs -> return $ Left $
+          "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"

   where
     -- Create a subst that instantiates all types passed to the tycon
     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
   where
     -- Create a subst that instantiates all types passed to the tycon
     -- TODO: I'm not 100% sure that this is the right way to do this. It seems


@@ -423,9 +489,10 @@ mk_natural_ty ::
   -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
       -- ^ An error message or The typemark created.
 mk_natural_ty min_bound max_bound = do
   -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
       -- ^ An error message or The typemark created.
 mk_natural_ty min_bound max_bound = do

-  let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
-  let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
-  let ty_def = AST.SubtypeIn naturalTM (Just range)
+  let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound)))
+  let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]
+  let ty_def = AST.SubtypeIn unsignedTM (Just range)

   return (Right $ Just (ty_id, Right ty_def))
 
 mk_unsigned_ty ::
   return (Right $ Just (ty_id, Right ty_def))
 
 mk_unsigned_ty ::


@@ -436,8 +503,6 @@ mk_unsigned_ty ty = do
   let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)
   let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
   let ty_def = AST.SubtypeIn unsignedTM (Just range)

-  let unsignedshow = mkIntegerShow ty_id
-  modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)

   return (Right $ Just (ty_id, Right ty_def))
   
 mk_signed_ty ::
   return (Right $ Just (ty_id, Right ty_def))
   
 mk_signed_ty ::


@@ -448,8 +513,6 @@ mk_signed_ty ty = do
   let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
   let ty_def = AST.SubtypeIn signedTM (Just range)
   let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
   let ty_def = AST.SubtypeIn signedTM (Just range)

-  let signedshow = mkIntegerShow ty_id
-  modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)

   return (Right $ Just (ty_id, Right ty_def))
 
 -- Finds the field labels for VHDL type generated for the given Core type,
   return (Right $ Just (ty_id, Right ty_def))
 
 -- Finds the field labels for VHDL type generated for the given Core type,


@@ -517,7 +580,7 @@ mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type

-    [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
+    [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"

     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys


@@ -528,9 +591,16 @@ mkTyConHType tycon args =
           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
         -- There were errors in element types
         (errors, _) -> return $ Left $
           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
         -- There were errors in element types
         (errors, _) -> return $ Left $

-          "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+          "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"

           ++ (concat errors)
           ++ (concat errors)

-    dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+    dcs -> do
+      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      case real_arg_tys of
+        [] ->
+          return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
+        xs -> return $ Left $
+          "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"

   where
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
   where
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)


@@ -597,6 +667,17 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 

+mkEnumShow ::
+  [AST.VHDLId]
+  -> AST.TypeMark
+  -> AST.SubProgBody
+mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
+  where
+    enumPar    = AST.unsafeVHDLBasicId "enum"
+    showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
+    showExpr  = AST.ReturnSm (Just $
+                  AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
+

 mkVectorShow ::
   AST.TypeMark -- ^ elemtype
   -> AST.TypeMark -- ^ vectype
 mkVectorShow ::
   AST.TypeMark -- ^ elemtype
   -> AST.TypeMark -- ^ vectype


@@ -667,26 +748,19 @@ mkVectorShow elemTM vectorTM =
                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
                                AST.PrimLit "'>'" )
 
                                genExprFCall doShowId (AST.PrimName $ AST.NSimple vecPar) AST.:&:
                                AST.PrimLit "'>'" )
 

-mkIntegerShow ::
-  AST.TypeMark -- ^ The specific signed
-  -> AST.SubProgBody
-mkIntegerShow signedTM = AST.SubProgBody showSpec [] [showExpr]
-  where
-    signedPar = AST.unsafeVHDLBasicId "sint"
-    showSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
-    showExpr = AST.ReturnSm (Just $
-                AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
-                  (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
-      where
-        signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
-

 mkBuiltInShow :: [AST.SubProgBody]
 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]
 mkBuiltInShow :: [AST.SubProgBody]
 mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                 , AST.SubProgBody showBoolSpec [] [showBoolExpr]

+                , AST.SubProgBody showSingedSpec [] [showSignedExpr]
+                , AST.SubProgBody showUnsignedSpec [] [showUnsignedExpr]
+                -- , AST.SubProgBody showNaturalSpec [] [showNaturalExpr]

                 ]
   where
                 ]
   where

-    bitPar    = AST.unsafeVHDLBasicId "s"
-    boolPar    = AST.unsafeVHDLBasicId "b"
+    bitPar      = AST.unsafeVHDLBasicId "s"
+    boolPar     = AST.unsafeVHDLBasicId "b"
+    signedPar   = AST.unsafeVHDLBasicId "sint"
+    unsignedPar = AST.unsafeVHDLBasicId "uint"
+    -- naturalPar  = AST.unsafeVHDLBasicId "nat"

     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
     -- if s = '1' then return "'1'" else return "'0'"
     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")
     showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM
     -- if s = '1' then return "'1'" else return "'0'"
     showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'")


@@ -699,6 +773,23 @@ mkBuiltInShow = [ AST.SubProgBody showBitSpec [] [showBitExpr]
                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
                         []
                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])
                         [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")]
                         []
                         (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])

+    showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM
+    showSignedExpr =  AST.ReturnSm (Just $
+                        AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
+                        (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing )
+                      where
+                        signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ signedPar)
+    showUnsignedSpec =  AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM
+    showUnsignedExpr =  AST.ReturnSm (Just $
+                          AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) 
+                          (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )
+                        where
+                          unsignToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ unsignedPar)
+    -- showNaturalSpec = AST.Function showId [AST.IfaceVarDec naturalPar naturalTM] stringTM
+    -- showNaturalExpr = AST.ReturnSm (Just $
+    --                     AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId)
+    --                     (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [AST.PrimName $ AST.NSimple $ naturalPar]) Nothing )
+                      

   
 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
 genExprFCall fName args = 
   
 genExprFCall :: AST.VHDLId -> AST.Expr -> AST.Expr
 genExprFCall fName args = 


@@ -717,3 +808,8 @@ mkSigDec bndr = do
   case type_mark_maybe of
     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
     Nothing -> return Nothing
   case type_mark_maybe of
     Just type_mark -> return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
     Nothing -> return Nothing

+
+-- | Does the given thing have a non-empty type?
+hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => 
+  t -> TranslatorSession Bool
+hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdl_ty "hasNonEmptyType: Non representable type?" thing)