Moved to new GHC API (6.11). Also use vhdl package for the VHDL AST

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

diff --git a/Generate.hs b/Generate.hs
index 857d4998091ef8ab5e54025c4feaf84c28cabace..8dc7a0aaaef50b0dacc7bc0be63df0f0d5a28013 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,17 +7,23 @@ 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

+import Data.Accessor.MonadState as MonadState

 import Debug.Trace
 
 -- ForSyDe
 import Debug.Trace
 
 -- ForSyDe

-import qualified ForSyDe.Backend.VHDL.AST as AST
+import qualified Language.VHDL.AST as AST

 
 -- GHC API
 import CoreSyn
 import Type
 import qualified Var
 import qualified IdInfo
 
 -- GHC API
 import CoreSyn
 import Type
 import qualified Var
 import qualified IdInfo

+import qualified Literal
+import qualified Name
+import qualified TyCon

 
 -- Local imports
 import Constants
 
 -- Local imports
 import Constants


@@ -30,12 +38,13 @@ import Pretty
 
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be expressions.
 
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be expressions.

-genExprArgs ::
-  (dst -> func -> [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 wrap dst func args = do
+  args' <- eitherCoreOrExprArgs args
+  wrap dst func args'
+
+eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
+eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
+

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


@@ -47,6 +56,18 @@ genVarArgs wrap dst func args = wrap dst func args'
     -- Check (rather crudely) that all arguments are CoreExprs
     (exprargs, []) = Either.partitionEithers args
 
     -- Check (rather crudely) that all arguments are CoreExprs
     (exprargs, []) = Either.partitionEithers args
 

+-- | A function to wrap a builder-like function that expects its arguments to
+-- be Literals
+genLitArgs ::
+  (dst -> func -> [Literal.Literal] -> res)
+  -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genLitArgs wrap dst func args = wrap dst func args'
+  where
+    args' = map exprToLit litargs
+    -- FIXME: Check if we were passed an CoreSyn.App
+    litargs = concat (map getLiterals exprargs)
+    (exprargs, []) = Either.partitionEithers args
+

 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.
 genExprRes ::
 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.
 genExprRes ::


@@ -69,157 +90,418 @@ genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genOperator1' op _ f [arg] = return $ op arg
 
 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] = do
+  arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
+  let ty = Var.varType arg
+  let (tycon, args) = Type.splitTyConApp ty
+  let name = Name.getOccString (TyCon.tyConName tycon)
+  case name of
+    "SizedInt" -> return $ AST.Neg arg1
+    otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name 
+

 -- | 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 :: BuiltinBuilder 
-genFCall = genExprArgs $ genExprRes genFCall'
-genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
-genFCall' (Left res) f args = do
+genFCall :: Bool -> BuiltinBuilder 
+genFCall switch = genExprArgs $ 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
   let fname = varToString f

-  let el_ty = (tfvec_elem . Var.varType) res
-  id <- vectorFunId el_ty fname
+  let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
+  id <- MonadState.lift vsType $ vectorFunId el_ty fname

   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args

-genFCall' (Right name) _ _ = error $ "Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genFromSizedWord :: BuiltinBuilder
+genFromSizedWord = genExprArgs $ 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
+  return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
+             map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genResize :: BuiltinBuilder
+genResize = genExprArgs $ genExprRes genResize'
+genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genResize' (Left res) f [arg] = 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)
+  ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+             [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+  }
+genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+-- FIXME: I'm calling genLitArgs which is very specific function,
+-- which needs to be fixed as well
+genFromInteger :: BuiltinBuilder
+genFromInteger = genLitArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
+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))]
+  }
+
+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
 
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder

