Great speed-up in type generation

Now just normalize tfp ints that are used as keys for the type map
Before these were translated to integers.

Save a map caches tfp ints, and their correspding integer literal

diff --git a/Adders.hs b/Adders.hs
index d9c1d26f61be295d5061654608616117c31c2ac2..f0987fdad484611e70e3f7495b44efaf5a0e668d 100644 (file)
--- a/Adders.hs
+++ b/Adders.hs
@@ -178,8 +178,8 @@ highordtest = \x ->
 
 xand a b = hwand a b
 
 
 xand a b = hwand a b
 

-functiontest :: SizedWord D8 -> SizedWord D8
-functiontest = \a -> let r = a + ((-1) :: SizedWord D8) in r
+functiontest :: TFVec D3 (TFVec D4 Bit) -> TFVec D12 Bit
+functiontest = \v -> let r = concat v in r

 
 xhwnot x = hwnot x
 
 
 xhwnot x = hwnot x
 

diff --git a/CoreTools.hs b/CoreTools.hs
index 443586b946f6b3ce904d090ed3d1a66aaae75d5f..eae4122deff7425570ea5b232d4545ede76d46ac 100644 (file)
--- a/CoreTools.hs
+++ b/CoreTools.hs
@@ -6,6 +6,7 @@ module CoreTools where
 
 --Standard modules
 import qualified Maybe
 
 --Standard modules
 import qualified Maybe

+import System.IO.Unsafe

 
 -- GHC API
 import qualified GHC
 
 -- GHC API
 import qualified GHC


@@ -14,6 +15,7 @@ import qualified TcType
 import qualified HsExpr
 import qualified HsTypes
 import qualified HsBinds
 import qualified HsExpr
 import qualified HsTypes
 import qualified HsBinds

+import qualified HscTypes

 import qualified RdrName
 import qualified Name
 import qualified OccName
 import qualified RdrName
 import qualified Name
 import qualified OccName


@@ -41,7 +43,6 @@ eval_tfp_int ty =
   unsafeRunGhc $ do
     -- Automatically import modules for any fully qualified identifiers
     setDynFlag DynFlags.Opt_ImplicitImportQualified
   unsafeRunGhc $ do
     -- Automatically import modules for any fully qualified identifiers
     setDynFlag DynFlags.Opt_ImplicitImportQualified

-    --setDynFlag DynFlags.Opt_D_dump_if_trace

 
     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
 
     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name


@@ -60,9 +61,15 @@ eval_tfp_int ty =
     core <- toCore modules expr
     execCore core 
 
     core <- toCore modules expr
     execCore core 
 

+normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
+normalise_tfp_int env ty =
+   unsafePerformIO $ do
+     nty <- normaliseType env ty
+     return nty
+

 -- | Get the width of a SizedWord type
 -- | Get the width of a SizedWord type

-sized_word_len :: Type.Type -> Int
-sized_word_len ty = eval_tfp_int (sized_word_len_ty ty)
+-- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
+-- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)

     
 sized_word_len_ty :: Type.Type -> Type.Type
 sized_word_len_ty ty = len
     
 sized_word_len_ty :: Type.Type -> Type.Type
 sized_word_len_ty ty = len


@@ -73,8 +80,8 @@ sized_word_len_ty ty = len
     [len]         = args
 
 -- | Get the width of a SizedInt type
     [len]         = args
 
 -- | Get the width of a SizedInt type

-sized_int_len :: Type.Type -> Int
-sized_int_len ty = eval_tfp_int (sized_int_len_ty ty)
+-- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
+-- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)

 
 sized_int_len_ty :: Type.Type -> Type.Type
 sized_int_len_ty ty = len
 
 sized_int_len_ty :: Type.Type -> Type.Type
 sized_int_len_ty ty = len


@@ -85,8 +92,8 @@ sized_int_len_ty ty = len
     [len]         = args
     
 -- | Get the upperbound of a RangedWord type
     [len]         = args
     
 -- | Get the upperbound of a RangedWord type

-ranged_word_bound :: Type.Type -> Int
-ranged_word_bound ty = eval_tfp_int (ranged_word_bound_ty ty)
+-- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
+-- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)

     
 ranged_word_bound_ty :: Type.Type -> Type.Type
 ranged_word_bound_ty ty = len
     
 ranged_word_bound_ty :: Type.Type -> Type.Type
 ranged_word_bound_ty ty = len


@@ -113,8 +120,8 @@ ranged_word_bound_ty ty = len
 --     execCore core 
 
 -- | Get the length of a FSVec type
 --     execCore core 
 
 -- | Get the length of a FSVec type

-tfvec_len :: Type.Type -> Int
-tfvec_len ty = eval_tfp_int (tfvec_len_ty ty)
+-- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
+-- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)

 
 tfvec_len_ty :: Type.Type -> Type.Type
 tfvec_len_ty ty = len
 
 tfvec_len_ty :: Type.Type -> Type.Type
 tfvec_len_ty ty = len

diff --git a/Generate.hs b/Generate.hs
index a72cc62d409205bdd6a36d2c11b64af46cef5330..e7a51983b1b9f7acb18e7a09a8a1a9eea8db5902 100644 (file)
--- a/Generate.hs
+++ b/Generate.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+

 module Generate where
 
 -- Standard modules
 module Generate where
 
 -- Standard modules


@@ -5,6 +7,8 @@ import qualified Control.Monad as Monad
 import qualified Data.Map as Map
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Data.Map as Map
 import qualified Maybe
 import qualified Data.Either as Either

+import qualified Control.Monad.Trans.State as State
+import qualified "transformers" Control.Monad.Identity as Identity

 import Data.Accessor
 import Data.Accessor.MonadState as MonadState
 import Debug.Trace
 import Data.Accessor
 import Data.Accessor.MonadState as MonadState
 import Debug.Trace


@@ -35,10 +39,11 @@ import Pretty
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be expressions.
 genExprArgs ::
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be expressions.
 genExprArgs ::

-  (dst -> func -> [AST.Expr] -> res)
+  TypeState
+  -> (dst -> func -> [AST.Expr] -> res)

   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)

-genExprArgs wrap dst func args = wrap dst func args'
-  where args' = map (either (varToVHDLExpr.exprToVar) id) args
+genExprArgs ty_state wrap dst func args = wrap dst func args'
+  where args' = map (either ((varToVHDLExpr ty_state).exprToVar) id) args

   
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be variables.
   
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be variables.


@@ -74,22 +79,22 @@ genExprRes wrap dst func args = do
 
 -- | Generate a binary operator application. The first argument should be a
 -- constructor from the AST.Expr type, e.g. AST.And.
 
 -- | Generate a binary operator application. The first argument should be a
 -- constructor from the AST.Expr type, e.g. AST.And.

-genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder 
-genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
+genOperator2 :: TypeState -> (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder 
+genOperator2 ty_state op = (genExprArgs ty_state) $ genExprRes (genOperator2' op)

 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
 
 -- | Generate a unary operator application
 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
 
 -- | Generate a unary operator application

-genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder 
-genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
+genOperator1 :: TypeState -> (AST.Expr -> AST.Expr) -> BuiltinBuilder 
+genOperator1 ty_state op = (genExprArgs ty_state) $ genExprRes (genOperator1' op)

 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genOperator1' op _ f [arg] = return $ op arg
 
 -- | Generate a unary operator application
 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genOperator1' op _ f [arg] = return $ op arg
 
 -- | Generate a unary operator application

-genNegation :: BuiltinBuilder 
-genNegation = genVarArgs $ genExprRes genNegation'
-genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
-genNegation' _ f [arg] = return $ op (varToVHDLExpr arg)
+genNegation :: TypeState -> BuiltinBuilder 
+genNegation ty_state = genVarArgs $ genExprRes (genNegation' ty_state)
+genNegation' :: TypeState -> dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
+genNegation' ty_state _ f [arg] = return $ op ((varToVHDLExpr ty_state) arg)

   where
     ty = Var.varType arg
     (tycon, args) = Type.splitTyConApp ty
   where
     ty = Var.varType arg
     (tycon, args) = Type.splitTyConApp ty


@@ -100,8 +105,8 @@ genNegation' _ f [arg] = return $ op (varToVHDLExpr arg)
 
 -- | Generate a function call from the destination binder, function name and a
 -- list of expressions (its arguments)
 
 -- | Generate a function call from the destination binder, function name and a
 -- list of expressions (its arguments)

-genFCall :: Bool -> BuiltinBuilder 
-genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
+genFCall :: TypeState -> Bool -> BuiltinBuilder 
+genFCall ty_state switch = (genExprArgs ty_state) $ genExprRes (genFCall' switch)

 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genFCall' switch (Left res) f args = do
   let fname = varToString f
 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genFCall' switch (Left res) f args = do
   let fname = varToString f


@@ -111,8 +116,8 @@ genFCall' switch (Left res) f args = do
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 

-genFromSizedWord :: BuiltinBuilder
-genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
+genFromSizedWord :: TypeState -> BuiltinBuilder
+genFromSizedWord ty_state = (genExprArgs ty_state) $ genExprRes genFromSizedWord'

 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genFromSizedWord' (Left res) f args = do
   let fname = varToString f
 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genFromSizedWord' (Left res) f args = do
   let fname = varToString f


@@ -125,90 +130,93 @@ genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cann
 genFromInteger :: BuiltinBuilder
 genFromInteger = genLitArgs $ genExprRes genFromInteger'
 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
 genFromInteger :: BuiltinBuilder
 genFromInteger = genLitArgs $ genExprRes genFromInteger'
 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr

-genFromInteger' (Left res) f lits = 
-  return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname)) 
+genFromInteger' (Left res) f lits = do {
+  ; let { ty = Var.varType res
+        ; (tycon, args) = Type.splitTyConApp ty
+        ; name = Name.getOccString (TyCon.tyConName tycon)
+        } ;
+  ; len <- case name of
+    "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
+    "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+  ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
+  ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname)) 

             [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
             [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]

-  where
-  ty = Var.varType res
-  (tycon, args) = Type.splitTyConApp ty
-  name = Name.getOccString (TyCon.tyConName tycon)
-  len = case name of
-    "SizedInt" -> sized_int_len ty
-    "SizedWord" -> sized_word_len ty
-  fname = case name of
-    "SizedInt" -> toSignedId
-    "SizedWord" -> toUnsignedId
+  }

 
 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
 
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder
 
 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
 
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder

-genMap (Left res) f [Left mapped_f, Left (Var arg)] =
+genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {

   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
   -- we must index it (which we couldn't if it was a VHDL Expr, since only
   -- VHDLNames can be indexed).
   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
   -- we must index it (which we couldn't if it was a VHDL Expr, since only
   -- VHDLNames can be indexed).

-  let
-    -- Setup the generate scheme
-    len         = (tfvec_len . Var.varType) res
-    -- TODO: Use something better than varToString
-    label       = mkVHDLExtId ("mapVector" ++ (varToString res))
-    n_id        = mkVHDLBasicId "n"
-    n_expr      = idToVHDLExpr n_id
-    range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
-    genScheme   = AST.ForGn n_id range
-
-    -- Create the content of the generate statement: Applying the mapped_f to
-    -- each of the elements in arg, storing to each element in res
-    resname     = mkIndexedName (varToVHDLName res) n_expr
-    argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
-  in do
-    let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
-    let valargs = get_val_args (Var.varType real_f) already_mapped_args
-    app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
+  -- Setup the generate scheme
+  ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+          -- TODO: Use something better than varToString
+  ; let { label       = mkVHDLExtId ("mapVector" ++ (varToString res))
+        ; n_id        = mkVHDLBasicId "n"
+        ; n_expr      = idToVHDLExpr n_id
+        ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+        ; genScheme   = AST.ForGn n_id range
+          -- Create the content of the generate statement: Applying the mapped_f to
+          -- each of the elements in arg, storing to each element in res
+        ; resname     = mkIndexedName (varToVHDLName res) n_expr
+        ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+        ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
+        ; valargs = get_val_args (Var.varType real_f) already_mapped_args
+        } ;
+  ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])

     -- Return the generate statement
     -- Return the generate statement

-    return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+  ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+  }

 
 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
     
 genZipWith :: BuiltinBuilder
 genZipWith = genVarArgs genZipWith'
 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 
 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
     
 genZipWith :: BuiltinBuilder
 genZipWith = genVarArgs genZipWith'
 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]

-genZipWith' (Left res) f args@[zipped_f, arg1, arg2] =
-  let
-    -- Setup the generate scheme
-    len         = (tfvec_len . Var.varType) res
-    -- TODO: Use something better than varToString
-    label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
-    n_id        = mkVHDLBasicId "n"
-    n_expr      = idToVHDLExpr n_id
-    range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
-    genScheme   = AST.ForGn n_id range
-
-    -- Create the content of the generate statement: Applying the zipped_f to
-    -- each of the elements in arg1 and arg2, storing to each element in res
-    resname     = mkIndexedName (varToVHDLName res) n_expr
-    argexpr1    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
-    argexpr2    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
-  in do
-    app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
+genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
+  -- Setup the generate scheme
+  ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+          -- TODO: Use something better than varToString
+  ; let { label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
+        ; n_id        = mkVHDLBasicId "n"
+        ; n_expr      = idToVHDLExpr n_id
+        ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+        ; genScheme   = AST.ForGn n_id range
+          -- Create the content of the generate statement: Applying the zipped_f to
+          -- each of the elements in arg1 and arg2, storing to each element in res
+        ; resname     = mkIndexedName (varToVHDLName res) n_expr
+        ; argexpr1    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+        ; argexpr2    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+        } ;
+  ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]

     -- Return the generate functions
     -- Return the generate functions

-    return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+  ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+  }

 
 

-genFoldl :: BuiltinBuilder
-genFoldl = genFold True
+genFoldl :: TypeState -> BuiltinBuilder
+genFoldl ty_state = genFold ty_state True

 
 

-genFoldr :: BuiltinBuilder
-genFoldr = genFold False
+genFoldr :: TypeState -> BuiltinBuilder
+genFoldr ty_state = genFold ty_state False

 
 

