Let vhld_ty handle free tyvars gracefully.

[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 9c10afd93349c805eb676bf36f4ec41f03b77db7..39506f8b5fd571c3f40c63abdb1f7b7036922bfd 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,10 +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
 
 -- Local imports
 import CLasH.VHDL.VHDLTypes

+import CLasH.Translator.TranslatorTypes

 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Core.CoreTools

+import CLasH.Utils

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


@@ -86,28 +91,21 @@ mkAssocElems ::
   -> Entity                     -- ^ The entity to map against.
   -> [AST.AssocElem]            -- ^ The resulting port maps
 mkAssocElems args res entity =
   -> 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
 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
 
 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
 

--- | Create an VHDL port -> signal association
-mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
-mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName 
-                      (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
-

 -- | Create an aggregate signal
 mkAggregateSignal :: [AST.Expr] -> AST.Expr
 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
 -- | Create an aggregate signal
 mkAggregateSignal :: [AST.Expr] -> AST.Expr
 mkAggregateSignal x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)


@@ -186,7 +184,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 ::


@@ -262,15 +263,16 @@ mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 -- for a few builtin types.
 builtin_types = 
   Map.fromList [
 -- for a few builtin types.
 builtin_types = 
   Map.fromList [

-    ("Bit", std_logicTM),
-    ("Bool", booleanTM), -- TysWiredIn.boolTy
-    ("Dec", integerTM)
+    ("Bit", Just std_logicTM),
+    ("Bool", Just booleanTM), -- TysWiredIn.boolTy
+    ("Dec", Just integerTM)

   ]
 
 -- 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
   ]
 
 -- 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.
-vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
+-- created. Returns Nothing when the type is valid, but empty.
+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


@@ -279,9 +281,17 @@ 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 AST.TypeMark)
-vhdl_ty_either ty = do
-  typemap <- getA vsTypes
+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
     -- No errors
   htype_either <- mkHType ty
   case htype_either of
     -- No errors


@@ -291,19 +301,22 @@ vhdl_ty_either ty = do
             let name = Name.getOccString (TyCon.tyConName tycon)
             Map.lookup name builtin_types
       -- If not a builtin type, try the custom types
             let name = Name.getOccString (TyCon.tyConName tycon)
             Map.lookup name builtin_types
       -- If not a builtin type, try the custom types

-      let existing_ty = (fmap fst) $ Map.lookup htype typemap
+      let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap

       case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
         -- Found a type, return it
         Just t -> return (Right t)
         -- No type yet, try to construct it
         Nothing -> do
       case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
         -- Found a type, return it
         Just t -> return (Right t)
         -- No type yet, try to construct it
         Nothing -> do

-          newty_maybe <- (construct_vhdl_ty ty)
-          case newty_maybe of
-            Right (ty_id, ty_def) -> do
+          newty_either <- (construct_vhdl_ty ty)
+          case newty_either of
+            Right newty  -> do

               -- TODO: Check name uniqueness
               -- TODO: Check name uniqueness

-              modA vsTypes (Map.insert htype (ty_id, ty_def))
-              modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
-              return (Right ty_id)
+              modA tsTypes (Map.insert htype newty)
+              case newty of
+                Just (ty_id, ty_def) -> do
+                  modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+                  return (Right $ Just ty_id)
+                Nothing -> return $ Right Nothing

             Left err -> return $ Left $
               "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
               ++ err
             Left err -> return $ Left $
               "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
               ++ err


@@ -312,7 +325,9 @@ vhdl_ty_either ty = do
 
 -- Construct a new VHDL type for the given Haskell type. Returns an error
 -- message or the resulting typemark and typedef.
 
 -- Construct a new VHDL type for the given Haskell type. Returns an error
 -- message or the resulting typemark and typedef.

-construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty :: Type.Type -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))
+-- State types don't generate VHDL
+construct_vhdl_ty ty | isStateType ty = return $ Right Nothing

 construct_vhdl_ty ty = do
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
 construct_vhdl_ty ty = do
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do


@@ -329,7 +344,7 @@ construct_vhdl_ty ty = do
     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
 
 -- | Create VHDL type for a custom tycon
     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
 
 -- | Create VHDL type for a custom tycon

-mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty :: Type.Type -> TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))

 mk_tycon_ty ty tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
 mk_tycon_ty ty tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type


@@ -343,18 +358,23 @@ mk_tycon_ty ty tycon args =
       elem_tys_either <- mapM vhdl_ty_either real_arg_tys
       case Either.partitionEithers elem_tys_either of
         -- No errors in element types
       elem_tys_either <- mapM vhdl_ty_either real_arg_tys
       case Either.partitionEithers elem_tys_either of
         -- No errors in element types