-genMap = genVarArgs genMap'
-genMap' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genMap' (Left res) f [mapped_f, arg] =
-  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
-    app_concsms <- genApplication (Right resname) mapped_f [Right argexpr]
+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).
+  -- 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 $ "Cannot generate map function call assigned to a VHDLName: " ++ show name
+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 :: 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
+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 [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+  }
+
+genFoldl :: BuiltinBuilder
+genFoldl = genFold True
+
+genFoldr :: BuiltinBuilder
+genFoldr = genFold False
+
+genFold :: Bool -> BuiltinBuilder
+genFold left = genVarArgs (genFold' left)
+
+genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genFold' left res f args@[folded_f , start ,vec]= do
+  len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
+  genFold'' len left res f args
+
+genFold'' :: Int -> 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
+genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
+  arg <- MonadState.lift vsType $ varToVHDLExpr start
+  return [mkUncondAssign (Left res) arg]
+    
+genFold'' len 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
+  -- temporary vector
+  let tmp_ty = Type.mkAppTy nvec (Var.varType start)
+  let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
+  tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
+  -- Setup the generate scheme
+  let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
+  let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
+  let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
+                  else AST.DownRange len_min_expr (AST.PrimLit "0")
+  let gen_scheme   = AST.ForGn n_id gen_range
+  -- Make the intermediate vector
+  let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+  -- Create the generate statement
+  cells <- sequence [genFirstCell, genOtherCell]
+  let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+  -- Assign tmp[len-1] or tmp[0] to res
+  let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
+                    (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
+                    (mkIndexedName tmp_name (AST.PrimLit "0")))      
+  let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+  return [AST.CSBSm block]
+  where
+    -- 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 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")
+                                                  else (AST.PrimLit $ show (len-1)))
+      -- Output to tmp[current n]
+      let resname = mkIndexedName tmp_name n_cur
+      -- Input from start
+      argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
+      -- Input from vec[current n]
+      let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+      app_concsms <- genApplication (Right resname) folded_f  ( if left then
+                                                                  [Right argexpr1, Right argexpr2]
+                                                                else
+                                                                  [Right argexpr2, Right argexpr1]
+                                                              )
+      -- Return the conditional generate part
+      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")
+                                                   else (AST.PrimLit $ show (len-1)))
+      -- Output to tmp[current n]
+      let resname = mkIndexedName tmp_name n_cur
+      -- Input from tmp[previous n]
+      let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+      -- Input from vec[current n]
+      let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
+      app_concsms <- genApplication (Right resname) folded_f  ( if left then
+                                                                  [Right argexpr1, Right argexpr2]
+                                                                else
+                                                                  [Right argexpr2, Right argexpr1]
+                                                              )
+      -- Return the conditional generate part
+      return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+-- | Generate a generate statement for the builtin function "zip"
+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] = do {

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

-    len         = (tfvec_len . Var.varType) res
+  ; 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 [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]
+genUnzip' (Left res) f args@[arg] = do {
+    -- Setup the generate scheme
+  ; 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 ("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]
+  ; 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 [] app_concsms]
-{-
-genFoldl :: BuiltinBuilder
-genFoldl = genVarArgs genFoldl'
-genFoldl' resVal f [folded_f, startVal, inVec] = do
-  signatures <- getA vsSignatures
-  let entity = Maybe.fromMaybe
-        (error $ "Using function '" ++ (varToString folded_f) ++ "' without signature? This should not happen!") 
-        (Map.lookup folded_f signatures)
-  let (vec, _) = splitAppTy (Var.varType inVec)
-  let vecty = Type.mkAppTy vec (Var.varType startVal)
-  vecType <- vhdl_ty vecty
+  ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+  }
+
+genCopy :: BuiltinBuilder 
+genCopy = genVarArgs genCopy'
+genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genCopy' (Left res) f args@[arg] =
+  let
+    resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
+                (AST.PrimName $ (varToVHDLName arg))]
+    out_assign = mkUncondAssign (Left res) resExpr
+  in 
+    return [out_assign]
+    
+genConcat :: BuiltinBuilder
+genConcat = genVarArgs genConcat'
+genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genConcat' (Left res) f args@[arg] = do {
+    -- Setup the generate scheme
+  ; 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 [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+  }
+  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)
+
+genIterate :: BuiltinBuilder
+genIterate = genIterateOrGenerate True
+
+genGeneraten :: BuiltinBuilder
+genGeneraten dst f args = genGenerate dst f (tail args)
+
+genGenerate :: BuiltinBuilder
+genGenerate = genIterateOrGenerate False
+
+genIterateOrGenerate :: Bool -> BuiltinBuilder
+genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
+
+genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genIterateOrGenerate' iter (Left res) f args = do
+  len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+  genIterateOrGenerate'' len iter (Left res) f args
+
+genIterateOrGenerate'' :: Int -> 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
+genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
+
+genIterateOrGenerate'' len 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
+  -- -- temporary vector
+  let tmp_ty = Var.varType res
+  let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
+  tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty

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

