Use data-accessor-transformers package to remove deprecation warnings

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

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index 048a711a1e58e6f6d455651d742b84dfad6fb720..4b24b576e89ca597a8c4b85b8bb551682d63e7fa 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -6,8 +6,7 @@ import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Maybe
 import qualified Data.Either as Either
 import qualified Control.Monad as Monad
 import qualified Maybe
 import qualified Data.Either as Either

-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
+import Data.Accessor.Monad.Trans.State as MonadState

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


@@ -50,9 +49,9 @@ getEntity fname = Utils.makeCached fname tsEntities $ do
       args' <- catMaybesM $ mapM mkMap args
       -- TODO: Handle Nothing
       res' <- mkMap res
       args' <- catMaybesM $ mapM mkMap args
       -- TODO: Handle Nothing
       res' <- mkMap res

-      count <- getA tsEntityCounter 
+      count <- MonadState.get tsEntityCounter 

       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count

-      putA tsEntityCounter (count + 1)
+      MonadState.set tsEntityCounter (count + 1)

       let ent_decl = createEntityAST vhdl_id args' res'
       let signature = Entity vhdl_id args' res' ent_decl
       return signature
       let ent_decl = createEntityAST vhdl_id args' res'
       let signature = Entity vhdl_id args' res' ent_decl
       return signature


@@ -71,7 +70,7 @@ getEntity fname = Utils.makeCached fname tsEntities $ do
         ty = Var.varType bndr
         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr 
       in do
         ty = Var.varType bndr
         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr 
       in do

-        type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty
+        type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty

         case type_mark_maybe of 
           Just type_mark -> return $ Just (id, type_mark)
           Nothing -> return Nothing
         case type_mark_maybe of 
           Just type_mark -> return $ Just (id, type_mark)
           Nothing -> return Nothing