-genFold :: Bool -> BuiltinBuilder
-genFold left = genVarArgs (genFold' left)
-genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genFold :: TypeState -> Bool -> BuiltinBuilder
+genFold ty_state left = genVarArgs (genFold' ty_state left)
+genFold' :: TypeState -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]

 -- Special case for an empty input vector, just assign start to res
 -- Special case for an empty input vector, just assign start to res

-genFold' left (Left res) _ [_, start, vec] | len == 0 = return [mkUncondAssign (Left res) (varToVHDLExpr start)]
-    where len = (tfvec_len . Var.varType) vec
-genFold' left (Left res) f [folded_f, start, vec] = do
+genFold' ty_state left (Left res) _ [_, start, vec] | len == 0 = return [mkUncondAssign (Left res) ((varToVHDLExpr ty_state) start)]
+  where 
+    len = State.evalState (tfp_to_int $ (tfvec_len_ty . Var.varType) vec) ty_state
+    
+genFold' ty_state left (Left res) f [folded_f, start, vec] = do
+  -- The vector length
+  len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+  -- An expression for len-1
+  let len_min_expr = (AST.PrimLit $ show (len-1))

   -- evec is (TFVec n), so it still needs an element type
   let (nvec, _) = splitAppTy (Var.varType vec)
   -- Put the type of the start value in nvec, this will be the type of our
   -- evec is (TFVec n), so it still needs an element type
   let (nvec, _) = splitAppTy (Var.varType vec)
   -- Put the type of the start value in nvec, this will be the type of our


@@ -234,22 +242,19 @@ genFold' left (Left res) f [folded_f, start, vec] = do
   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
   return [AST.CSBSm block]
   where
   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
   return [AST.CSBSm block]
   where

-    -- The vector length
-    len         = (tfvec_len . Var.varType) vec

     -- An id for the counter
     n_id = mkVHDLBasicId "n"
     n_cur = idToVHDLExpr n_id
     -- An expression for previous n
     n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
                      else (n_cur AST.:+: (AST.PrimLit "1"))
     -- An id for the counter
     n_id = mkVHDLBasicId "n"
     n_cur = idToVHDLExpr n_id
     -- An expression for previous n
     n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
                      else (n_cur AST.:+: (AST.PrimLit "1"))

-    -- An expression for len-1
-    len_min_expr = (AST.PrimLit $ show (len-1))

     -- An id for the tmp result vector
     tmp_id = mkVHDLBasicId "tmp"
     tmp_name = AST.NSimple tmp_id
     -- Generate parts of the fold
     genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
     genFirstCell = do
     -- An id for the tmp result vector
     tmp_id = mkVHDLBasicId "tmp"
     tmp_name = AST.NSimple tmp_id
     -- Generate parts of the fold
     genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
     genFirstCell = do

+      len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec

       let cond_label = mkVHDLExtId "firstcell"
       -- if n == 0 or n == len-1
       let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
       let cond_label = mkVHDLExtId "firstcell"
       -- if n == 0 or n == len-1
       let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")


@@ -257,7 +262,7 @@ genFold' left (Left res) f [folded_f, start, vec] = do
       -- Output to tmp[current n]
       let resname = mkIndexedName tmp_name n_cur
       -- Input from start
       -- Output to tmp[current n]
       let resname = mkIndexedName tmp_name n_cur
       -- Input from start

-      let argexpr1 = varToVHDLExpr start
+      let argexpr1 = (varToVHDLExpr ty_state) start

       -- Input from vec[current n]
       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
       app_concsms <- genApplication (Right resname) folded_f  ( if left then
       -- Input from vec[current n]
       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
       app_concsms <- genApplication (Right resname) folded_f  ( if left then


@@ -269,6 +274,7 @@ genFold' left (Left res) f [folded_f, start, vec] = do
       return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
 
     genOtherCell = do
       return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
 
     genOtherCell = do

+      len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec

       let cond_label = mkVHDLExtId "othercell"
       -- if n > 0 or n < len-1
       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
       let cond_label = mkVHDLExtId "othercell"
       -- if n > 0 or n < len-1
       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")


@@ -291,55 +297,57 @@ genFold' left (Left res) f [folded_f, start, vec] = do
 genZip :: BuiltinBuilder
 genZip = genVarArgs genZip'
 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 genZip :: BuiltinBuilder
 genZip = genVarArgs genZip'
 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]

-genZip' (Left res) f args@[arg1, arg2] =
-  let
+genZip' (Left res) f args@[arg1, arg2] = do {

     -- Setup the generate scheme
     -- Setup the generate scheme

-    len             = (tfvec_len . Var.varType) res
-    -- TODO: Use something better than varToString
-    label           = mkVHDLExtId ("zipVector" ++ (varToString res))
-    n_id            = mkVHDLBasicId "n"
-    n_expr          = idToVHDLExpr n_id
-    range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
-    genScheme       = AST.ForGn n_id range
-    resname'        = mkIndexedName (varToVHDLName res) n_expr
-    argexpr1        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
-    argexpr2        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
-  in do
-    labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
-    let resnameA    = mkSelectedName resname' (labels!!0)
-    let resnameB    = mkSelectedName resname' (labels!!1)
-    let resA_assign = mkUncondAssign (Right resnameA) argexpr1
-    let resB_assign = mkUncondAssign (Right resnameB) argexpr2
+  ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+          -- TODO: Use something better than varToString
+  ; let { label           = mkVHDLExtId ("zipVector" ++ (varToString res))
+        ; n_id            = mkVHDLBasicId "n"
+        ; n_expr          = idToVHDLExpr n_id
+        ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+        ; genScheme       = AST.ForGn n_id range
+        ; resname'        = mkIndexedName (varToVHDLName res) n_expr
+        ; argexpr1        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+        ; argexpr2        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+        } ; 
+  ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
+  ; let { resnameA    = mkSelectedName resname' (labels!!0)
+        ; resnameB    = mkSelectedName resname' (labels!!1)
+        ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
+        ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
+        } ;

     -- Return the generate functions
     -- Return the generate functions

-    return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+  ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+  }

     
 -- | Generate a generate statement for the builtin function "unzip"
 genUnzip :: BuiltinBuilder
 genUnzip = genVarArgs genUnzip'
 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
     
 -- | Generate a generate statement for the builtin function "unzip"
 genUnzip :: BuiltinBuilder
 genUnzip = genVarArgs genUnzip'
 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]

-genUnzip' (Left res) f args@[arg] =
-  let
+genUnzip' (Left res) f args@[arg] = do {

     -- Setup the generate scheme
     -- Setup the generate scheme

-    len             = (tfvec_len . Var.varType) arg
+  ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg

     -- TODO: Use something better than varToString
     -- TODO: Use something better than varToString

-    label           = mkVHDLExtId ("unzipVector" ++ (varToString res))
-    n_id            = mkVHDLBasicId "n"
-    n_expr          = idToVHDLExpr n_id
-    range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
-    genScheme       = AST.ForGn n_id range
-    resname'        = varToVHDLName res
-    argexpr'        = mkIndexedName (varToVHDLName arg) n_expr
-  in do
-    reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
-    arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
-    let resnameA    = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
-    let resnameB    = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
-    let argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
-    let argexprB    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
-    let resA_assign = mkUncondAssign (Right resnameA) argexprA
-    let resB_assign = mkUncondAssign (Right resnameB) argexprB
+  ; let { label           = mkVHDLExtId ("unzipVector" ++ (varToString res))
+        ; n_id            = mkVHDLBasicId "n"
+        ; n_expr          = idToVHDLExpr n_id
+        ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+        ; genScheme       = AST.ForGn n_id range
+        ; resname'        = varToVHDLName res
+        ; argexpr'        = mkIndexedName (varToVHDLName arg) n_expr
+        } ;
+  ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
+  ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
+  ; let { resnameA    = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
+        ; resnameB    = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
+        ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
+        ; argexprB    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
+        ; resA_assign = mkUncondAssign (Right resnameA) argexprA
+        ; resB_assign = mkUncondAssign (Right resnameB) argexprB
+        } ;

     -- Return the generate functions
     -- Return the generate functions

-    return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+  ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+  }

 
 genCopy :: BuiltinBuilder 
 genCopy = genVarArgs genCopy'
 
 genCopy :: BuiltinBuilder 
 genCopy = genVarArgs genCopy'


@@ -355,51 +363,55 @@ genCopy' (Left res) f args@[arg] =
 genConcat :: BuiltinBuilder
 genConcat = genVarArgs genConcat'
 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 genConcat :: BuiltinBuilder
 genConcat = genVarArgs genConcat'
 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]

-genConcat' (Left res) f args@[arg] =
-  let
+genConcat' (Left res) f args@[arg] = do {

     -- Setup the generate scheme
     -- Setup the generate scheme

-    len1        = (tfvec_len . Var.varType) arg
-    (_, nvec)   = splitAppTy (Var.varType arg)
-    len2        = tfvec_len nvec
-    -- TODO: Use something better than varToString
-    label       = mkVHDLExtId ("concatVector" ++ (varToString res))
-    n_id        = mkVHDLBasicId "n"
-    n_expr      = idToVHDLExpr n_id
-    fromRange   = n_expr AST.:*: (AST.PrimLit $ show len2)
-    genScheme   = AST.ForGn n_id range
-    -- Create the content of the generate statement: Applying the mapped_f to
-    -- each of the elements in arg, storing to each element in res
-    toRange     = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
-    range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
-    resname     = vecSlice fromRange toRange
-    argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
-    out_assign  = mkUncondAssign (Right resname) argexpr
-  in
+  ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+  ; let (_, nvec) = splitAppTy (Var.varType arg)
+  ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
+          -- TODO: Use something better than varToString
+  ; let { label       = mkVHDLExtId ("concatVector" ++ (varToString res))
+        ; n_id        = mkVHDLBasicId "n"
+        ; n_expr      = idToVHDLExpr n_id
+        ; fromRange   = n_expr AST.:*: (AST.PrimLit $ show len2)
+        ; genScheme   = AST.ForGn n_id range
+          -- Create the content of the generate statement: Applying the mapped_f to
+          -- each of the elements in arg, storing to each element in res
+        ; toRange     = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
+        ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
+        ; resname     = vecSlice fromRange toRange
+        ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+        ; out_assign  = mkUncondAssign (Right resname) argexpr
+        } ;

     -- Return the generate statement
     -- Return the generate statement

-    return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+  ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+  }

   where
     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
                             (AST.ToRange init last))
 
   where
     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
                             (AST.ToRange init last))
 

-genIteraten :: BuiltinBuilder
-genIteraten dst f args = genIterate dst f (tail args)
+genIteraten :: TypeState -> BuiltinBuilder
+genIteraten ty_state dst f args = genIterate ty_state dst f (tail args)

 
 

-genIterate :: BuiltinBuilder
-genIterate = genIterateOrGenerate True
+genIterate :: TypeState -> BuiltinBuilder
+genIterate ty_state = genIterateOrGenerate ty_state True

 
 

-genGeneraten :: BuiltinBuilder
-genGeneraten dst f args = genGenerate dst f (tail args)
+genGeneraten :: TypeState -> BuiltinBuilder
+genGeneraten ty_state dst f args = genGenerate ty_state dst f (tail args)

 
 

-genGenerate :: BuiltinBuilder
-genGenerate = genIterateOrGenerate False
+genGenerate :: TypeState -> BuiltinBuilder
+genGenerate ty_state = genIterateOrGenerate ty_state False

 
 

