Pulled 'varToVHDLExpr' into the TypeSession monad

diff --git a/Generate.hs b/Generate.hs
index 4f0acf319760946a632e5a5b45970164c1b8e0dc..4846d58690011e3e3b8d82083feecc67e91c2a19 100644 (file)
--- a/Generate.hs
+++ b/Generate.hs
@@ -38,12 +38,21 @@ import Pretty
 
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be expressions.
-genExprArgs ::
-  TypeState
-  -> (dst -> func -> [AST.Expr] -> res)
-  -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genExprArgs ty_state wrap dst func args = wrap dst func args'
-  where args' = map (either ((varToVHDLExpr ty_state).exprToVar) id) args
+genExprArgs wrap dst func args = do
+  args' <- eitherCoreOrExprArgs args
+  wrap dst func args'
+
+idM :: a -> VHDLSession a
+idM e = return e
+
+eitherM :: (a -> m c) -> (b -> m c) -> Either a b -> m c
+eitherM f1 f2 e = do
+  case e of
+    Left e1 -> f1 e1
+    Right e2 -> f2 e2
+    
+eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
+eitherCoreOrExprArgs args = mapM (eitherM (\x -> MonadState.lift vsType $ (varToVHDLExpr (exprToVar x))) idM) args
 
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be variables.
@@ -79,34 +88,34 @@ genExprRes wrap dst func args = do
 
 -- | Generate a binary operator application. The first argument should be a
 -- constructor from the AST.Expr type, e.g. AST.And.