@@ -129,16 +128,23 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
   (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
   let (in_state_maybes, out_state_maybes) = unzip state_vars
   let (statementss, used_entitiess) = unzip sms
   (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
   let (in_state_maybes, out_state_maybes) = unzip state_vars
   let (statementss, used_entitiess) = unzip sms

+  -- Get initial state, if it's there
+  initSmap <- MonadState.get tsInitStates
+  let init_state = Map.lookup fname initSmap

   -- Create a state proc, if needed
   -- Create a state proc, if needed

-  state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
-        ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
-        ([], []) -> return []
-        (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
+  (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
+        ([in_state], [out_state], Nothing) -> do 
+          nonEmpty <- hasNonEmptyType in_state
+          if nonEmpty then error ("No initial state defined for: " ++ show fname) else return ([],[])
+        ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval)
+        ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
+        ([], [], Nothing) -> return ([],[])
+        (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs

   -- Join the create statements and the (optional) state_proc
   let statements = concat statementss ++ state_proc
   -- Create the architecture
   let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
   -- Join the create statements and the (optional) state_proc
   let statements = concat statementss ++ state_proc
   -- Create the architecture
   let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements

-  let used_entities = concat used_entitiess
+  let used_entities = (concat used_entitiess) ++ resbndr

   return (arch, used_entities)
   where
     dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
   return (arch, used_entities)
   where
     dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process


@@ -162,24 +168,39 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
       return ((Nothing, Nothing), sms)
 
 mkStateProcSm :: 
       return ((Nothing, Nothing), sms)
 
 mkStateProcSm :: 

-  (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
-  -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
-mkStateProcSm (old, new) = do
-  nonempty <- hasNonEmptyType old 
-  if nonempty 
-    then return [AST.CSPSm $ AST.ProcSm label [clockId,resetId] [statement]]
-    else return []
-  where
-    label       = mkVHDLBasicId $ "state"
-    rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
-    wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
-    clk_assign      = AST.SigAssign (varToVHDLName old) wform
-    rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
-    resetn_is_low  = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
-    reset_statement = []
-    clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
-    statement   = AST.IfSm resetn_is_low reset_statement clk_statement Nothing
-
+  (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
+  -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
+mkStateProcSm (old, new, res) = do
+  let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res 
+  type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
+  let type_mark_old = Maybe.fromJust type_mark_old_maybe
+  type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
+  let type_mark_res' = Maybe.fromJust type_mark_res_maybe
+  let type_mark_res = if type_mark_old == type_mark_res' then
+                        type_mark_res'
+                      else 
+                        error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: "  ++ show type_mark_res'    
+  let resvalid  = mkVHDLExtId $ varToString res ++ "val"
+  let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
+  let reswform  = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
+  let res_assign = AST.SigAssign (varToVHDLName old) reswform
+  let blocklabel       = mkVHDLBasicId $ "state"
+  let statelabel  = mkVHDLBasicId $ "stateupdate"
+  let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+  let wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
+  let clk_assign      = AST.SigAssign (varToVHDLName old) wform
+  let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
+  let resetn_is_low  = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
+  signature <- getEntity res
+  let entity_id = ent_id signature
+  let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
+  let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
+  let reset_statement = mkComponentInst reslabel entity_id portmaps
+  let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
+  let statement   = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
+  let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
+  let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
+  return ([block],[res])

 
 -- | Transforms a core binding into a VHDL concurrent statement
 mkConcSm ::
 
 -- | Transforms a core binding into a VHDL concurrent statement
 mkConcSm ::


@@ -219,11 +240,25 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
       bndrs' <- Monad.filterM hasNonEmptyType bndrs
       case List.elemIndex sel_bndr bndrs' of
         Just i -> do
       bndrs' <- Monad.filterM hasNonEmptyType bndrs
       case List.elemIndex sel_bndr bndrs' of
         Just i -> do

-          labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
-          let label = labels!!i
-          let sel_name = mkSelectedName (varToVHDLName scrut) label
-          let sel_expr = AST.PrimName sel_name
-          return ([mkUncondAssign (Left bndr) sel_expr], [])
+          htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
+          htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+          case htypeScrt == htypeBndr of
+            True -> do
+              let sel_name = varToVHDLName scrut
+              let sel_expr = AST.PrimName sel_name
+              return ([mkUncondAssign (Left bndr) sel_expr], [])
+            otherwise -> do
+              case htypeScrt of
+                Right (AggrType _ _) -> do
+                  labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
+                  let label = labels!!i
+                  let sel_name = mkSelectedName (varToVHDLName scrut) label
+                  let sel_expr = AST.PrimName sel_name
+                  return ([mkUncondAssign (Left bndr) sel_expr], [])
+                _ -> do -- error $ "DIE!"
+                  let sel_name = varToVHDLName scrut
+                  let sel_expr = AST.PrimName sel_name
+                  return ([mkUncondAssign (Left bndr) sel_expr], [])

         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
       
     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
       
     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)


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

-mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+
+-- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+--   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
+--   altcon <- MonadState.lift tsType $ altconToVHDLExpr con
+--   let cond_expr = scrut' AST.:=: altcon
+--   true_expr <- MonadState.lift tsType $ varToVHDLExpr true
+--   false_expr <- MonadState.lift tsType $ varToVHDLExpr false
+--   return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"

   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut

-  let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
-  true_expr <- MonadState.lift tsType $ varToVHDLExpr true
-  false_expr <- MonadState.lift tsType $ varToVHDLExpr false
-  return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+  -- Omit first condition, which is the default
+  altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
+  let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
+  -- Rotate expressions to the left, so that the expression related to the default case is the last
+  exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
+  return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])

 
 

-mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"

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


@@ -260,7 +304,7 @@ argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
   let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
   let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"

-  ty_maybe <- vhdl_ty errmsg expr
+  ty_maybe <- vhdlTy errmsg expr

   case ty_maybe of
     Just _ -> do
       vhdl_expr <- varToVHDLExpr $ exprToVar expr
   case ty_maybe of
     Just _ -> do
       vhdl_expr <- varToVHDLExpr $ exprToVar expr


@@ -292,14 +336,16 @@ genVarArgs wrap dst func args = wrap dst func args'
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be Literals
 genLitArgs ::
 -- | 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
+  (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
+  -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
+genLitArgs wrap dst func args = do
+  hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
+  let (exprargs, []) = Either.partitionEithers args
+  -- FIXME: Check if we were passed an CoreSyn.App
+  let litargs = concat (map (getLiterals hscenv) exprargs)
+  let args' = map exprToLit litargs
+  concsms <- wrap dst func args'
+  return concsms    

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


@@ -334,7 +380,7 @@ genNegation' _ f [arg] = do
   let name = Name.getOccString (TyCon.tyConName tycon)
   case name of
     "SizedInt" -> return $ AST.Neg arg1
   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 
+    otherwise -> error $ "\nGenerate.genNegation': Negation not 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)


@@ -558,7 +604,7 @@ genFold'' len left (Left res) f [folded_f, start, vec] = do
   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 
   -- TODO: Handle Nothing
   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 
   -- TODO: Handle Nothing

-  Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+  Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty

   -- Setup the generate scheme
   let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
   let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
   -- Setup the generate scheme
   let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
   let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))


@@ -789,7 +835,7 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
   let tmp_ty = Var.varType res
   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
   -- TODO: Handle Nothing
   let tmp_ty = Var.varType res
   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
   -- TODO: Handle Nothing

-  Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+  Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty

   -- Setup the generate scheme
   let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
   let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
   -- Setup the generate scheme
   let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
   let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))