-genIterateOrGenerate :: Bool -> BuiltinBuilder
-genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
-genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genIterateOrGenerate :: TypeState -> Bool -> BuiltinBuilder
+genIterateOrGenerate ty_state iter = genVarArgs (genIterateOrGenerate' ty_state iter)
+genIterateOrGenerate' :: TypeState -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]

 -- Special case for an empty input vector, just assign start to res
 -- Special case for an empty input vector, just assign start to res

-genIterateOrGenerate' iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
-    where len = (tfvec_len . Var.varType) res
-genIterateOrGenerate' iter (Left res) f [app_f, start] = do
+genIterateOrGenerate' ty_state iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
+    where len = State.evalState (tfp_to_int $ (tfvec_len_ty . Var.varType) res) ty_state
+genIterateOrGenerate' ty_state iter (Left res) f [app_f, start] = do
+  -- The vector length
+  len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+  -- An expression for len-1
+  let len_min_expr = (AST.PrimLit $ show (len-1))

   -- -- evec is (TFVec n), so it still needs an element type
   -- let (nvec, _) = splitAppTy (Var.varType vec)
   -- -- Put the type of the start value in nvec, this will be the type of our
   -- -- evec is (TFVec n), so it still needs an element type
   -- let (nvec, _) = splitAppTy (Var.varType vec)
   -- -- Put the type of the start value in nvec, this will be the type of our


@@ -422,15 +434,11 @@ genIterateOrGenerate' iter (Left res) f [app_f, start] = do
   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
   return [AST.CSBSm block]
   where
   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
   return [AST.CSBSm block]
   where

-    -- The vector length
-    len = (tfvec_len . Var.varType) res

     -- An id for the counter
     n_id = mkVHDLBasicId "n"
     n_cur = idToVHDLExpr n_id
     -- An expression for previous n
     n_prev = n_cur AST.:-: (AST.PrimLit "1")
     -- An id for the counter
     n_id = mkVHDLBasicId "n"
     n_cur = idToVHDLExpr n_id
     -- An expression for previous n
     n_prev = n_cur AST.:-: (AST.PrimLit "1")

-    -- An expression for len-1
-    len_min_expr = (AST.PrimLit $ show (len-1))

     -- An id for the tmp result vector
     tmp_id = mkVHDLBasicId "tmp"
     tmp_name = AST.NSimple tmp_id
     -- An id for the tmp result vector
     tmp_id = mkVHDLBasicId "tmp"
     tmp_name = AST.NSimple tmp_id


@@ -443,7 +451,7 @@ genIterateOrGenerate' iter (Left res) f [app_f, start] = do
       -- Output to tmp[current n]
       let resname = mkIndexedName tmp_name n_cur
       -- Input from start
       -- Output to tmp[current n]
       let resname = mkIndexedName tmp_name n_cur
       -- Input from start

-      let argexpr = varToVHDLExpr start
+      let argexpr = (varToVHDLExpr ty_state) start

       let startassign = mkUncondAssign (Right resname) argexpr
       app_concsms <- genApplication (Right resname) app_f  [Right argexpr]
       -- Return the conditional generate part
       let startassign = mkUncondAssign (Right resname) argexpr
       app_concsms <- genApplication (Right resname) app_f  [Right argexpr]
       -- Return the conditional generate part


@@ -474,14 +482,15 @@ genApplication ::
   -> CoreSyn.CoreBndr -- ^ The function to apply
   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
   -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
   -> CoreSyn.CoreBndr -- ^ The function to apply
   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
   -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements

-genApplication dst f args =
+genApplication dst f args = do
+  ty_state <- getA vsType

   case Var.globalIdVarDetails f of
     IdInfo.DataConWorkId dc -> case dst of
       -- It's a datacon. Create a record from its arguments.
       Left bndr -> do
         -- We have the bndr, so we can get at the type
         labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
   case Var.globalIdVarDetails f of
     IdInfo.DataConWorkId dc -> case dst of
       -- It's a datacon. Create a record from its arguments.
       Left bndr -> do
         -- We have the bndr, so we can get at the type
         labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)

-        return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args
+        return $ zipWith mkassign labels $ map (either (exprToVHDLExpr ty_state) id) args

         where
           mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
           mkassign label arg =
         where
           mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
           mkassign label arg =


@@ -494,7 +503,7 @@ genApplication dst f args =
       -- the associated builder if there is any and the argument count matches
       -- (this should always be the case if it typechecks, but just to be
       -- sure...).
       -- the associated builder if there is any and the argument count matches
       -- (this should always be the case if it typechecks, but just to be
       -- sure...).

-      case (Map.lookup (varToString f) globalNameTable) of
+      case (Map.lookup (varToString f) (globalNameTable ty_state)) of

         Just (arg_count, builder) ->
           if length args == arg_count then
             builder dst f args
         Just (arg_count, builder) ->
           if length args == arg_count then
             builder dst f args


@@ -513,13 +522,13 @@ genApplication dst f args =
         -- TODO: Using show here isn't really pretty, but we'll need some
         -- unique-ish value...
         label = "comp_ins_" ++ (either show prettyShow) dst
         -- TODO: Using show here isn't really pretty, but we'll need some
         -- unique-ish value...
         label = "comp_ins_" ++ (either show prettyShow) dst

-        portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature
+        portmaps = mkAssocElems (map (either (exprToVHDLExpr ty_state) id) args) ((either varToVHDLName id) dst) signature

         in
           return [mkComponentInst label entity_id portmaps]
     IdInfo.ClassOpId cls -> do
       -- FIXME: Not looking for what instance this class op is called for
       -- Is quite stupid of course.
         in
           return [mkComponentInst label entity_id portmaps]
     IdInfo.ClassOpId cls -> do
       -- FIXME: Not looking for what instance this class op is called for
       -- Is quite stupid of course.

-      case (Map.lookup (varToString f) globalNameTable) of
+      case (Map.lookup (varToString f) (globalNameTable ty_state)) of

         Just (arg_count, builder) ->
           if length args == arg_count then
             builder dst f args
         Just (arg_count, builder) ->
           if length args == arg_count then
             builder dst f args


@@ -942,50 +951,50 @@ genUnconsVectorFuns elemTM vectorTM  =
 
 -- | The builtin functions we support. Maps a name to an argument count and a
 -- builder function.
 
 -- | The builtin functions we support. Maps a name to an argument count and a
 -- builder function.

-globalNameTable :: NameTable
-globalNameTable = Map.fromList
-  [ (exId             , (2, genFCall False          ) )
-  , (replaceId        , (3, genFCall False          ) )
-  , (headId           , (1, genFCall True           ) )
-  , (lastId           , (1, genFCall True           ) )
-  , (tailId           , (1, genFCall False          ) )
-  , (initId           , (1, genFCall False          ) )
-  , (takeId           , (2, genFCall False          ) )
-  , (dropId           , (2, genFCall False          ) )
-  , (selId            , (4, genFCall False          ) )
-  , (plusgtId         , (2, genFCall False          ) )
-  , (ltplusId         , (2, genFCall False          ) )
-  , (plusplusId       , (2, genFCall False          ) )
-  , (mapId            , (2, genMap                  ) )
-  , (zipWithId        , (3, genZipWith              ) )
-  , (foldlId          , (3, genFoldl                ) )
-  , (foldrId          , (3, genFoldr                ) )
-  , (zipId            , (2, genZip                  ) )
-  , (unzipId          , (1, genUnzip                ) )
-  , (shiftlId         , (2, genFCall False          ) )
-  , (shiftrId         , (2, genFCall False          ) )
-  , (rotlId           , (1, genFCall False          ) )
-  , (rotrId           , (1, genFCall False          ) )
-  , (concatId         , (1, genConcat               ) )
-  , (reverseId        , (1, genFCall False          ) )
-  , (iteratenId       , (3, genIteraten             ) )
-  , (iterateId        , (2, genIterate              ) )
-  , (generatenId      , (3, genGeneraten            ) )
-  , (generateId       , (2, genGenerate             ) )
-  , (emptyId          , (0, genFCall False          ) )
-  , (singletonId      , (1, genFCall False          ) )
-  , (copynId          , (2, genFCall False          ) )
-  , (copyId           , (1, genCopy                 ) )
-  , (lengthTId        , (1, genFCall False          ) )
-  , (nullId           , (1, genFCall False          ) )
-  , (hwxorId          , (2, genOperator2 AST.Xor    ) )
-  , (hwandId          , (2, genOperator2 AST.And    ) )
-  , (hworId           , (2, genOperator2 AST.Or     ) )
-  , (hwnotId          , (1, genOperator1 AST.Not    ) )
-  , (plusId           , (2, genOperator2 (AST.:+:)  ) )
-  , (timesId          , (2, genOperator2 (AST.:*:)  ) )
-  , (negateId         , (1, genNegation             ) )
-  , (minusId          , (2, genOperator2 (AST.:-:)  ) )
-  , (fromSizedWordId  , (1, genFromSizedWord        ) )
-  , (fromIntegerId    , (1, genFromInteger          ) )
+globalNameTable :: TypeState -> NameTable
+globalNameTable ty_state = Map.fromList
+  [ (exId             , (2, genFCall ty_state False         ) )
+  , (replaceId        , (3, genFCall ty_state False         ) )
+  , (headId           , (1, genFCall ty_state True          ) )
+  , (lastId           , (1, genFCall ty_state True          ) )
+  , (tailId           , (1, genFCall ty_state False         ) )
+  , (initId           , (1, genFCall ty_state False         ) )
+  , (takeId           , (2, genFCall ty_state False         ) )
+  , (dropId           , (2, genFCall ty_state False         ) )
+  , (selId            , (4, genFCall ty_state False         ) )
+  , (plusgtId         , (2, genFCall ty_state False         ) )
+  , (ltplusId         , (2, genFCall ty_state False         ) )
+  , (plusplusId       , (2, genFCall ty_state False         ) )
+  , (mapId            , (2, genMap                          ) )
+  , (zipWithId        , (3, genZipWith                      ) )
+  , (foldlId          , (3, genFoldl ty_state               ) )
+  , (foldrId          , (3, genFoldr ty_state               ) )
+  , (zipId            , (2, genZip                          ) )
+  , (unzipId          , (1, genUnzip                        ) )
+  , (shiftlId         , (2, genFCall ty_state False         ) )
+  , (shiftrId         , (2, genFCall ty_state False         ) )
+  , (rotlId           , (1, genFCall ty_state False         ) )
+  , (rotrId           , (1, genFCall ty_state False         ) )
+  , (concatId         , (1, genConcat                       ) )
+  , (reverseId        , (1, genFCall ty_state False         ) )
+  , (iteratenId       , (3, genIteraten ty_state            ) )
+  , (iterateId        , (2, genIterate ty_state             ) )
+  , (generatenId      , (3, genGeneraten ty_state           ) )
+  , (generateId       , (2, genGenerate ty_state            ) )
+  , (emptyId          , (0, genFCall ty_state False         ) )
+  , (singletonId      , (1, genFCall ty_state False         ) )
+  , (copynId          , (2, genFCall ty_state False         ) )
+  , (copyId           , (1, genCopy                         ) )
+  , (lengthTId        , (1, genFCall ty_state False         ) )
+  , (nullId           , (1, genFCall ty_state False         ) )
+  , (hwxorId          , (2, genOperator2 ty_state AST.Xor   ) )
+  , (hwandId          , (2, genOperator2 ty_state AST.And   ) )
+  , (hworId           , (2, genOperator2 ty_state AST.Or    ) )
+  , (hwnotId          , (1, genOperator1 ty_state AST.Not   ) )
+  , (plusId           , (2, genOperator2 ty_state (AST.:+:) ) )
+  , (timesId          , (2, genOperator2 ty_state (AST.:*:) ) )
+  , (negateId         , (1, genNegation ty_state            ) )
+  , (minusId          , (2, genOperator2 ty_state (AST.:-:) ) )
+  , (fromSizedWordId  , (1, genFromSizedWord ty_state       ) )
+  , (fromIntegerId    , (1, genFromInteger                  ) )

   ]
   ]