-  let  len         = (tfvec_len . Var.varType) inVec
-  let  genlabel       = mkVHDLExtId ("foldlVector" ++ (varToString inVec))
-  let  blockLabel  = mkVHDLExtId ("foldlVector" ++ (varToString startVal))
-  let  range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
-  let  genScheme   = AST.ForGn (AST.unsafeVHDLBasicId "n") range
+  let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
+  let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
+  let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
+  let gen_scheme   = AST.ForGn n_id gen_range

   -- Make the intermediate vector
   -- Make the intermediate vector

-  let  tmpVec      = AST.BDISD $ AST.SigDec (mkVHDLExtId "tmp") vecType Nothing
-  -- Get the entity name and port names
-  let entity_id   = ent_id entity
-  let argports    = map (Monad.liftM fst) (ent_args entity)
-  let resport     = (Monad.liftM fst) (ent_res entity)
-  -- Return the generate functions
-  let genSm       = AST.GenerateSm genlabel genScheme [] 
-                      [ AST.CSGSm (genFirstCell (entity_id, argports, resport) 
-                                    [startVal, inVec, resVal])
-                      , AST.CSGSm (genOtherCell (entity_id, argports, resport) 
-                                    [startVal, inVec, resVal])
-                      , AST.CSGSm (genLastCell (entity_id, argports, resport) 
-                                    [startVal, inVec, resVal])
-                      ]
-  return $ [AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm]]
+  let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+  -- Create the generate statement
+  cells <- sequence [genFirstCell, genOtherCell]
+  let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+  -- Assign tmp[len-1] or tmp[0] to res
+  let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name    
+  let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+  return [AST.CSBSm block]

   where
   where