@@ -856,13 +902,13 @@ genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
   let (tup',ramvec) = Type.splitAppTy tup
   let Just realram = Type.coreView ramvec
   let Just (tycon, types) = Type.splitTyConApp_maybe realram
   let (tup',ramvec) = Type.splitAppTy tup
   let Just realram = Type.coreView ramvec
   let Just (tycon, types) = Type.splitTyConApp_maybe realram

-  Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types)
+  Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)

   -- Make the intermediate vector
   let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
   -- Get the data_out name
   -- Make the intermediate vector
   let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
   -- Get the data_out name

-  reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
-  let resname' = varToVHDLName res
-  let resname = mkSelectedName resname' (reslabels!!0)
+  -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+  let resname = varToVHDLName res
+  -- let resname = mkSelectedName resname' (reslabels!!0)

   let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
   let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
   let assign = mkUncondAssign (Right resname) argexpr
   let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
   let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
   let assign = mkUncondAssign (Right resname) argexpr


@@ -882,7 +928,32 @@ genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
         ramassign      = AST.SigAssign ramloc wform
         rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
         statement   = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
         ramassign      = AST.SigAssign ramloc wform
         rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
         statement   = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing

-
+        
+genSplit :: BuiltinBuilder
+genSplit = genNoInsts $ genVarArgs genSplit'
+
+genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genSplit' (Left res) f args@[vecIn] = do {
+  ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+  ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
+  ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
+        ; halflen   = round ((fromIntegral len) / 2)
+        ; rangeL    = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
+        ; rangeR    = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
+        ; resname   = varToVHDLName res
+        ; resnameL  = mkSelectedName resname (labels!!0)
+        ; resnameR  = mkSelectedName resname (labels!!1)
+        ; argexprL  = vhdlNameToVHDLExpr rangeL
+        ; argexprR  = vhdlNameToVHDLExpr rangeR
+        ; out_assignL = mkUncondAssign (Right resnameL) argexprL
+        ; out_assignR = mkUncondAssign (Right resnameR) argexprR
+        ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
+        }
+  ; return [AST.CSBSm block]
+  }
+  where
+    vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
+                            (AST.ToRange init last))

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


@@ -922,14 +993,26 @@ genApplication dst f args = do
           -- It's a datacon. Create a record from its arguments.
           Left bndr -> do
             -- We have the bndr, so we can get at the type
           -- 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 tsType $ getFieldLabels (Var.varType bndr)