-genOperator2 :: TypeState -> (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder 
-genOperator2 ty_state op = (genExprArgs ty_state) $ genExprRes (genOperator2' op)
+genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder 
+genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
 
 -- | Generate a unary operator application
-genOperator1 :: TypeState -> (AST.Expr -> AST.Expr) -> BuiltinBuilder 
-genOperator1 ty_state op = (genExprArgs ty_state) $ genExprRes (genOperator1' op)
+genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder 
+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
 
 -- | Generate a unary operator application
-genNegation :: TypeState -> BuiltinBuilder 
-genNegation ty_state = genVarArgs $ genExprRes (genNegation' ty_state)
-genNegation' :: TypeState -> dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
-genNegation' ty_state _ f [arg] = return $ op ((varToVHDLExpr ty_state) arg)
-  where
-    ty = Var.varType arg
-    (tycon, args) = Type.splitTyConApp ty
-    name = Name.getOccString (TyCon.tyConName tycon)
-    op = case name of
-      "SizedInt" -> AST.Neg
-      otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name 
+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)
-genFCall :: TypeState -> Bool -> BuiltinBuilder 
-genFCall ty_state switch = (genExprArgs ty_state) $ genExprRes (genFCall' switch)
+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
@@ -116,8 +125,8 @@ genFCall' switch (Left res) f args = do
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
-genFromSizedWord :: TypeState -> BuiltinBuilder
-genFromSizedWord ty_state = (genExprArgs ty_state) $ genExprRes genFromSizedWord'
+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
@@ -198,23 +207,29 @@ genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
   }
 
-genFoldl :: TypeState -> BuiltinBuilder
-genFoldl ty_state = genFold ty_state True
+genFoldl :: BuiltinBuilder
+genFoldl = genFold True
+
+genFoldr :: BuiltinBuilder
+genFoldr = genFold False
+
+genFold :: Bool -> BuiltinBuilder
+genFold left = genVarArgs (genFold' left)
 
-genFoldr :: TypeState -> BuiltinBuilder
-genFoldr ty_state = genFold ty_state False
+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 :: TypeState -> Bool -> BuiltinBuilder
-genFold ty_state left = genVarArgs (genFold' ty_state left)
-genFold' :: TypeState -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+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' ty_state left (Left res) _ [_, start, vec] | len == 0 = return [mkUncondAssign (Left res) ((varToVHDLExpr ty_state) start)]
-  where 
-    len = State.evalState (tfp_to_int $ (tfvec_len_ty . Var.varType) vec) ty_state
+genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
+  arg <- MonadState.lift vsType $ varToVHDLExpr start
+  return [mkUncondAssign (Left res) arg]
     
-genFold' ty_state left (Left res) f [folded_f, start, vec] = do
+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
+  --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
@@ -262,7 +277,7 @@ genFold' ty_state left (Left res) f [folded_f, start, vec] = do
       -- Output to tmp[current n]
       let resname = mkIndexedName tmp_name n_cur
       -- Input from start
-      let argexpr1 = (varToVHDLExpr ty_state) 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
@@ -389,27 +404,33 @@ genConcat' (Left res) f args@[arg] = do {
     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
                             (AST.ToRange init last))
 
-genIteraten :: TypeState -> BuiltinBuilder
-genIteraten ty_state dst f args = genIterate ty_state dst f (tail args)
+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)
 
-genIterate :: TypeState -> BuiltinBuilder
-genIterate ty_state = genIterateOrGenerate ty_state True
+genGenerate :: BuiltinBuilder
+genGenerate = genIterateOrGenerate False
 
-genGeneraten :: TypeState -> BuiltinBuilder
-genGeneraten ty_state dst f args = genGenerate ty_state dst f (tail args)
+genIterateOrGenerate :: Bool -> BuiltinBuilder
+genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
 
-genGenerate :: TypeState -> BuiltinBuilder
-genGenerate ty_state = genIterateOrGenerate ty_state False
+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 :: TypeState -> Bool -> BuiltinBuilder
-genIterateOrGenerate ty_state iter = genVarArgs (genIterateOrGenerate' ty_state iter)
-genIterateOrGenerate' :: TypeState -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+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' ty_state iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
-    where len = State.evalState (tfp_to_int $ (tfvec_len_ty . Var.varType) res) ty_state
-genIterateOrGenerate' ty_state iter (Left res) f [app_f, start] = do
+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)
+  -- 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
@@ -451,7 +472,7 @@ genIterateOrGenerate' ty_state iter (Left res) f [app_f, start] = do
       -- Output to tmp[current n]
       let resname = mkIndexedName tmp_name n_cur
       -- Input from start
-      let argexpr = (varToVHDLExpr ty_state) 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
@@ -483,14 +504,14 @@ genApplication ::
   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
   -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
 genApplication dst f args = do
-  ty_state <- getA vsType
   case Var.globalIdVarDetails f of
     IdInfo.DataConWorkId dc -> case dst of
       -- It's a datacon. Create a record from its arguments.
       Left bndr -> do
         -- We have the bndr, so we can get at the type
         labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
-        return $ zipWith mkassign labels $ map (either (exprToVHDLExpr ty_state) id) args
+        args' <- eitherCoreOrExprArgs args
+        return $ zipWith mkassign labels $ args'
         where
           mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
           mkassign label arg =
@@ -503,7 +524,7 @@ genApplication dst f args = do
       -- 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 ty_state)) of
+      case (Map.lookup (varToString f) globalNameTable) of
         Just (arg_count, builder) ->
           if length args == arg_count then
             builder dst f args
@@ -515,28 +536,28 @@ genApplication dst f args = do
       -- This is a local id, so it should be a function whose definition we
       -- have and which can be turned into a component instantiation.
       case (Map.lookup f signatures) of
-        Just signature -> let
+        Just signature -> do
+          args' <- eitherCoreOrExprArgs args
           -- We have a signature, this is a top level binding. Generate a
           -- component instantiation.
-          entity_id = ent_id signature
+          let 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 prettyShow) dst
-          portmaps = mkAssocElems (map (either (exprToVHDLExpr ty_state) id) args) ((either varToVHDLName id) dst) signature
-          in
-            return [mkComponentInst label entity_id portmaps]
+          let label = "comp_ins_" ++ (either show prettyShow) dst
+          let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+          return [mkComponentInst label entity_id portmaps]
         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.
-          ty_state <- getA vsType
-          return $ [mkUncondAssign dst ((varToVHDLExpr ty_state) f)]
+          f' <- MonadState.lift vsType $ varToVHDLExpr f
+          return $ [mkUncondAssign dst 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 ty_state)) of
+      case (Map.lookup (varToString f) globalNameTable) of
         Just (arg_count, builder) ->
           if length args == arg_count then
             builder dst f args
@@ -959,50 +980,50 @@ genUnconsVectorFuns elemTM vectorTM  =
 
 -- | The builtin functions we support. Maps a name to an argument count and a
 -- builder function.