-    genFirstCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
-      where
-        cellLabel    = mkVHDLExtId "firstcell"
-        cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar)  AST.:=: (AST.PrimLit "0"))
-        tmpId       = mkVHDLExtId "tmp"
-        nPar        = AST.unsafeVHDLBasicId "n"
-        -- Assign the ports
-        inport1     = mkAssocElem (argports!!0) (varToString startVal)
-        inport2     = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar 
-        outport     = mkAssocElemIndexed resport tmpId nPar
-        portassigns = Maybe.catMaybes [inport1,inport2,outport]
-        -- Generate the portmap
-        mapLabel    = "cell" ++ (AST.fromVHDLId entity_id)
-        compins     = mkComponentInst mapLabel entity_id portassigns
-        -- Return the generate functions
-        cellGn       = AST.GenerateSm cellLabel cellGenScheme [] [compins]
-    genOtherCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
-      where
-        len         = (tfvec_len . Var.varType) inVec
-        cellLabel    = mkVHDLExtId "othercell"
-        cellGenScheme = AST.IfGn $ AST.And ((AST.PrimName $ AST.NSimple nPar)  AST.:>: (AST.PrimLit "0"))
-                                ((AST.PrimName $ AST.NSimple nPar)  AST.:<: (AST.PrimLit $ show (len-1)))
-        tmpId       = mkVHDLExtId "tmp"
-        nPar        = AST.unsafeVHDLBasicId "n"
-        -- Assign the ports
-        inport1     = mkAssocElemIndexed (argports!!0) tmpId (AST.unsafeVHDLBasicId "n-1")
-        inport2     = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar 
-        outport     = mkAssocElemIndexed resport tmpId nPar
-        portassigns = Maybe.catMaybes [inport1,inport2,outport]
-        -- Generate the portmap
-        mapLabel    = "cell" ++ (AST.fromVHDLId entity_id)
-        compins     = mkComponentInst mapLabel entity_id portassigns
-        -- Return the generate functions
-        cellGn      = AST.GenerateSm cellLabel cellGenScheme [] [compins]
-    genLastCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
-      where
-        len         = (tfvec_len . Var.varType) inVec
-        cellLabel    = mkVHDLExtId "lastCell"
-        cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar)  AST.:=: (AST.PrimLit $ show (len-1)))
-        tmpId       = mkVHDLExtId "tmp"
-        nPar        = AST.unsafeVHDLBasicId "n"
-        -- Assign the ports
-        inport1     = mkAssocElemIndexed (argports!!0) tmpId (AST.unsafeVHDLBasicId "n-1")
-        inport2     = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar 
-        outport     = mkAssocElemIndexed resport tmpId nPar
-        portassigns = Maybe.catMaybes [inport1,inport2,outport]
-        -- Generate the portmap
-        mapLabel    = "cell" ++ (AST.fromVHDLId entity_id)
-        compins     = mkComponentInst mapLabel entity_id portassigns
-        -- Generate the output assignment
-        assign      = mkUncondAssign (Left resVal) (AST.PrimName (AST.NIndexed (AST.IndexedName 
-                              (AST.NSimple tmpId) [AST.PrimLit $ show (len-1)])))
-        -- Return the generate functions
-        cellGn      = AST.GenerateSm cellLabel cellGenScheme [] [compins,assign]
--}
+    -- 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 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
+      let cond_label = mkVHDLExtId "firstcell"
+      -- if n == 0 or n == len-1
+      let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
+      -- Output to tmp[current n]
+      let resname = mkIndexedName tmp_name n_cur
+      -- Input from start
+      argexpr <- MonadState.lift vsType $ varToVHDLExpr start
+      let startassign = mkUncondAssign (Right resname) argexpr
+      app_concsms <- genApplication (Right resname) app_f  [Right argexpr]
+      -- Return the conditional generate part
+      return $ AST.GenerateSm cond_label cond_scheme [] (if iter then 
+                                                          [startassign]
+                                                         else 
+                                                          app_concsms
+                                                        )
+
+    genOtherCell = do
+      let cond_label = mkVHDLExtId "othercell"
+      -- if n > 0 or n < len-1
+      let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
+      -- Output to tmp[current n]
+      let resname = mkIndexedName tmp_name n_cur
+      -- Input from tmp[previous n]
+      let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
+      app_concsms <- genApplication (Right resname) app_f [Right argexpr]
+      -- Return the conditional generate part
+      return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+

 -----------------------------------------------------------------------------
 -- Function to generate VHDL for applications
 -----------------------------------------------------------------------------
 -----------------------------------------------------------------------------
 -- Function to generate VHDL for applications
 -----------------------------------------------------------------------------