diff --git a/HsTools.hs b/HsTools.hs
index 0f3e463040a02777dbb068cba06c4769efc9eedd..22cd57f06de9d90350cb2c39e67b90b254ba058d 100644 (file)
--- a/HsTools.hs
+++ b/HsTools.hs
@@ -3,7 +3,7 @@ module HsTools where
 
 -- Standard modules
 import qualified Unsafe.Coerce
 
 -- Standard modules
 import qualified Unsafe.Coerce

-
+import qualified Maybe

 
 -- GHC API
 import qualified GHC
 
 -- GHC API
 import qualified GHC


@@ -31,6 +31,7 @@ import qualified RnEnv
 import qualified TcExpr
 import qualified TcEnv
 import qualified TcSimplify
 import qualified TcExpr
 import qualified TcEnv
 import qualified TcSimplify

+import qualified TcTyFuns

 import qualified Desugar
 import qualified InstEnv
 import qualified FamInstEnv
 import qualified Desugar
 import qualified InstEnv
 import qualified FamInstEnv


@@ -123,6 +124,20 @@ mkId rdr_name = do
         TcEnv.tcLookupId name 
   return id
 
         TcEnv.tcLookupId name 
   return id
 

+normaliseType ::
+  HscTypes.HscEnv
+  -> Type.Type
+  -> IO Type.Type
+normaliseType env ty = do
+   (err, nty) <- MonadUtils.liftIO $
+     -- Initialize the typechecker monad
+     TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
+       -- Normalize the type
+       (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
+       return nty
+   let normalized_ty = Maybe.fromJust nty
+   return normalized_ty
+

 -- | Translate a core Type to an HsType. Far from complete so far.
 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
 --  Translate TyConApps
 -- | Translate a core Type to an HsType. Far from complete so far.
 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
 --  Translate TyConApps

diff --git a/Normalize.hs b/Normalize.hs
index a299fd3673acc2d6f50788098aa6ae8896296b01..fe544ede09973302e85921b7975a3616e0d1cdc4 100644 (file)
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -29,11 +29,13 @@ import qualified NameSet
 import qualified CoreFVs
 import qualified CoreUtils
 import qualified MkCore
 import qualified CoreFVs
 import qualified CoreUtils
 import qualified MkCore

+import qualified HscTypes

 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import NormalizeTypes
 import NormalizeTools
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import NormalizeTypes
 import NormalizeTools

+import VHDLTypes

 import CoreTools
 import Pretty
 
 import CoreTools
 import Pretty
 


@@ -453,14 +455,15 @@ funextracttop = everywhere ("funextract", funextract)
 transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
 
 -- Turns the given bind into VHDL
 transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
 
 -- Turns the given bind into VHDL

-normalizeModule :: 
-  UniqSupply.UniqSupply -- ^ A UniqSupply we can use
+normalizeModule ::
+  HscTypes.HscEnv
+  -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use

   -> [(CoreBndr, CoreExpr)]  -- ^ All bindings we know (i.e., in the current module)
   -> [CoreBndr]  -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
   -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful
   -> [(CoreBndr, CoreExpr)]  -- ^ All bindings we know (i.e., in the current module)
   -> [CoreBndr]  -- ^ The bindings to generate VHDL for (i.e., the top level bindings)
   -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful

-  -> [(CoreBndr, CoreExpr)] -- ^ The resulting VHDL
+  -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL

 
 

-normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession uniqsupply $ do
+normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do

   -- Put all the bindings in this module in the tsBindings map
   putA tsBindings (Map.fromList bindings)
   -- (Recursively) normalize each of the requested bindings
   -- Put all the bindings in this module in the tsBindings map
   putA tsBindings (Map.fromList bindings)
   -- (Recursively) normalize each of the requested bindings


@@ -469,8 +472,9 @@ normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession
   bindings_map <- getA tsBindings
   let bindings = Map.assocs bindings_map
   normalized_bindings <- getA tsNormalized
   bindings_map <- getA tsBindings
   let bindings = Map.assocs bindings_map
   normalized_bindings <- getA tsNormalized

+  typestate <- getA tsType

   -- But return only the normalized bindings
   -- But return only the normalized bindings

-  return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings
+  return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate)

 
 normalizeBind :: CoreBndr -> TransformSession ()
 normalizeBind bndr =
 
 normalizeBind :: CoreBndr -> TransformSession ()
 normalizeBind bndr =

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index 85fae47e8f66a19865f281ee25e642d9dca1f16f..0508b38162aab5381bf025e62b6679f8f901573a 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -30,11 +30,13 @@ import qualified IdInfo
 import qualified CoreUtils
 import qualified CoreSubst
 import qualified VarSet
 import qualified CoreUtils
 import qualified CoreSubst
 import qualified VarSet

+import qualified HscTypes

 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import NormalizeTypes
 import Pretty
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import NormalizeTypes
 import Pretty

+import VHDLTypes

 import qualified VHDLTools
 
 -- Create a new internal var with the given name and type. A Unique is
 import qualified VHDLTools
 
 -- Create a new internal var with the given name and type. A Unique is


@@ -246,8 +248,11 @@ substitute ((b, e):subss) expr = substitute subss' expr'
 
 -- Run a given TransformSession. Used mostly to setup the right calls and
 -- an initial state.
 
 -- Run a given TransformSession. Used mostly to setup the right calls and
 -- an initial state.

-runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a
-runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply)
+runTransformSession :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a
+runTransformSession env uniqSupply session = State.evalState session emptyTransformState
+  where
+    emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env
+    emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState

 
 -- Is the given expression representable at runtime, based on the type?
 isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool
 
 -- Is the given expression representable at runtime, based on the type?
 isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool

diff --git a/NormalizeTypes.hs b/NormalizeTypes.hs
index 89ed53d41746d871924bf56ba02787d7e475b961..56cba91a411666a078e0eed852ffe5c084fea0f9 100644 (file)
--- a/NormalizeTypes.hs
+++ b/NormalizeTypes.hs
@@ -28,8 +28,6 @@ data TransformState = TransformState {
   , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized
   , tsType_ :: TypeState
 }
   , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized
   , tsType_ :: TypeState
 }

--- Create an (almost) empty TransformState, containing just a UniqSupply.
-emptyTransformState uniqSupply = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState

 
 $( Data.Accessor.Template.deriveAccessors ''TransformState )
 
 
 $( Data.Accessor.Template.deriveAccessors ''TransformState )
 

diff --git a/Translator.hs b/Translator.hs
index 85f790a6a979baac92c54a632f4798c86f2a8dfb..feb712ba7dbf3bd96c9a652e0ec6f976f54fb20f 100644 (file)
--- a/Translator.hs
+++ b/Translator.hs
@@ -48,17 +48,17 @@ import TranslatorTypes
 import HsValueMap
 import Pretty
 import Normalize
 import HsValueMap
 import Pretty
 import Normalize

-import Flatten
-import FlattenTypes
+-- import Flatten
+-- import FlattenTypes

 import VHDLTypes
 import qualified VHDL
 
 makeVHDL :: String -> String -> Bool -> IO ()
 makeVHDL filename name stateful = do
   -- Load the module
 import VHDLTypes
 import qualified VHDL
 
 makeVHDL :: String -> String -> Bool -> IO ()
 makeVHDL filename name stateful = do
   -- Load the module

-  core <- loadModule filename
+  (core, env) <- loadModule filename

   -- Translate to VHDL
   -- Translate to VHDL