-globalNameTable :: TypeState -> NameTable
-globalNameTable ty_state = Map.fromList
-  [ (exId             , (2, genFCall ty_state False         ) )
-  , (replaceId        , (3, genFCall ty_state False         ) )
-  , (headId           , (1, genFCall ty_state True          ) )
-  , (lastId           , (1, genFCall ty_state True          ) )
-  , (tailId           , (1, genFCall ty_state False         ) )
-  , (initId           , (1, genFCall ty_state False         ) )
-  , (takeId           , (2, genFCall ty_state False         ) )
-  , (dropId           , (2, genFCall ty_state False         ) )
-  , (selId            , (4, genFCall ty_state False         ) )
-  , (plusgtId         , (2, genFCall ty_state False         ) )
-  , (ltplusId         , (2, genFCall ty_state False         ) )
-  , (plusplusId       , (2, genFCall ty_state False         ) )
-  , (mapId            , (2, genMap                          ) )
-  , (zipWithId        , (3, genZipWith                      ) )
-  , (foldlId          , (3, genFoldl ty_state               ) )
-  , (foldrId          , (3, genFoldr ty_state               ) )
-  , (zipId            , (2, genZip                          ) )
-  , (unzipId          , (1, genUnzip                        ) )
-  , (shiftlId         , (2, genFCall ty_state False         ) )
-  , (shiftrId         , (2, genFCall ty_state False         ) )
-  , (rotlId           , (1, genFCall ty_state False         ) )
-  , (rotrId           , (1, genFCall ty_state False         ) )
-  , (concatId         , (1, genConcat                       ) )
-  , (reverseId        , (1, genFCall ty_state False         ) )
-  , (iteratenId       , (3, genIteraten ty_state            ) )
-  , (iterateId        , (2, genIterate ty_state             ) )
-  , (generatenId      , (3, genGeneraten ty_state           ) )
-  , (generateId       , (2, genGenerate ty_state            ) )
-  , (emptyId          , (0, genFCall ty_state False         ) )
-  , (singletonId      , (1, genFCall ty_state False         ) )
-  , (copynId          , (2, genFCall ty_state False         ) )
-  , (copyId           , (1, genCopy                         ) )
-  , (lengthTId        , (1, genFCall ty_state False         ) )
-  , (nullId           , (1, genFCall ty_state False         ) )
-  , (hwxorId          , (2, genOperator2 ty_state AST.Xor   ) )
-  , (hwandId          , (2, genOperator2 ty_state AST.And   ) )
-  , (hworId           , (2, genOperator2 ty_state AST.Or    ) )
-  , (hwnotId          , (1, genOperator1 ty_state AST.Not   ) )
-  , (plusId           , (2, genOperator2 ty_state (AST.:+:) ) )
-  , (timesId          , (2, genOperator2 ty_state (AST.:*:) ) )
-  , (negateId         , (1, genNegation ty_state            ) )
-  , (minusId          , (2, genOperator2 ty_state (AST.:-:) ) )
-  , (fromSizedWordId  , (1, genFromSizedWord ty_state       ) )
-  , (fromIntegerId    , (1, genFromInteger                  ) )
+globalNameTable :: NameTable
+globalNameTable = Map.fromList
+  [ (exId             , (2, genFCall False          ) )
+  , (replaceId        , (3, genFCall False          ) )
+  , (headId           , (1, genFCall True           ) )
+  , (lastId           , (1, genFCall True           ) )
+  , (tailId           , (1, genFCall False          ) )
+  , (initId           , (1, genFCall False          ) )
+  , (takeId           , (2, genFCall False          ) )
+  , (dropId           , (2, genFCall False          ) )
+  , (selId            , (4, genFCall False          ) )
+  , (plusgtId         , (2, genFCall False          ) )
+  , (ltplusId         , (2, genFCall False          ) )
+  , (plusplusId       , (2, genFCall False          ) )
+  , (mapId            , (2, genMap                  ) )
+  , (zipWithId        , (3, genZipWith              ) )
+  , (foldlId          , (3, genFoldl                ) )
+  , (foldrId          , (3, genFoldr                ) )
+  , (zipId            , (2, genZip                  ) )
+  , (unzipId          , (1, genUnzip                ) )
+  , (shiftlId         , (2, genFCall False          ) )
+  , (shiftrId         , (2, genFCall False          ) )
+  , (rotlId           , (1, genFCall False          ) )
+  , (rotrId           , (1, genFCall False          ) )
+  , (concatId         , (1, genConcat               ) )
+  , (reverseId        , (1, genFCall False          ) )
+  , (iteratenId       , (3, genIteraten             ) )
+  , (iterateId        , (2, genIterate              ) )
+  , (generatenId      , (3, genGeneraten            ) )
+  , (generateId       , (2, genGenerate             ) )
+  , (emptyId          , (0, genFCall False          ) )
+  , (singletonId      , (1, genFCall False          ) )
+  , (copynId          , (2, genFCall False          ) )
+  , (copyId           , (1, genCopy                 ) )
+  , (lengthTId        , (1, genFCall False          ) )
+  , (nullId           , (1, genFCall False          ) )
+  , (hwxorId          , (2, genOperator2 AST.Xor    ) )
+  , (hwandId          , (2, genOperator2 AST.And    ) )
+  , (hworId           , (2, genOperator2 AST.Or     ) )
+  , (hwnotId          , (1, genOperator1 AST.Not    ) )
+  , (plusId           , (2, genOperator2 (AST.:+:)  ) )
+  , (timesId          , (2, genOperator2 (AST.:*:)  ) )
+  , (negateId         , (1, genNegation             ) )
+  , (minusId          , (2, genOperator2 (AST.:-:)  ) )
+  , (fromSizedWordId  , (1, genFromSizedWord        ) )
+  , (fromIntegerId    , (1, genFromInteger          ) )
   ]

diff --git a/VHDL.hs b/VHDL.hs
index 2ac2a12aaffb0a74d6303053f97d871eabdd7775..03859095b8f8fb4158f4d8965b536b354ad46a22 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -286,14 +286,13 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
 -- binders in the alts and only variables in the case values and a variable
 -- for a scrutinee. We check the constructor of the second alt, since the
 -- first is the default case, if there is any.
-mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do {
-  ; ty_state <- getA vsType
-  ; let { cond_expr = (varToVHDLExpr ty_state scrut) AST.:=: (altconToVHDLExpr con)
-        ; true_expr  = (varToVHDLExpr ty_state true)
-        ; false_expr  = (varToVHDLExpr ty_state false)
-        } ;
-  ; return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
-  }
+mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
+  scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
+  let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
+  true_expr <- MonadState.lift vsType $ varToVHDLExpr true
+  false_expr <- MonadState.lift vsType $ varToVHDLExpr false
+  return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
+
 mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr

diff --git a/VHDLTools.hs b/VHDLTools.hs
index e7c598d498d322222821bdaf091422ca778e5f96..2d36049d1f3572d9eca43e3e05d45dfe41e7547c 100644 (file)
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -122,11 +122,10 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 -- Functions to generate VHDL Exprs
 -----------------------------------------------------------------------------
 
--- Turn a variable reference into a AST expression
-varToVHDLExpr :: TypeState -> Var.Var -> AST.Expr
-varToVHDLExpr ty_state var =
+varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
+varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of
-    Just dc -> dataconToVHDLExpr dc
+    Just dc -> return $ dataconToVHDLExpr dc
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
@@ -134,17 +133,15 @@ varToVHDLExpr ty_state var =
     -- should still be translated to integer literals. It is probebly not the
     -- best solution to translate them here.
     -- FIXME: Find a better solution for translating instances of tfp integers
-    Nothing ->
-        let 
-          ty  = Var.varType var
-          res = case Type.splitTyConApp_maybe ty of
-                  Just (tycon, args) ->
-                    case Name.getOccString (TyCon.tyConName tycon) of
-                      "Dec" -> AST.PrimLit $ (show (fst ( State.runState (tfp_to_int ty) ty_state ) ) )
-                      otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
-        in
-          res
-
+    Nothing -> do
+        let ty  = Var.varType var
+        case Type.splitTyConApp_maybe ty of
+                Just (tycon, args) ->
+                  case Name.getOccString (TyCon.tyConName tycon) of
+                    "Dec" -> do
+                      len <- tfp_to_int ty
+                      return $ AST.PrimLit $ (show len)
+                    otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var
 
 -- Turn a VHDLName into an AST expression
 vhdlNameToVHDLExpr = AST.PrimName
@@ -153,7 +150,7 @@ vhdlNameToVHDLExpr = AST.PrimName
 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 
 -- Turn a Core expression into an AST expression
-exprToVHDLExpr ty_state = (varToVHDLExpr ty_state) . exprToVar
+exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
 
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it