@@ -228,49 +510,69 @@ 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 =
-  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 <- getFieldLabels (Var.varType bndr)
-        return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args
-        where
-          mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
-          mkassign label arg =
-            let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
-            mkUncondAssign (Right sel_name) arg
-      Right _ -> error $ "Generate.genApplication Can't generate dataconstructor application without an original binder"
-    IdInfo.VanillaGlobal -> do
-      -- It's a global value imported from elsewhere. These can be builtin
-      -- functions. Look up the function name in the name table and execute
-      -- 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
-        Just (arg_count, builder) ->
-          if length args == arg_count then
-            builder dst f args
-          else
-            error $ "Generate.genApplication Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
-        Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
-    IdInfo.NotGlobalId -> do
+genApplication dst f args = do
+  case Var.isGlobalId f of
+    False -> do

       signatures <- getA vsSignatures
       -- This is a local id, so it should be a function whose definition we
       -- have and which can be turned into a component instantiation.
       signatures <- getA vsSignatures
       -- This is a local id, so it should be a function whose definition we
       -- have and which can be turned into a component instantiation.

-      let  
-        signature = Maybe.fromMaybe 
-          (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") 
-          (Map.lookup f signatures)
-        entity_id = ent_id signature
-        -- TODO: Using show here isn't really pretty, but we'll need some
-        -- unique-ish value...
-        label = "comp_ins_" ++ (either show show) dst
-        portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature
-        in
+      case (Map.lookup f signatures) of
+        Just signature -> do
+          args' <- eitherCoreOrExprArgs args
+          -- We have a signature, this is a top level binding. Generate a
+          -- component instantiation.
+          let entity_id = ent_id signature
+          -- TODO: Using show here isn't really pretty, but we'll need some
+          -- unique-ish value...
+          let label = "comp_ins_" ++ (either show prettyShow) dst
+          let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature

           return [mkComponentInst label entity_id portmaps]
           return [mkComponentInst label entity_id portmaps]

-    details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+        Nothing -> do
+          -- No signature, so this must be a local variable reference. It
+          -- should have a representable type (and thus, no arguments) and a
+          -- signal should be generated for it. Just generate an
+          -- unconditional assignment here.
+          f' <- MonadState.lift vsType $ varToVHDLExpr f
+          return $ [mkUncondAssign dst f']
+    True ->
+      case Var.idDetails 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)
+            args' <- eitherCoreOrExprArgs args
+            return $ zipWith mkassign labels $ args'
+            where
+              mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
+              mkassign label arg =
+                let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
+                mkUncondAssign (Right sel_name) arg
+          Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
+        IdInfo.VanillaId -> do
+          -- It's a global value imported from elsewhere. These can be builtin
+          -- functions. Look up the function name in the name table and execute
+          -- 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
+            Just (arg_count, builder) ->
+              if length args == arg_count then
+                builder dst f args
+              else
+                error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+            Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
+        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
+            Just (arg_count, builder) ->
+              if length args == arg_count then
+                builder dst f args
+              else
+                error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+            Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
+        details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details

 
 -----------------------------------------------------------------------------
 -- Functions to generate functions dealing with vectors.
 
 -----------------------------------------------------------------------------
 -- Functions to generate functions dealing with vectors.


@@ -278,9 +580,10 @@ genApplication dst f args =
 
 -- Returns the VHDLId of the vector function with the given name for the given
 -- element type. Generates -- this function if needed.
 
 -- Returns the VHDLId of the vector function with the given name for the given
 -- element type. Generates -- this function if needed.

-vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
+vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId

 vectorFunId el_ty fname = do
 vectorFunId el_ty fname = do

-  elemTM <- vhdl_ty el_ty
+  let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
+  elemTM <- vhdl_ty error_msg el_ty

   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
   -- the VHDLState or something.
   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
   -- the VHDLState or something.
   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)


@@ -293,36 +596,51 @@ vectorFunId el_ty fname = do
       let functions = genUnconsVectorFuns elemTM vectorTM
       case lookup fname functions of
         Just body -> do
       let functions = genUnconsVectorFuns elemTM vectorTM
       case lookup fname functions of
         Just body -> do

-          modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
+          modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
+          mapM_ (vectorFunId el_ty) (snd body)

           return function_id
           return function_id