-            args' <- argsToVHDLExprs 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
+            htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+            let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
+            case argsNostate of
+              [arg] -> do
+                [arg'] <- argsToVHDLExprs [arg]
+                return $ ([mkUncondAssign dst arg'], [])
+              otherwise -> do
+                case htype of
+                  Right (AggrType _ _) -> do
+                    labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
+                    args' <- argsToVHDLExprs argsNostate
+                    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
+                  _ -> do -- error $ "DIE!"
+                    args' <- argsToVHDLExprs argsNostate
+                    return $ ([mkUncondAssign dst (head args')], [])            

           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
         IdInfo.DataConWrapId dc -> case dst of
           -- It's a datacon. Create a record from its arguments.
           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
         IdInfo.DataConWrapId dc -> case dst of
           -- It's a datacon. Create a record from its arguments.


@@ -976,7 +1059,12 @@ genApplication dst f args = do
                   -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
                   -- f' <- MonadState.lift tsType $ varToVHDLExpr f
                   --                   return $ ([mkUncondAssign dst f'], [])
                   -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
                   -- f' <- MonadState.lift tsType $ varToVHDLExpr f
                   --                   return $ ([mkUncondAssign dst f'], [])

-                  error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
+                  errtype <- case dst of 
+                    Left bndr -> do 
+                      htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
+                      return (show htype)
+                    Right vhd -> return $ show vhd
+                  error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype) 

         IdInfo.ClassOpId cls -> do
           -- FIXME: Not looking for what instance this class op is called for
           -- Is quite stupid of course.
         IdInfo.ClassOpId cls -> do
           -- FIXME: Not looking for what instance this class op is called for
           -- Is quite stupid of course.


@@ -999,12 +1087,13 @@ vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
 vectorFunId el_ty fname = do
   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
   -- TODO: Handle the Nothing case?
 vectorFunId el_ty fname = do
   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
   -- TODO: Handle the Nothing case?

-  Just elemTM <- vhdl_ty error_msg el_ty
+  Just elemTM <- vhdlTy 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)

-  typefuns <- getA tsTypeFuns
-  case Map.lookup (OrdType el_ty, fname) typefuns of
+  typefuns <- MonadState.get tsTypeFuns
+  el_htype <- mkHType error_msg el_ty
+  case Map.lookup (UVecType el_htype, fname) typefuns of

     -- Function already generated, just return it
     Just (id, _) -> return id
     -- Function not generated yet, generate it
     -- Function already generated, just return it
     Just (id, _) -> return id
     -- Function not generated yet, generate it


@@ -1012,7 +1101,7 @@ 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 tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
+          MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))

           mapM_ (vectorFunId el_ty) (snd body)
           return function_id
         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
           mapM_ (vectorFunId el_ty) (snd body)
           return function_id
         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname


@@ -1446,6 +1535,10 @@ globalNameTable = Map.fromList
   , (hwnotId          , (1, genOperator1 AST.Not    ) )
   , (equalityId       , (2, genOperator2 (AST.:=:)  ) )
   , (inEqualityId     , (2, genOperator2 (AST.:/=:) ) )
   , (hwnotId          , (1, genOperator1 AST.Not    ) )
   , (equalityId       , (2, genOperator2 (AST.:=:)  ) )
   , (inEqualityId     , (2, genOperator2 (AST.:/=:) ) )

+  , (ltId             , (2, genOperator2 (AST.:<:)  ) )
+  , (lteqId           , (2, genOperator2 (AST.:<=:) ) )
+  , (gtId             , (2, genOperator2 (AST.:>:)  ) )
+  , (gteqId           , (2, genOperator2 (AST.:>=:) ) )

   , (boolOrId         , (2, genOperator2 AST.Or     ) )
   , (boolAndId        , (2, genOperator2 AST.And    ) )
   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
   , (boolOrId         , (2, genOperator2 AST.Or     ) )
   , (boolAndId        , (2, genOperator2 AST.And    ) )
   , (plusId           , (2, genOperator2 (AST.:+:)  ) )


@@ -1454,12 +1547,14 @@ globalNameTable = Map.fromList
   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
   , (fromIntegerId    , (1, genFromInteger          ) )
   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
   , (fromIntegerId    , (1, genFromInteger          ) )

-  , (resizeId         , (1, genResize               ) )
+  , (resizeWordId     , (1, genResize               ) )
+  , (resizeIntId      , (1, genResize               ) )

   , (sizedIntId       , (1, genSizedInt             ) )
   , (smallIntegerId   , (1, genFromInteger          ) )
   , (fstId            , (1, genFst                  ) )
   , (sndId            , (1, genSnd                  ) )
   , (blockRAMId       , (5, genBlockRAM             ) )
   , (sizedIntId       , (1, genSizedInt             ) )
   , (smallIntegerId   , (1, genFromInteger          ) )
   , (fstId            , (1, genFst                  ) )
   , (sndId            , (1, genSnd                  ) )
   , (blockRAMId       , (5, genBlockRAM             ) )

+  , (splitId          , (1, genSplit                ) )

   --, (tfvecId          , (1, genTFVec                ) )
   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
   ]
   --, (tfvecId          , (1, genTFVec                ) )
   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
   ]