-  vhdl <- moduleToVHDL core [(name, stateful)]
+  vhdl <- moduleToVHDL env core [(name, stateful)]

   -- Write VHDL to file
   let dir = "./vhdl/" ++ name ++ "/"
   prepareDir dir
   -- Write VHDL to file
   let dir = "./vhdl/" ++ name ++ "/"
   prepareDir dir


@@ -67,7 +67,7 @@ makeVHDL filename name stateful = do
 
 listBindings :: String -> IO [()]
 listBindings filename = do
 
 listBindings :: String -> IO [()]
 listBindings filename = do

-  core <- loadModule filename
+  (core, env) <- loadModule filename

   let binds = CoreSyn.flattenBinds $ cm_binds core
   mapM (listBinding) binds
 
   let binds = CoreSyn.flattenBinds $ cm_binds core
   mapM (listBinding) binds
 


@@ -86,7 +86,7 @@ listBinding (b, e) = do
 -- | Show the core structure of the given binds in the given file.
 listBind :: String -> String -> IO ()
 listBind filename name = do
 -- | Show the core structure of the given binds in the given file.
 listBind :: String -> String -> IO ()
 listBind filename name = do

-  core <- loadModule filename
+  (core, env) <- loadModule filename

   let [(b, expr)] = findBinds core [name]
   putStr "\n"
   putStr $ prettyShow expr
   let [(b, expr)] = findBinds core [name]
   putStr "\n"
   putStr $ prettyShow expr


@@ -99,8 +99,8 @@ listBind filename name = do
 -- | Translate the binds with the given names from the given core module to
 --   VHDL. The Bool in the tuple makes the function stateful (True) or
 --   stateless (False).
 -- | Translate the binds with the given names from the given core module to
 --   VHDL. The Bool in the tuple makes the function stateful (True) or
 --   stateless (False).

-moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL core list = do
+moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL env core list = do

   let (names, statefuls) = unzip list
   let binds = map fst $ findBinds core names
   -- Generate a UniqSupply
   let (names, statefuls) = unzip list
   let binds = map fst $ findBinds core names
   -- Generate a UniqSupply


@@ -111,8 +111,8 @@ moduleToVHDL core list = do
   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
   -- Turn bind into VHDL
   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
   -- Turn bind into VHDL
   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)

-  let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls
-  let vhdl = VHDL.createDesignFiles normalized_bindings
+  let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
+  let vhdl = VHDL.createDesignFiles typestate normalized_bindings

   mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
   mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl


@@ -143,7 +143,7 @@ writeVHDL dir (name, vhdl) = do
   ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
 
 -- | Loads the given file and turns it into a core module.
   ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
 
 -- | Loads the given file and turns it into a core module.

-loadModule :: String -> IO HscTypes.CoreModule
+loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)

 loadModule filename =
   defaultErrorHandler defaultDynFlags $ do
     runGhc (Just libdir) $ do
 loadModule filename =
   defaultErrorHandler defaultDynFlags $ do
     runGhc (Just libdir) $ do


@@ -156,7 +156,8 @@ loadModule filename =
       --load LoadAllTargets
       --core <- GHC.compileToCoreSimplified "Adders.hs"
       core <- GHC.compileToCoreModule filename
       --load LoadAllTargets
       --core <- GHC.compileToCoreSimplified "Adders.hs"
       core <- GHC.compileToCoreModule filename

-      return core
+      env <- GHC.getSession
+      return (core, env)

 
 -- | Extracts the named binds from the given module.
 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
 
 -- | Extracts the named binds from the given module.
 findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]


@@ -173,200 +174,200 @@ findBind binds lookfor =
 -- | Flattens the given bind into the given signature and adds it to the
 --   session. Then (recursively) finds any functions it uses and does the same
 --   with them.
 -- | Flattens the given bind into the given signature and adds it to the
 --   session. Then (recursively) finds any functions it uses and does the same
 --   with them.