-        ([], elem_tys) -> do
-          let elems = zipWith AST.ElementDec recordlabels elem_tys
-          -- For a single construct datatype, build a record with one field for
-          -- each argument.
-          -- TODO: Add argument type ids to this, to ensure uniqueness
-          -- TODO: Special handling for tuples?
-          let elem_names = concat $ map prettyShow elem_tys
-          let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
-          let ty_def = AST.TDR $ AST.RecordTypeDef elems
-          let tupshow = mkTupleShow elem_tys ty_id
-          modA vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
-          return $ Right (ty_id, Left ty_def)
+        ([], elem_tys') -> do
+          -- Throw away all empty members
+          case Maybe.catMaybes elem_tys' of
+            [] -> -- No non-empty members
+              return $ Right Nothing
+            elem_tys -> do
+              let elems = zipWith AST.ElementDec recordlabels elem_tys
+              -- For a single construct datatype, build a record with one field for
+              -- each argument.
+              -- TODO: Add argument type ids to this, to ensure uniqueness
+              -- TODO: Special handling for tuples?
+              let elem_names = concat $ map prettyShow elem_tys
+              let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
+              let ty_def = AST.TDR $ AST.RecordTypeDef elems
+              let tupshow = mkTupleShow elem_tys ty_id
+              modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, tupshow)
+              return $ Right $ Just (ty_id, Left ty_def)

         -- There were errors in element types
         (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"
         -- There were errors in element types
         (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"


@@ -372,12 +392,12 @@ mk_tycon_ty ty tycon args =
 -- | Create a VHDL vector type
 mk_vector_ty ::
   Type.Type -- ^ The Haskell type of the Vector
 -- | Create a VHDL vector type
 mk_vector_ty ::
   Type.Type -- ^ The Haskell type of the Vector

-  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+  -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))

       -- ^ An error message or The typemark created.
 
 mk_vector_ty ty = do
       -- ^ An error message or The typemark created.
 
 mk_vector_ty ty = do

-  types_map <- getA vsTypes
-  env <- getA vsHscEnv
+  types_map <- getA tsTypes
+  env <- getA tsHscEnv

   let (nvec_l, nvec_el) = Type.splitAppTy ty
   let (nvec, leng) = Type.splitAppTy nvec_l
   let vec_ty = Type.mkAppTy nvec nvec_el
   let (nvec_l, nvec_el) = Type.splitAppTy ty
   let (nvec, leng) = Type.splitAppTy nvec_l
   let vec_ty = Type.mkAppTy nvec nvec_el


@@ -386,23 +406,26 @@ mk_vector_ty ty = do
   el_ty_tm_either <- vhdl_ty_either el_ty
   case el_ty_tm_either of
     -- Could create element type
   el_ty_tm_either <- vhdl_ty_either el_ty
   case el_ty_tm_either of
     -- Could create element type

-    Right el_ty_tm -> do
+    Right (Just el_ty_tm) -> do

       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]

-      let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
+      let existing_elem_ty = (fmap $ fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map

       case existing_elem_ty of
       case existing_elem_ty of

-        Just t -> do
+        Just (Just t) -> do

           let ty_def = AST.SubtypeIn t (Just range)
           let ty_def = AST.SubtypeIn t (Just range)

-          return (Right (ty_id, Right ty_def))
+          return (Right $ Just (ty_id, Right ty_def))

         Nothing -> do
           let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
         Nothing -> do
           let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm

-          modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
-          modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])
+          modA tsTypes (Map.insert (StdType $ OrdType vec_ty) (Just (vec_id, (Left vec_def))))
+          modA tsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))])

           let vecShowFuns = mkVectorShow el_ty_tm vec_id
           let vecShowFuns = mkVectorShow el_ty_tm vec_id

-          mapM_ (\(id, subprog) -> modA vsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns
+          mapM_ (\(id, subprog) -> modA tsTypeFuns $ Map.insert (OrdType vec_ty, id) ((mkVHDLExtId id), subprog)) vecShowFuns

           let ty_def = AST.SubtypeIn vec_id (Just range)
           let ty_def = AST.SubtypeIn vec_id (Just range)

-          return (Right (ty_id, Right ty_def))
+          return (Right $ Just (ty_id, Right ty_def))
+    -- Empty element type? Empty vector type then. TODO: Does this make sense?
+    -- Probably needs changes in the builtin functions as well...
+    Right Nothing -> return $ Right Nothing

     -- Could not create element type
     Left err -> return $ Left $ 
       "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
     -- Could not create element type
     Left err -> return $ Left $ 
       "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"


@@ -411,37 +434,33 @@ mk_vector_ty ty = do
 mk_natural_ty ::
   Int -- ^ The minimum bound (> 0)
   -> Int -- ^ The maximum bound (> minimum bound)
 mk_natural_ty ::
   Int -- ^ The minimum bound (> 0)
   -> Int -- ^ The maximum bound (> minimum bound)

-  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+  -> 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)
       -- ^ 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)

-  return (Right (ty_id, Right ty_def))
+  return (Right $ Just (ty_id, Right ty_def))

 
 mk_unsigned_ty ::
   Type.Type -- ^ Haskell type of the unsigned integer
 
 mk_unsigned_ty ::
   Type.Type -- ^ Haskell type of the unsigned integer

-  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+  -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))

 mk_unsigned_ty ty = do
   size <- tfp_to_int (sized_word_len_ty ty)
   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)
 mk_unsigned_ty ty = do
   size <- tfp_to_int (sized_word_len_ty ty)
   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 vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, unsignedshow)