-        Nothing -> error $ "I don't know how to generate vector function " ++ fname
+        Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname

   where
     function_id = mkVHDLExtId fname
 
 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
                     -> AST.TypeMark -- ^ type of the vector
   where
     function_id = mkVHDLExtId fname
 
 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
                     -> AST.TypeMark -- ^ type of the vector

-                    -> [(String, AST.SubProgBody)]
+                    -> [(String, (AST.SubProgBody, [String]))]

 genUnconsVectorFuns elemTM vectorTM  = 
 genUnconsVectorFuns elemTM vectorTM  = 

-  [ (exId, AST.SubProgBody exSpec      []                  [exExpr])
-  , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
-  , (headId, AST.SubProgBody headSpec    []                  [headExpr])
-  , (lastId, AST.SubProgBody lastSpec    []                  [lastExpr])
-  , (initId, AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet])
-  , (tailId, AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet])
-  , (takeId, AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet])
-  , (dropId, AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet])
-  , (plusgtId, AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
-  , (emptyId, AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr])
-  , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
-  , (copyId, AST.SubProgBody copySpec    [AST.SPVD copyVar]      [copyExpr])
+  [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
+  , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
+  , (headId, (AST.SubProgBody headSpec    []                  [headExpr],[]))
+  , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
+  , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
+  , (tailId, (AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet],[]))
+  , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[]))
+  , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
+  , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
+  , (emptyId, (AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr],[]))
+  , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
+  , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
+  , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
+  , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))  
+  , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
+  , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
+  , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
+  , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
+  , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
+  , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
+  , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
+  , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))

   ]
   where 
     ixPar   = AST.unsafeVHDLBasicId "ix"
     vecPar  = AST.unsafeVHDLBasicId "vec"
   ]
   where 
     ixPar   = AST.unsafeVHDLBasicId "ix"
     vecPar  = AST.unsafeVHDLBasicId "vec"

+    vec1Par = AST.unsafeVHDLBasicId "vec1"
+    vec2Par = AST.unsafeVHDLBasicId "vec2"

     nPar    = AST.unsafeVHDLBasicId "n"
     iId     = AST.unsafeVHDLBasicId "i"
     iPar    = iId
     aPar    = AST.unsafeVHDLBasicId "a"
     nPar    = AST.unsafeVHDLBasicId "n"
     iId     = AST.unsafeVHDLBasicId "i"
     iPar    = iId
     aPar    = AST.unsafeVHDLBasicId "a"

+    fPar = AST.unsafeVHDLBasicId "f"
+    sPar = AST.unsafeVHDLBasicId "s"

     resId   = AST.unsafeVHDLBasicId "res"
     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
                                AST.IfaceVarDec ixPar  naturalTM] elemTM
     resId   = AST.unsafeVHDLBasicId "res"
     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
                                AST.IfaceVarDec ixPar  naturalTM] elemTM


@@ -470,10 +788,10 @@ genUnconsVectorFuns elemTM vectorTM  =
              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
                                           (AST.PrimName $ AST.NSimple aPar)])
     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
                                           (AST.PrimName $ AST.NSimple aPar)])
     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)

-    copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar   naturalTM,
+    copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,

                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM 
     -- variable res : fsvec_x (0 to n-1) := (others => a);
                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM 
     -- variable res : fsvec_x (0 to n-1) := (others => a);

-    copyVar = 
+    copynVar = 

       AST.VarDec resId 
              (AST.SubtypeIn vectorTM
                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
       AST.VarDec resId 
              (AST.SubtypeIn vectorTM
                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 


@@ -483,8 +801,187 @@ genUnconsVectorFuns elemTM vectorTM  =
              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
                                           (AST.PrimName $ AST.NSimple aPar)])
     -- return res
              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
                                           (AST.PrimName $ AST.NSimple aPar)])
     -- return res