-flattenBind ::
-  HsFunction                         -- The signature to flatten into
-  -> (CoreBndr, CoreExpr)            -- The bind to flatten
-  -> TranslatorState ()
-
-flattenBind hsfunc bind@(var, expr) = do
-  -- Flatten the function
-  let flatfunc = flattenFunction hsfunc bind
-  -- Propagate state variables
-  let flatfunc' = propagateState hsfunc flatfunc
-  -- Store the flat function in the session
-  modA tsFlatFuncs (Map.insert hsfunc flatfunc')
-  -- Flatten any functions used
-  let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
-  mapM_ resolvFunc used_hsfuncs
+-- flattenBind ::
+--   HsFunction                         -- The signature to flatten into
+--   -> (CoreBndr, CoreExpr)            -- The bind to flatten
+--   -> TranslatorState ()
+-- 
+-- flattenBind hsfunc bind@(var, expr) = do
+--   -- Flatten the function
+--   let flatfunc = flattenFunction hsfunc bind
+--   -- Propagate state variables
+--   let flatfunc' = propagateState hsfunc flatfunc
+--   -- Store the flat function in the session
+--   modA tsFlatFuncs (Map.insert hsfunc flatfunc')
+--   -- Flatten any functions used
+--   let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
+--   mapM_ resolvFunc used_hsfuncs

 
 -- | Decide which incoming state variables will become state in the
 --   given function, and which will be propagate to other applied
 --   functions.
 
 -- | Decide which incoming state variables will become state in the
 --   given function, and which will be propagate to other applied
 --   functions.

-propagateState ::
-  HsFunction
-  -> FlatFunction
-  -> FlatFunction
-
-propagateState hsfunc flatfunc =
-    flatfunc {flat_defs = apps', flat_sigs = sigs'} 
-  where
-    (olds, news) = unzip $ getStateSignals hsfunc flatfunc
-    states' = zip olds news
-    -- Find all signals used by all sigdefs
-    uses = concatMap sigDefUses (flat_defs flatfunc)
-    -- Find all signals that are used more than once (is there a
-    -- prettier way to do this?)
-    multiple_uses = uses List.\\ (List.nub uses)
-    -- Find the states whose "old state" signal is used only once
-    single_use_states = filter ((`notElem` multiple_uses) . fst) states'
-    -- See if these single use states can be propagated
-    (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
-    substate_sigs = concat substate_sigss
-    -- Mark any propagated state signals as SigSubState
-    sigs' = map 
-      (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
-      (flat_sigs flatfunc)
+-- propagateState ::
+--   HsFunction
+--   -> FlatFunction
+--   -> FlatFunction
+-- 
+-- propagateState hsfunc flatfunc =
+--     flatfunc {flat_defs = apps', flat_sigs = sigs'} 
+--   where
+--     (olds, news) = unzip $ getStateSignals hsfunc flatfunc
+--     states' = zip olds news
+--     -- Find all signals used by all sigdefs
+--     uses = concatMap sigDefUses (flat_defs flatfunc)
+--     -- Find all signals that are used more than once (is there a
+--     -- prettier way to do this?)
+--     multiple_uses = uses List.\\ (List.nub uses)
+--     -- Find the states whose "old state" signal is used only once
+--     single_use_states = filter ((`notElem` multiple_uses) . fst) states'
+--     -- See if these single use states can be propagated
+--     (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
+--     substate_sigs = concat substate_sigss
+--     -- Mark any propagated state signals as SigSubState
+--     sigs' = map 
+--       (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
+--       (flat_sigs flatfunc)

 
 -- | Propagate the state into a single function application.
 
 -- | Propagate the state into a single function application.

-propagateState' ::
-  [(SignalId, SignalId)]
-                      -- ^ TODO
-  -> SigDef           -- ^ The SigDef to process.
-  -> ([SignalId], SigDef) 
-                      -- ^ Any signal ids that should become substates,
-                      --   and the resulting application.
-
-propagateState' states def =
-    if (is_FApp def) then
-      (our_old ++ our_new, def {appFunc = hsfunc'})
-    else
-      ([], def)
-  where
-    hsfunc = appFunc def
-    args = appArgs def
-    res = appRes def
-    our_states = filter our_state states
-    -- A state signal belongs in this function if the old state is
-    -- passed in, and the new state returned
-    our_state (old, new) =
-      any (old `Foldable.elem`) args
-      && new `Foldable.elem` res
-    (our_old, our_new) = unzip our_states
-    -- Mark the result
-    zipped_res = zipValueMaps res (hsFuncRes hsfunc)
-    res' = fmap (mark_state (zip our_new [0..])) zipped_res
-    -- Mark the args
-    zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
-    args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
-    hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
-
-    mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
-    mark_state states (id, use) =
-      case lookup id states of
-        Nothing -> use
-        Just state_id -> State state_id
+-- propagateState' ::
+--   [(SignalId, SignalId)]
+--                       -- ^ TODO
+--   -> SigDef           -- ^ The SigDef to process.
+--   -> ([SignalId], SigDef) 
+--                       -- ^ Any signal ids that should become substates,
+--                       --   and the resulting application.
+-- 
+-- propagateState' states def =
+--     if (is_FApp def) then
+--       (our_old ++ our_new, def {appFunc = hsfunc'})
+--     else
+--       ([], def)
+--   where
+--     hsfunc = appFunc def
+--     args = appArgs def
+--     res = appRes def
+--     our_states = filter our_state states
+--     -- A state signal belongs in this function if the old state is
+--     -- passed in, and the new state returned
+--     our_state (old, new) =
+--       any (old `Foldable.elem`) args
+--       && new `Foldable.elem` res
+--     (our_old, our_new) = unzip our_states
+--     -- Mark the result
+--     zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+--     res' = fmap (mark_state (zip our_new [0..])) zipped_res
+--     -- Mark the args
+--     zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+--     args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+--     hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+-- 
+--     mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+--     mark_state states (id, use) =
+--       case lookup id states of
+--         Nothing -> use
+--         Just state_id -> State state_id

 
 -- | Returns pairs of signals that should be mapped to state in this function.
 
 -- | Returns pairs of signals that should be mapped to state in this function.

-getStateSignals ::
-  HsFunction                      -- | The function to look at
-  -> FlatFunction                 -- | The function to look at
-  -> [(SignalId, SignalId)]   
-        -- | TODO The state signals. The first is the state number, the second the
-        --   signal to assign the current state to, the last is the signal
-        --   that holds the new state.
-
-getStateSignals hsfunc flatfunc =
-  [(old_id, new_id) 
-    | (old_num, old_id) <- args
-    , (new_num, new_id) <- res
-    , old_num == new_num]
-  where
-    sigs = flat_sigs flatfunc
-    -- Translate args and res to lists of (statenum, sigid)
-    args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
-    res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
+-- getStateSignals ::
+--   HsFunction                      -- | The function to look at
+--   -> FlatFunction                 -- | The function to look at
+--   -> [(SignalId, SignalId)]   
+--         -- | TODO The state signals. The first is the state number, the second the
+--         --   signal to assign the current state to, the last is the signal
+--         --   that holds the new state.
+-- 
+-- getStateSignals hsfunc flatfunc =
+--   [(old_id, new_id) 
+--     | (old_num, old_id) <- args
+--     , (new_num, new_id) <- res
+--     , old_num == new_num]
+--   where
+--     sigs = flat_sigs flatfunc
+--     -- Translate args and res to lists of (statenum, sigid)
+--     args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
+--     res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)

     
 -- | Find the given function, flatten it and add it to the session. Then
 --   (recursively) do the same for any functions used.
     
 -- | Find the given function, flatten it and add it to the session. Then
 --   (recursively) do the same for any functions used.

-resolvFunc ::
-  HsFunction        -- | The function to look for
-  -> TranslatorState ()
-
-resolvFunc hsfunc = do
-  flatfuncmap <- getA tsFlatFuncs
-  -- Don't do anything if there is already a flat function for this hsfunc or
-  -- when it is a builtin function.
-  Monad.unless (Map.member hsfunc flatfuncmap) $ do
-  -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
-  -- New function, resolve it
-  core <- getA tsCoreModule
-  -- Find the named function
-  let name = (hsFuncName hsfunc)
-  let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name 
-  case bind of
-    Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
-    Just b  -> flattenBind hsfunc b
+-- resolvFunc ::
+--   HsFunction        -- | The function to look for
+--   -> TranslatorState ()
+-- 
+-- resolvFunc hsfunc = do
+--   flatfuncmap <- getA tsFlatFuncs
+--   -- Don't do anything if there is already a flat function for this hsfunc or
+--   -- when it is a builtin function.
+--   Monad.unless (Map.member hsfunc flatfuncmap) $ do
+--   -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+--   -- New function, resolve it
+--   core <- getA tsCoreModule
+--   -- Find the named function
+--   let name = (hsFuncName hsfunc)
+--   let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name 
+--   case bind of
+--     Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+--     Just b  -> flattenBind hsfunc b

 
 -- | Translate a top level function declaration to a HsFunction. i.e., which
 --   interface will be provided by this function. This function essentially
 --   defines the "calling convention" for hardware models.
 
 -- | Translate a top level function declaration to a HsFunction. i.e., which
 --   interface will be provided by this function. This function essentially
 --   defines the "calling convention" for hardware models.

-mkHsFunction ::
-  Var.Var         -- ^ The function defined
-  -> Type         -- ^ The function type (including arguments!)
-  -> Bool         -- ^ Is this a stateful function?
-  -> HsFunction   -- ^ The resulting HsFunction
-
-mkHsFunction f ty stateful=
-  HsFunction hsname hsargs hsres
-  where
-    hsname  = getOccString f
-    (arg_tys, res_ty) = Type.splitFunTys ty
-    (hsargs, hsres) = 
-      if stateful 
-      then
-        let
-          -- The last argument must be state
-          state_ty = last arg_tys
-          state    = useAsState (mkHsValueMap state_ty)
-          -- All but the last argument are inports
-          inports = map (useAsPort . mkHsValueMap)(init arg_tys)
-          hsargs   = inports ++ [state]
-          hsres    = case splitTupleType res_ty of
-            -- Result type must be a two tuple (state, ports)
-            Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
-              then
-                Tuple [state, useAsPort (mkHsValueMap outport_ty)]
-              else
-                error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
-            otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
-        in
-          (hsargs, hsres)
-      else
-        -- Just use everything as a port
-        (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
+-- mkHsFunction ::
+--   Var.Var         -- ^ The function defined
+--   -> Type         -- ^ The function type (including arguments!)
+--   -> Bool         -- ^ Is this a stateful function?
+--   -> HsFunction   -- ^ The resulting HsFunction
+-- 
+-- mkHsFunction f ty stateful=
+--   HsFunction hsname hsargs hsres
+--   where
+--     hsname  = getOccString f
+--     (arg_tys, res_ty) = Type.splitFunTys ty
+--     (hsargs, hsres) = 
+--       if stateful 
+--       then
+--         let
+--           -- The last argument must be state
+--           state_ty = last arg_tys
+--           state    = useAsState (mkHsValueMap state_ty)
+--           -- All but the last argument are inports
+--           inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+--           hsargs   = inports ++ [state]
+--           hsres    = case splitTupleType res_ty of
+--             -- Result type must be a two tuple (state, ports)
+--             Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+--               then
+--                 Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+--               else
+--                 error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+--             otherwise                -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+--         in
+--           (hsargs, hsres)
+--       else
+--         -- Just use everything as a port
+--         (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)

 
 -- | Adds signal names to the given FlatFunction
 
 -- | Adds signal names to the given FlatFunction

-nameFlatFunction ::
-  FlatFunction
-  -> FlatFunction
-
-nameFlatFunction flatfunc =
-  -- Name the signals
-  let 
-    s = flat_sigs flatfunc
-    s' = map nameSignal s in
-  flatfunc { flat_sigs = s' }
-  where
-    nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
-    nameSignal (id, info) =
-      let hints = nameHints info in
-      let parts = ("sig" : hints) ++ [show id] in
-      let name = concat $ List.intersperse "_" parts in
-      (id, info {sigName = Just name})
-
--- | Splits a tuple type into a list of element types, or Nothing if the type
---   is not a tuple type.
-splitTupleType ::
-  Type              -- ^ The type to split
-  -> Maybe [Type]   -- ^ The tuples element types
-
-splitTupleType ty =
-  case Type.splitTyConApp_maybe ty of
-    Just (tycon, args) -> if TyCon.isTupleTyCon tycon 
-      then
-        Just args
-      else
-        Nothing
-    Nothing -> Nothing
+-- nameFlatFunction ::
+--   FlatFunction
+--   -> FlatFunction
+-- 
+-- nameFlatFunction flatfunc =
+--   -- Name the signals
+--   let 
+--     s = flat_sigs flatfunc
+--     s' = map nameSignal s in
+--   flatfunc { flat_sigs = s' }
+--   where
+--     nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+--     nameSignal (id, info) =
+--       let hints = nameHints info in
+--       let parts = ("sig" : hints) ++ [show id] in
+--       let name = concat $ List.intersperse "_" parts in
+--       (id, info {sigName = Just name})
+-- 
+-- -- | Splits a tuple type into a list of element types, or Nothing if the type
+-- --   is not a tuple type.
+-- splitTupleType ::
+--   Type              -- ^ The type to split
+--   -> Maybe [Type]   -- ^ The tuples element types
+-- 
+-- splitTupleType ty =
+--   case Type.splitTyConApp_maybe ty of
+--     Just (tycon, args) -> if TyCon.isTupleTyCon tycon 
+--       then
+--         Just args
+--       else
+--         Nothing
+--     Nothing -> Nothing

 
 -- vim: set ts=8 sw=2 sts=2 expandtab:
 
 -- vim: set ts=8 sw=2 sts=2 expandtab:

diff --git a/VHDL.hs b/VHDL.hs
index daf843f45d58c9b5ebe751bff37440ae6ee00556..6039447a55f5eb57097fa23b4fffc01d7cbee22a 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -40,15 +40,16 @@ import Constants
 import Generate
 
 createDesignFiles ::
 import Generate
 
 createDesignFiles ::

-  [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+  TypeState
+  -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]

   -> [(AST.VHDLId, AST.DesignFile)]
 
   -> [(AST.VHDLId, AST.DesignFile)]
 

-createDesignFiles binds =
+createDesignFiles init_typestate binds =

   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
   (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where

-    init_session = VHDLState emptyTypeState Map.empty
+    init_session = VHDLState init_typestate Map.empty

     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
     tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
     tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)


@@ -257,7 +258,9 @@ mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
 -- assignment. This should only happen for dataconstructors without arguments.
 -- TODO: Integrate this with the below code for application (essentially this
 -- is an application without arguments)
 -- assignment. This should only happen for dataconstructors without arguments.
 -- TODO: Integrate this with the below code for application (essentially this
 -- is an application without arguments)

-mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
+mkConcSm (bndr, Var v) = do
+  ty_state <- getA vsType
+  return $ [mkUncondAssign (Left bndr) ((varToVHDLExpr ty_state) v)]

 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app


@@ -285,13 +288,14 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 -- binders in the alts and only variables in the case values and a variable
 -- for a scrutinee. We check the constructor of the second alt, since the
 -- first is the default case, if there is any.
 -- binders in the alts and only variables in the case values and a variable
 -- for a scrutinee. We check the constructor of the second alt, since the
 -- first is the default case, if there is any.

-mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
-  let
-    cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
-    true_expr  = (varToVHDLExpr true)
-    false_expr  = (varToVHDLExpr false)
-  in
-    return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
+mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do {
+  ; ty_state <- getA vsType
+  ; let { cond_expr = (varToVHDLExpr ty_state scrut) AST.:=: (altconToVHDLExpr con)
+        ; true_expr  = (varToVHDLExpr ty_state true)
+        ; false_expr  = (varToVHDLExpr ty_state false)
+        } ;
+  ; return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
+  }

 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr

diff --git a/VHDLTools.hs b/VHDLTools.hs
index cf91cc7270fb45a9e844b437c254c770d22175ab..1e6e5bc1d09e6a956bb5b53fc7039e2985afb406 100644 (file)
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -7,6 +7,7 @@ import qualified Data.List as List
 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

+import qualified Control.Monad.Trans.State as State

 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import Debug.Trace
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import Debug.Trace


@@ -122,8 +123,8 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 -----------------------------------------------------------------------------
 
 -- Turn a variable reference into a AST expression
 -----------------------------------------------------------------------------
 
 -- Turn a variable reference into a AST expression

-varToVHDLExpr :: Var.Var -> AST.Expr
-varToVHDLExpr var = 
+varToVHDLExpr :: TypeState -> Var.Var -> AST.Expr
+varToVHDLExpr ty_state var =

   case Id.isDataConWorkId_maybe var of
     Just dc -> dataconToVHDLExpr dc
     -- This is a dataconstructor.
   case Id.isDataConWorkId_maybe var of
     Just dc -> dataconToVHDLExpr dc
     -- This is a dataconstructor.


@@ -133,13 +134,13 @@ varToVHDLExpr var =
     -- should still be translated to integer literals. It is probebly not the
     -- best solution to translate them here.
     -- FIXME: Find a better solution for translating instances of tfp integers
     -- should still be translated to integer literals. It is probebly not the
     -- best solution to translate them here.
     -- FIXME: Find a better solution for translating instances of tfp integers

-    Nothing -> 
+    Nothing ->

         let 
           ty  = Var.varType var
           res = case Type.splitTyConApp_maybe ty of
                   Just (tycon, args) ->
                     case Name.getOccString (TyCon.tyConName tycon) of
         let 
           ty  = Var.varType var
           res = case Type.splitTyConApp_maybe ty of
                   Just (tycon, args) ->
                     case Name.getOccString (TyCon.tyConName tycon) of

-                      "Dec" -> AST.PrimLit $ (show (eval_tfp_int ty))
+                      "Dec" -> AST.PrimLit $ (show (fst ( State.runState (tfp_to_int ty) ty_state ) ) )

                       otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
         in
           res
                       otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
         in
           res


@@ -152,7 +153,7 @@ vhdlNameToVHDLExpr = AST.PrimName
 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 
 -- Turn a Core expression into an AST expression
 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 
 -- Turn a Core expression into an AST expression

-exprToVHDLExpr = varToVHDLExpr . exprToVar
+exprToVHDLExpr ty_state = (varToVHDLExpr ty_state) . exprToVar

 
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it


@@ -318,7 +319,9 @@ construct_vhdl_ty ty = do
         "TFVec" -> mk_vector_ty ty
         "SizedWord" -> mk_unsigned_ty ty
         "SizedInt"  -> mk_signed_ty ty
         "TFVec" -> mk_vector_ty ty
         "SizedWord" -> mk_unsigned_ty ty
         "SizedInt"  -> mk_signed_ty ty

-        "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
+        "RangedWord" -> do 
+          bound <- tfp_to_int (ranged_word_bound_ty ty)
+          mk_natural_ty 0 bound

         -- Create a custom type from this tycon
         otherwise -> mk_tycon_ty tycon args
     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
         -- Create a custom type from this tycon
         otherwise -> mk_tycon_ty tycon args
     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")


@@ -370,10 +373,11 @@ mk_vector_ty ::
 
 mk_vector_ty ty = do
   types_map <- getA vsTypes
 
 mk_vector_ty ty = do
   types_map <- getA vsTypes

+  env <- getA vsHscEnv

   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

-  let len = tfvec_len ty
+  len <- tfp_to_int (tfvec_len_ty ty)

   let el_ty = tfvec_elem ty
   el_ty_tm_either <- vhdl_ty_either el_ty
   case el_ty_tm_either of
   let el_ty = tfvec_elem ty
   el_ty_tm_either <- vhdl_ty_either el_ty
   case el_ty_tm_either of


@@ -413,7 +417,7 @@ mk_unsigned_ty ::
   Type.Type -- ^ Haskell type of the unsigned integer
   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 mk_unsigned_ty ty = do
   Type.Type -- ^ Haskell type of the unsigned integer
   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 mk_unsigned_ty ty = do

-  let size  = sized_word_len ty
+  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 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)


@@ -423,7 +427,7 @@ mk_signed_ty ::
   Type.Type -- ^ Haskell type of the signed integer
   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 mk_signed_ty ty = do
   Type.Type -- ^ Haskell type of the signed integer
   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 mk_signed_ty ty = do

-  let size  = sized_word_len ty
+  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 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)


@@ -469,8 +473,9 @@ mkHType ty = do
               case elem_htype_either of
                 -- Could create element type
                 Right elem_htype -> do
               case elem_htype_either of
                 -- Could create element type
                 Right elem_htype -> do

-                  len <- tfp_to_int (tfvec_len_ty ty)
-                  return $ Right $ VecType len elem_htype
+                  env <- getA vsHscEnv
+                  let norm_ty = normalise_tfp_int env (tfvec_len_ty ty)
+                  return $ Right $ VecType (OrdType norm_ty) elem_htype

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

diff --git a/VHDLTypes.hs b/VHDLTypes.hs
index b9db66a485220276f060c18edcb9c1419efa1fa3..b4c1d6981c2f757df4fb7c5049375aa4845bcb59 100644 (file)
--- a/VHDLTypes.hs
+++ b/VHDLTypes.hs
@@ -13,6 +13,7 @@ import qualified Data.Accessor.Template
 -- GHC API imports
 import qualified Type
 import qualified CoreSyn
 -- GHC API imports
 import qualified Type
 import qualified CoreSyn

+import qualified HscTypes

 
 -- ForSyDe imports
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- ForSyDe imports
 import qualified ForSyDe.Backend.VHDL.AST as AST


@@ -40,7 +41,7 @@ instance Ord OrdType where
 
 data HType = StdType OrdType |
              ADTType String [HType] |
 
 data HType = StdType OrdType |
              ADTType String [HType] |

-             VecType Int HType |
+             VecType OrdType HType |

              SizedWType Int |
              RangedWType Int |
              SizedIType Int |
              SizedWType Int |
              RangedWType Int |
              SizedIType Int |


@@ -66,12 +67,11 @@ data TypeState = TypeState {
   vsTypeDecls_  :: [AST.PackageDecItem],
   -- | A map of vector Core type -> VHDL type function
   vsTypeFuns_   :: TypeFunMap,
   vsTypeDecls_  :: [AST.PackageDecItem],
   -- | A map of vector Core type -> VHDL type function
   vsTypeFuns_   :: TypeFunMap,

-  vsTfpInts_    :: TfpIntMap
+  vsTfpInts_    :: TfpIntMap,
+  vsHscEnv_     :: HscTypes.HscEnv

 }
 -- Derive accessors
 $( Data.Accessor.Template.deriveAccessors ''TypeState )
 }
 -- Derive accessors
 $( Data.Accessor.Template.deriveAccessors ''TypeState )

--- Define an empty TypeState
-emptyTypeState = TypeState Map.empty [] Map.empty Map.empty

 -- Define a session
 type TypeSession = State.State TypeState
 
 -- Define a session
 type TypeSession = State.State TypeState