Great speed-up in type generation

[matthijs/master-project/cλash.git] / Generate.hs

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                  ) )

   ]
   ]