-    copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-
+    copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
+                               AST.IfaceVarDec sPar   naturalTM,
+                               AST.IfaceVarDec nPar   naturalTM,
+                               AST.IfaceVarDec vecPar vectorTM ] vectorTM
+    -- variable res : fsvec_x (0 to n-1);
+    selVar = 
+      AST.VarDec resId 
+                (AST.SubtypeIn vectorTM
+                  (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+                    [AST.ToRange (AST.PrimLit "0")
+                      ((AST.PrimName (AST.NSimple nPar)) AST.:-:
+                      (AST.PrimLit "1"))   ])
+                )
+                Nothing
+    -- for i res'range loop
+    --   res(i) := vec(f+i*s);
+    -- end loop;
+    selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign]
+    -- res(i) := vec(f+i*s);
+    selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+: 
+                                (AST.PrimName (AST.NSimple iId) AST.:*: 
+                                  AST.PrimName (AST.NSimple sPar)) in
+                                  AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
+                                    (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
+    -- return res;
+    selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+    ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
+                                        AST.IfaceVarDec aPar   elemTM] vectorTM 
+     -- variable res : fsvec_x (0 to vec'length);
+    ltplusVar = 
+      AST.VarDec resId 
+        (AST.SubtypeIn vectorTM
+          (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+            [AST.ToRange (AST.PrimLit "0")
+              (AST.PrimName (AST.NAttribute $ 
+                AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
+        Nothing
+    ltplusExpr = AST.NSimple resId AST.:= 
+                     ((AST.PrimName $ AST.NSimple vecPar) AST.:&: 
+                      (AST.PrimName $ AST.NSimple aPar))
+    ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
+                                             AST.IfaceVarDec vec2Par vectorTM] 
+                                             vectorTM 
+    -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
+    plusplusVar = 
+      AST.VarDec resId 
+        (AST.SubtypeIn vectorTM
+          (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+            [AST.ToRange (AST.PrimLit "0")
+              (AST.PrimName (AST.NAttribute $ 
+                AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+:
+                  AST.PrimName (AST.NAttribute $ 
+                AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+                  AST.PrimLit "1")]))
+       Nothing
+    plusplusExpr = AST.NSimple resId AST.:= 
+                     ((AST.PrimName $ AST.NSimple vec1Par) AST.:&: 
+                      (AST.PrimName $ AST.NSimple vec2Par))
+    plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
+    lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ 
+                                AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
+    shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
+                                   AST.IfaceVarDec aPar   elemTM  ] vectorTM 
+    -- variable res : fsvec_x (0 to vec'length-1);
+    shiftlVar = 
+     AST.VarDec resId 
+            (AST.SubtypeIn vectorTM
+              (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+               [AST.ToRange (AST.PrimLit "0")
+                        (AST.PrimName (AST.NAttribute $ 
+                          AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+                           (AST.PrimLit "1")) ]))
+            Nothing
+    -- res := a & init(vec)
+    shiftlExpr = AST.NSimple resId AST.:=
+                    (AST.PrimName (AST.NSimple aPar) AST.:&:
+                     (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))  
+                       [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+    shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)       
+    shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
+                                       AST.IfaceVarDec aPar   elemTM  ] vectorTM 
+    -- variable res : fsvec_x (0 to vec'length-1);
+    shiftrVar = 
+     AST.VarDec resId 
+            (AST.SubtypeIn vectorTM
+              (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+               [AST.ToRange (AST.PrimLit "0")
+                        (AST.PrimName (AST.NAttribute $ 
+                          AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+                           (AST.PrimLit "1")) ]))
+            Nothing
+    -- res := tail(vec) & a
+    shiftrExpr = AST.NSimple resId AST.:=
+                  ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))  
+                    [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+                  (AST.PrimName (AST.NSimple aPar)))
+                
+    shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)      
+    nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
+    -- return vec'length = 0
+    nullExpr = AST.ReturnSm (Just $ 
+                AST.PrimName (AST.NAttribute $ 
+                  AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=:
+                    AST.PrimLit "0")
+    rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
+    -- variable res : fsvec_x (0 to vec'length-1);
+    rotlVar = 
+     AST.VarDec resId 
+            (AST.SubtypeIn vectorTM
+              (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+               [AST.ToRange (AST.PrimLit "0")
+                        (AST.PrimName (AST.NAttribute $ 
+                          AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+                           (AST.PrimLit "1")) ]))
+            Nothing
+    -- if null(vec) then res := vec else res := last(vec) & init(vec)
+    rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))  
+                          [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+                        [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+                        []
+                        (Just $ AST.Else [rotlExprRet])
+      where rotlExprRet = 
+                AST.NSimple resId AST.:= 
+                      ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))  
+                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))  
+                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+    rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)       
+    rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
+    -- variable res : fsvec_x (0 to vec'length-1);
+    rotrVar = 
+     AST.VarDec resId 
+            (AST.SubtypeIn vectorTM
+              (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+               [AST.ToRange (AST.PrimLit "0")
+                        (AST.PrimName (AST.NAttribute $ 
+                          AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+                           (AST.PrimLit "1")) ]))
+            Nothing
+    -- if null(vec) then res := vec else res := tail(vec) & head(vec)
+    rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))  
+                          [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
+                        [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
+                        []
+                        (Just $ AST.Else [rotrExprRet])
+      where rotrExprRet = 
+                AST.NSimple resId AST.:= 
+                      ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))  
+                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
+                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))  
+                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
+    rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+    reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
+    reverseVar = 
+      AST.VarDec resId 
+             (AST.SubtypeIn vectorTM
+               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
+                [AST.ToRange (AST.PrimLit "0")
+                         (AST.PrimName (AST.NAttribute $ 
+                           AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
+                            (AST.PrimLit "1")) ]))
+             Nothing
+    -- for i in 0 to res'range loop
+    --   res(vec'length-i-1) := vec(i);
+    -- end loop;
+    reverseFor = 
+       AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign]
+    -- res(vec'length-i-1) := vec(i);
+    reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
+      (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) 
+                           [AST.PrimName $ AST.NSimple iId]))
+        where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) 
+                                   (mkVHDLBasicId lengthId) Nothing) AST.:-: 
+                        AST.PrimName (AST.NSimple iId) AST.:-: 
+                        (AST.PrimLit "1") 
+    -- return res;
+    reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
+    

 -----------------------------------------------------------------------------
 -- A table of builtin functions
 -----------------------------------------------------------------------------
 -----------------------------------------------------------------------------
 -- A table of builtin functions
 -----------------------------------------------------------------------------


@@ -493,23 +990,49 @@ genUnconsVectorFuns elemTM vectorTM  =
 -- builder function.
 globalNameTable :: NameTable
 globalNameTable = Map.fromList
 -- builder function.
 globalNameTable :: NameTable
 globalNameTable = Map.fromList

-  [ (exId             , (2, genFCall                ) )
-  , (replaceId        , (3, genFCall                ) )
-  , (headId           , (1, genFCall                ) )
-  , (lastId           , (1, genFCall                ) )
-  , (tailId           , (1, genFCall                ) )
-  , (initId           , (1, genFCall                ) )
-  , (takeId           , (2, genFCall                ) )
-  , (dropId           , (2, genFCall                ) )
-  , (plusgtId         , (2, genFCall                ) )
+  [ (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              ) )
   , (mapId            , (2, genMap                  ) )
   , (zipWithId        , (3, genZipWith              ) )

-  --, (foldlId          , (3, genFoldl                ) )
-  , (emptyId          , (0, genFCall                ) )
-  , (singletonId      , (1, genFCall                ) )
-  , (copyId           , (2, genFCall                ) )
+  , (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    ) )
   , (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          ) )
+  , (resizeId         , (1, genResize               ) )

   ]
   ]