-  return (Right (ty_id, Right ty_def))
+  return (Right $ Just (ty_id, Right ty_def))

   
 mk_signed_ty ::
   Type.Type -- ^ Haskell type of the signed integer
   
 mk_signed_ty ::
   Type.Type -- ^ Haskell type of the signed integer

-  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+  -> TypeSession (Either String (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)))

 mk_signed_ty ty = do
   size <- tfp_to_int (sized_int_len_ty ty)
   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)
 mk_signed_ty ty = do
   size <- tfp_to_int (sized_int_len_ty ty)
   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 vsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, signedshow)
-  return (Right (ty_id, Right ty_def))
+  return (Right $ Just (ty_id, Right ty_def))

 
 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.
 
 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.


@@ -451,11 +470,12 @@ getFieldLabels ty = do
   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
   vhdl_ty error_msg ty
   -- Get the types map, lookup and unpack the VHDL TypeDef
   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
   vhdl_ty error_msg ty
   -- Get the types map, lookup and unpack the VHDL TypeDef

-  types <- getA vsTypes
+  types <- getA tsTypes

   -- Assume the type for which we want labels is really translatable
   Right htype <- mkHType ty
   case Map.lookup htype types of
   -- Assume the type for which we want labels is really translatable
   Right htype <- mkHType ty
   case Map.lookup htype types of

-    Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+    Just (Just (_, Left (AST.TDR (AST.RecordTypeDef elems)))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+    Just Nothing -> return [] -- The type is empty

     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
     
 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
     
 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem


@@ -536,7 +556,7 @@ isReprType ty = do
 
 tfp_to_int :: Type.Type -> TypeSession Int
 tfp_to_int ty = do
 
 tfp_to_int :: Type.Type -> TypeSession Int
 tfp_to_int ty = do

-  hscenv <- getA vsHscEnv
+  hscenv <- getA tsHscEnv

   let norm_ty = normalise_tfp_int hscenv ty
   case Type.splitTyConApp_maybe norm_ty of
     Just (tycon, args) -> do
   let norm_ty = normalise_tfp_int hscenv ty
   case Type.splitTyConApp_maybe norm_ty of
     Just (tycon, args) -> do


@@ -546,21 +566,21 @@ tfp_to_int ty = do
           len <- tfp_to_int' ty
           return len
         otherwise -> do
           len <- tfp_to_int' ty
           return len
         otherwise -> do

-          modA vsTfpInts (Map.insert (OrdType norm_ty) (-1))
+          modA tsTfpInts (Map.insert (OrdType norm_ty) (-1))

           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
     Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
 
 tfp_to_int' :: Type.Type -> TypeSession Int
 tfp_to_int' ty = do
           return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
     Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty))
 
 tfp_to_int' :: Type.Type -> TypeSession Int
 tfp_to_int' ty = do

-  lens <- getA vsTfpInts
-  hscenv <- getA vsHscEnv
+  lens <- getA tsTfpInts
+  hscenv <- getA tsHscEnv

   let norm_ty = normalise_tfp_int hscenv ty
   let existing_len = Map.lookup (OrdType norm_ty) lens
   case existing_len of
     Just len -> return len
     Nothing -> do
       let new_len = eval_tfp_int hscenv ty
   let norm_ty = normalise_tfp_int hscenv ty
   let existing_len = Map.lookup (OrdType norm_ty) lens
   case existing_len of
     Just len -> return len
     Nothing -> do
       let new_len = eval_tfp_int hscenv ty

-      modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+      modA tsTfpInts (Map.insert (OrdType norm_ty) (new_len))

       return new_len
       
 mkTupleShow :: 
       return new_len
       
 mkTupleShow :: 


@@ -574,13 +594,16 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
     showExpr  = AST.ReturnSm (Just $
                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
       where
     showExpr  = AST.ReturnSm (Just $
                   AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'")
       where

-        showMiddle = foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
-          map ((genExprFCall showId).
-                AST.PrimName .
-                AST.NSelected .
-                (AST.NSimple tupPar AST.:.:).
-                tupVHDLSuffix)
-              (take tupSize recordlabels)
+        showMiddle = if null elemTMs then
+            AST.PrimLit "''"
+          else
+            foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $
+              map ((genExprFCall showId).
+                    AST.PrimName .
+                    AST.NSelected .
+                    (AST.NSimple tupPar AST.:.:).
+                    tupVHDLSuffix)
+                  (take tupSize recordlabels)

     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 


@@ -654,26 +677,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'")


@@ -686,6 +702,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 = 


@@ -697,11 +730,15 @@ genExprPCall2 entid arg1 arg2 =
         AST.ProcCall (AST.NSimple entid) $
          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
 
         AST.ProcCall (AST.NSimple entid) $
          map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2]
 

-mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
-mkSigDec bndr =
-  if True then do --isInternalSigUse use || isStateSigUse use then do
-    let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
-    type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
-    return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
-  else
-    return Nothing
+mkSigDec :: CoreSyn.CoreBndr -> TranslatorSession (Maybe AST.SigDec)
+mkSigDec bndr = do
+  let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr 
+  type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType bndr)
+  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)