IMP in Haskell

Martin Sulzmann

Overview

Use Haskell to implement other languages

Haskell is a great language to implement other languages. Here we show how to implement IMP = a simple imperative language.

We use algebraic data types to represent the abstract syntax of IMP. We provide for an interpreter as well a compiler that translates to a stack-based virtual machine.

Main Haskell features used are:

Use Haskell to embed other languages

Another great feature of Haskell is to serve as a host to embed other languages. We use IMP as an example of an embedded domain-specific language (EDSL).

To write IMP programs, we have to specify its syntax directly in terms of the abstract syntax (the Exp data type). This is rather clumsy and error prone (no type checking).

We use Haskell’s advanced typing featuers to embed IMP into Haskell. Thus, there’s no need to write a separate parser and type checker. The advantage is that we can use of the host language Haskell to add further features to IMP.

Main Haskell features used are:

Main

Source code

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

import Prelude hiding ((==),(<), (-), (+), (*), (/), (&&), (!), (>>), print)
import EDSL
import qualified Interpreter as I
import qualified VM
import qualified Compiler as C

-- Examples

-- We need the type annotatons because 1 could be any number (Int, Float, ...)
ex1 = (1 :: Int) == (2 :: Int)


ex2 = True && ex1


-- We make use of parentheses that are not explicitly available in Exp.
ex3 = ((1 :: Int) + (2 :: Int)) * (3 :: Int)


x = var int "x"

ex5 = (1 :: Int) < x



cmd1 = let x = var int "x"
       in new x (1 :: Int) (print x)

cmd1b = let x = var int "x"
        in new x (1 :: Int) $
              print x
              >>
              x =:= x - (1::Int)
              >>
              print x

cmd2 = let x = var int "x"
       in new x (1 :: Int) $
             print x
             >>
             ifThenElse (x < (2 :: Int))
                        (print x)
                        skip


cmd2b = let x = var int "x"
        in new x (1 :: Int)
            (while (x < (10 :: Int))
                   skip)


cmd3 = let x = var int "x"
       in new x (1 :: Int)
            (while (x < (10 :: Int)) $
                   x =:= x + (1::Int)
                   >>
                   print x)


-- | Some derived EDSL commands.
-- print only accepts variables as arguments.
-- We introduce two further primitives that allow to print Integer/Boolean expressions.
printInt v = let x = var int "x"
             in new x v $ print x

printBool v = let x = var int "x"
              in new x v $ print x



eval = I.run

compileAndExecute cmd = do let code = C.compile cmd
                           VM.run code


-- Further design issues
-- A type error manifests itself as an unresolved instance


{-

-- Yields
-- No instance for (EXPOrd Int Bool c0) arising from a use of ‘==’
illTypedExpression = (1 :: Int) == True

-}


-- Instead of reporting IMP type errors as unresolved type class errors,
-- we could resolve such errors by providing additional instances.

instance EXPOrd Bool Int (ExpTy Bool) where
  (==) _ _ = error "Type error == \n mismatch between left operand (Bool) and right operand (Int)"
  (<) _ _ = error "Type error < \n mismatch between left operand (Bool) and right operand (Int)"


illTypedExpression2 = True == (1 :: Int)

{-

Showing the above expression yields

*** Exception: Type error ==
 mismatch between left operand (Bool) and right operand (Int)

-}

Abstract syntax

Source code

-- Abstract syntax of IMP

module Syntax where

type Var = String
data Values = N Int | BTrue | BFalse deriving Show

data Exp = Val Values | Id Var | Plus Exp Exp | Minus Exp Exp | Times Exp Exp
         | Div Exp Exp | Equal Exp Exp | LessThan Exp Exp | And Exp Exp | Not Exp deriving Show

data Cmd = Skip | Assign Var Exp | Seq Cmd Cmd | ITE Exp Cmd Cmd
         | While Exp Cmd | Newvar Var Exp Cmd | Print Var
         deriving Show

EDSL

High-level overview.

Introduce a phantom type to turn the untyped representation of expressions into a typed expression.

data ExpTy a = MkEx Exp

The type parameter a keeps track of the type of an expression. In our case, a is either Int or Bool. The construction is called a phantom type because a only appears at the level of types (left-hand side of data type definition) but is not used at the level of terms/programs (right-hand side of data type definition).

Encode typing rules via type classes

   |- e1 : Int   |- e2 : Int
  ---------------------------
   |- e1 + e2 : Int

Introduce a type class

class EXPInt a b c | a b -> c where
  (+) :: a -> b -> c

The functional dependency is used to compute the result c.

We distinguish between

Here’s a selection of instances

instance ExpInt (ExpTy Int) (ExpTy Int) (ExpTy Int)
instance ExpInt (VarTy Int) (ExpTy Int) (ExpTy Int)
instance ExpInt Int (ExpTy Int) (ExpTy Int)

and so on.

Source code

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}

module EDSL where

import Prelude hiding ((==),(<), (-), (+), (*), (/), (&&), (!))

import Syntax

-- Helpers

mkInt :: Int -> Exp
mkInt i = Val (N i)

mkBool :: Bool -> Exp
mkBool True = Val BTrue
mkBool False = Val BFalse


-- Strongly typed interface
----------------------------------------

-- Phantom type

data ExpTy a = MkEx Exp deriving Show
unMk (MkEx e) = e

data VarTy a = MkVar Var
unVar (MkVar e) = e

mkIntTy :: Int -> ExpTy Int
mkIntTy i = MkEx $ Val $ N i

mkBoolTy :: Bool -> ExpTy Bool
mkBoolTy True = MkEx $ Val BTrue
mkBoolTy False = MkEx $ Val BFalse

-- variables

int :: Int
int = undefined

bool :: Bool
bool = undefined

varToE :: VarTy a -> ExpTy a
varToE (MkVar x) = MkEx (Id x)

class VAR a where
  var :: a -> String -> VarTy a

instance VAR Int where
  var _ x = MkVar x

instance VAR Bool where
  var _ x = MkVar x

-- expressions

-- infixr 6 -, +
infixr 7 *,/
class EXPInt a b c | a b -> c where
  (-) :: a -> b -> c
  (+) :: a -> b -> c
  (*) :: a -> b -> c
  (/) :: a -> b -> c

class EXPBool a b c | a b -> c where
  (&&) :: a -> b -> c

class EXPOrd a b c | a b -> c where
  (==) :: a -> b -> c
  (<) :: a -> b -> c

class NOT a b | a -> b where
  (!) :: a -> b

-- commands

infix 5 =:=
(=:=) :: VarTy a -> ExpTy a -> Cmd
(=:=) (MkVar x)  e = Assign x (unMk e)

infixr 4 >>
(>>) :: Cmd -> Cmd -> Cmd
(>>) c1 c2 = Seq c1 c2

while :: ExpTy Bool -> Cmd -> Cmd
while e c = While (unMk e) c

print :: (VarTy a) -> Cmd
print (MkVar x) = Print x

ifThenElse :: ExpTy Bool -> Cmd -> Cmd -> Cmd
ifThenElse e c1 c2 = ITE (unMk e) c1 c2

skip :: Cmd
skip = Skip

class NEW a b where
  new :: a -> b -> Cmd -> Cmd

instance NEW (VarTy a) (ExpTy a) where
  new (MkVar x) e c = Newvar x (unMk e) c

instance NEW (VarTy Int) Int where
  new (MkVar x) i c = Newvar x (mkInt i) c

instance NEW (VarTy Bool) Bool where
  new (MkVar x) b c = Newvar x (mkBool b) c



-- Instances
------------------

-- Negation

instance NOT Bool (ExpTy Bool) where
  (!) b = MkEx $ Not $ mkBool b

instance NOT (ExpTy Bool) (ExpTy Bool) where
  (!) e = MkEx $ Not $ unMk e

-- Integer expressions
-- Consider all combinations of (ExpTy Int), (VarTy Int) and Int.

instance EXPInt (ExpTy Int) (ExpTy Int) (ExpTy Int) where
  (-) e1 e2  = MkEx $ Minus (unMk e1) (unMk e2)
  (+) e1 e2  = MkEx $ Plus (unMk e1) (unMk e2)
  (*) e1 e2  = MkEx $ Times (unMk e1) (unMk e2)
  (/) e1 e2  = MkEx $ Div (unMk e1) (unMk e2)

instance EXPInt (ExpTy Int) (ExpTy Int) (ExpTy Int) => EXPInt Int (ExpTy Int) (ExpTy Int) where
  (-) i e  = (-) (mkIntTy i) e
  (+) i e  = (+) (mkIntTy i) e
  (*) i e  = (*) (mkIntTy i) e
  (/) i e  = (/) (mkIntTy i) e

instance EXPInt Int (ExpTy Int) (ExpTy Int) => EXPInt (ExpTy Int) Int (ExpTy Int) where
  (-) e i  = (-) i e
  (+) e i  = (+) i e
  (*) e i  = (*) i e
  (/) e i  = (/) i e

-- We map (Int, Int) to (ExpTy Int, ExpTy Int).
-- We could also map (Int, Int) to (ExpTy Int, Int) which would save some code in the method definitions.
instance EXPInt (ExpTy Int) (ExpTy Int) (ExpTy Int) => EXPInt Int Int (ExpTy Int) where
  (-) i1 i2 = (-) (mkIntTy i1) (mkIntTy i2)
  (+) i1 i2 = (+) (mkIntTy i1) (mkIntTy i2)
  (*) i1 i2 = (*) (mkIntTy i1) (mkIntTy i2)
  (/) i1 i2 = (/) (mkIntTy i1) (mkIntTy i2)

instance EXPInt (ExpTy Int) (ExpTy Int) (ExpTy Int) => EXPInt (VarTy Int) (ExpTy Int) (ExpTy Int) where
  (-) v e  = (-) (varToE v) e
  (+) v e  = (+) (varToE v) e
  (*) v e  = (*) (varToE v) e
  (/) v e  = (/) (varToE v) e

instance EXPInt (VarTy Int) (ExpTy Int) (ExpTy Int) => EXPInt (ExpTy Int) (VarTy Int) (ExpTy Int) where
  (-) e v = (-) v e
  (+) e v = (+) v e
  (*) e v = (*) v e
  (/) e v = (/) v e

instance EXPInt (VarTy Int) (ExpTy Int) (ExpTy Int) => EXPInt (VarTy Int) (VarTy Int) (ExpTy Int) where
  (-) v1 v2 = (-) v1 (varToE v2)
  (+) v1 v2 = (+) v1 (varToE v2)
  (*) v1 v2 = (*) v1 (varToE v2)
  (/) v1 v2 = (/) v1 (varToE v2)

instance EXPInt (ExpTy Int) Int (ExpTy Int) => EXPInt (VarTy Int) Int (ExpTy Int) where
  (-) v i = (-) (varToE v) i
  (+) v i = (+) (varToE v) i
  (*) v i = (*) (varToE v) i
  (/) v i = (/) (varToE v) i

instance EXPInt (VarTy Int) Int (ExpTy Int) => EXPInt Int (VarTy Int) (ExpTy Int) where
  (-) i v = (-) v i
  (+) i v = (+) v i
  (*) i v = (*) v i
  (/) i v = (/) v i

-- Boolean expressions:
-- Consider all combinations of (ExpTy Bool), (VarTy Bool) and Bool.

instance EXPBool (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) where
  (&&) e1 e2 = MkEx $ And (unMk e1) (unMk e2)

instance EXPBool (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPBool Bool (ExpTy Bool) (ExpTy Bool) where
  (&&) b e = (&&) (mkBoolTy b) e

instance EXPBool (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPBool (ExpTy Bool) Bool (ExpTy Bool) where
  (&&) e b = (&&) e (mkBoolTy b)

instance EXPBool (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPBool Bool Bool (ExpTy Bool) where
  (&&) b1 b2 = (&&) (mkBoolTy b1) (mkBoolTy b2)

instance EXPBool (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPBool (VarTy Bool) (ExpTy Bool) (ExpTy Bool) where
  (&&) v b = (&&) (varToE v) b

instance EXPBool (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPBool (ExpTy Bool) (VarTy Bool) (ExpTy Bool) where
  (&&) b v = (&&) b (varToE v)

instance EXPBool (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPBool (VarTy Bool) (VarTy Bool) (ExpTy Bool) where
  (&&) v1 v2 = (&&) (varToE v1) (varToE v2)

instance EXPBool (ExpTy Bool) Bool (ExpTy Bool) => EXPBool (VarTy Bool) Bool (ExpTy Bool) where
  (&&) v b = (&&) (varToE v) b

instance EXPBool Bool (ExpTy Bool) (ExpTy Bool) => EXPBool Bool (VarTy Bool) (ExpTy Bool) where
  (&&) b v = (&&) b (varToE v)

-- Ordering expressions
-- Consider all combinations.

-- int cases
instance EXPOrd (ExpTy Int) (ExpTy Int) (ExpTy Bool) where
  (==) e1 e2 = MkEx $ Equal (unMk e1) (unMk e2)
  (<) e1 e2 = MkEx $ LessThan (unMk e1) (unMk e2)

instance EXPOrd (ExpTy Int) (ExpTy Int) (ExpTy Bool) => EXPOrd Int (ExpTy Int) (ExpTy Bool) where
  (==) i e = (==) (mkIntTy i) e
  (<) i e = (<) (mkIntTy i) e

instance EXPOrd (ExpTy Int) (ExpTy Int) (ExpTy Bool) => EXPOrd (ExpTy Int) Int (ExpTy Bool) where
  (==) e i = (==) e (mkIntTy i)
  (<) e i = (<) e (mkIntTy i)

instance EXPOrd (ExpTy Int) (ExpTy Int) (ExpTy Bool) => EXPOrd Int Int (ExpTy Bool) where
  (==) i1 i2 = (==) (mkIntTy i1) (mkIntTy i2)
  (<) i1 i2 = (<) (mkIntTy i1) (mkIntTy i2)

instance EXPOrd (ExpTy Int) (ExpTy Int) (ExpTy Bool) => EXPOrd (VarTy Int) (ExpTy Int) (ExpTy Bool) where
  (==) v e = (==) (varToE v) e
  (<) v e = (<) (varToE v) e

instance EXPOrd (ExpTy Int) (ExpTy Int) (ExpTy Bool) => EXPOrd (ExpTy Int) (VarTy Int) (ExpTy Bool) where
  (==) e v = (==) e (varToE v)
  (<) e v = (<) e (varToE v)

instance EXPOrd (ExpTy Int) (ExpTy Int) (ExpTy Bool) => EXPOrd (VarTy Int) (VarTy Int) (ExpTy Bool) where
  (==) v1 v2 = (==) (varToE v1) (varToE v2)
  (<) v1 v2 = (<) (varToE v1) (varToE v2)

instance EXPOrd (ExpTy Int) Int (ExpTy Bool) => EXPOrd (VarTy Int) Int (ExpTy Bool) where
  (==) v i = (==) (varToE v) i
  (<) v i = (<) (varToE v) i

instance EXPOrd Int (ExpTy Int) (ExpTy Bool) => EXPOrd Int (VarTy Int) (ExpTy Bool) where
  (==) i v = (==) i (varToE v)
  (<) i v = (<) i (varToE v)

-- bool cases
instance EXPOrd (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) where
  (==) e1 e2 = MkEx $ Equal (unMk e1) (unMk e2)
  (<) e1 e2 = MkEx $ LessThan (unMk e1) (unMk e2)

instance EXPOrd (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPOrd Bool (ExpTy Bool) (ExpTy Bool) where
  (==) b e = (==) (mkBoolTy b) e
  (<) b e = (<) (mkBoolTy b) e

instance EXPOrd (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPOrd (ExpTy Bool) Bool (ExpTy Bool) where
  (==) e b = (==) e (mkBoolTy b)
  (<) e b = (<) e (mkBoolTy b)

instance EXPOrd (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPOrd Bool Bool (ExpTy Bool) where
  (==) b1 b2 = (==) (mkBoolTy b1) (mkBoolTy b2)
  (<) b1 b2 = (<) (mkBoolTy b1) (mkBoolTy b2)

instance EXPOrd (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPOrd (VarTy Bool) (ExpTy Bool) (ExpTy Bool) where
  (==) v e = (==) (varToE v) e
  (<) v e = (<) (varToE v) e

-- Just for fun we map the case (ExpTy Bool, VarTyBool) to (VarTyBool, ExpTyBool).
instance EXPOrd (VarTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPOrd (ExpTy Bool) (VarTy Bool) (ExpTy Bool) where
  (==) e v = (==) v e
  (<) e v = (<) v e

instance EXPOrd (ExpTy Bool) (ExpTy Bool) (ExpTy Bool) => EXPOrd (VarTy Bool) (VarTy Bool) (ExpTy Bool) where
  (==) v1 v2 = (==) (varToE v1) (varToE v2)
  (<) v1 v2 = (<) (varToE v1) (varToE v2)

instance EXPOrd (ExpTy Bool) Bool (ExpTy Bool) => EXPOrd (VarTy Bool) Bool (ExpTy Bool) where
  (==) v b = (==) (varToE v) b
  (<) v b = (<) (varToE v) b

-- Here we map (Bool, VarTy Bool) to (Bool, ExpTy Bool).
instance EXPOrd Bool (ExpTy Bool) (ExpTy Bool) => EXPOrd Bool (VarTy Bool) (ExpTy Bool) where
  (==) b v = (==) b (varToE v)
  (<) b v = (<) b (varToE v)

Interpreter

Source code

-- Operatonal big-step semantics (interpreter)

module Interpreter where

import Control.Monad
import Control.Monad.State
import Control.Monad.Trans

import Syntax


----------------------
-- state operations --
----------------------

-- | We don't check if

type VarState = [(Var, Values)]

lookupVar :: VarState -> Var -> Values
lookupVar s id = case (lookup id s) of
                    Just v -> v

-- | We simply add the new binding to the front.
addVarState :: VarState -> Var -> Values -> VarState
addVarState s id v = (id, v) : s


-- | Update binding.
updateVarState :: VarState -> Var -> Values -> VarState
updateVarState [] id v = []
updateVarState ((id',v'):s) id v
  | id' == id = (id,v) : s
  | otherwise = (id',v') : updateVarState s id v


-- | We remove the first binding of id.
-- Any later (in the last) bindings of id will be kept.
-- This is useful to in case of 'newvar' where we temporarily add a binding,
-- and then remove this binding again.
removeVarState :: VarState -> Var -> VarState
removeVarState [] _ = []
removeVarState ((id,v):s) id'
   | id == id' = s
   | otherwise = (id,v) : removeVarState s id'

--------------------------
-- expression semantics --
--------------------------


-- | Evaluation of expressions is pure
evalExp :: VarState -> Exp -> Values
evalExp _ (Val v) = v
evalExp s (Id id) = lookupVar s id
evalExp s (Plus e1 e2) = let (N i1) = evalExp s e1
                             (N i2) = evalExp s e2
                         in N (i1 + i2)
evalExp s (Minus e1 e2) = let (N i1) = evalExp s e1
                              (N i2) = evalExp s e2
                          in N (i1 - i2)
evalExp s (Times e1 e2) = let (N i1) = evalExp s e1
                              (N i2) = evalExp s e2
                          in N (i1 * i2)
evalExp s (Div e1 e2) = let (N i1) = evalExp s e1
                            (N i2) = evalExp s e2
                        in if i2 /= 0
                           then N (i1 * i2)
                           else undefined
evalExp s (Equal e1 e2) = let v1 = evalExp s e1
                              v2 = evalExp s e2
                              eqB BTrue BTrue = BTrue
                              eqB BFalse BFalse = BTrue
                              eqB _ _ = BFalse
                              eqInt i1 i2
                                | i1 == i2  = BTrue
                                | otherwise = BFalse
                          in case v1 of
                              N i1   -> case v2 of
                                         N   i2 -> eqInt i1 i2
                                         _      -> error "Equal: Incompatible operands"
                              _      -> case v2 of
                                         N _   -> error "Equal: Incompatible operands"
                                         _     -> eqB v1 v2
evalExp s (LessThan e1 e2) = let (N i1) = evalExp s e1
                                 (N i2) = evalExp s e2
                             in if i1 < i2
                                then BTrue
                                else BFalse

-----------------------
-- command semantics --
-----------------------

-- | We need IO because of print.
type EVAL a = StateT VarState IO a

evalCmd :: Cmd -> EVAL()
evalCmd Skip = return ()
evalCmd (Print id) = do s <- get
                        let x = lookupVar s id
                        let showValues (N i) = show i
                            showValues BTrue = "true"
                            showValues BFalse = "false"
                        liftIO $ putStrLn (showValues x)
                        return ()
evalCmd (Assign id e) = do s <- get
                           let s' = updateVarState s id (evalExp s e)
                           put s'
                           return ()
evalCmd (Seq c1 c2) = do evalCmd c1
                         evalCmd c2

evalCmd (ITE e c1 c2) = do s <- get
                           let v = evalExp s e
                           case v of
                             BTrue  -> evalCmd c1
                             BFalse -> evalCmd c2
                             _      -> error "ITE: invalid condition"
evalCmd (While e c) = do s <- get
                         let v = evalExp s e
                         case v of
                            BFalse -> return ()
                            BTrue  -> do evalCmd c
                                         evalCmd (While e c)
                            _      -> error "While: invalid condition"
evalCmd (Newvar id e c) = do s <- get
                             let s' = addVarState s id (evalExp s e)
                             put s'
                             evalCmd c
                             s'' <- get
                             put $ removeVarState s'' id


run :: Cmd -> IO VarState
run cmd = do (_,s) <- runStateT (evalCmd cmd) []
             return s

We assume a linear address space where variables are stored in memory. All values are integers. That is, the Boolean value true is represented by 1 and false by 0. Compuations take place on a stack. The definitions of memory and stack are as follows.

type Mem = [Int]
type Stack = [Int]

The VM supports the following instructions

data Instruction = Add | Sub | Lt | Gt | Div | Mult | Eq
                 | Push Int
                 | Lbl Label | NonZero Label | Zero Label
                 | Jump Label
                 | Dref Location | Asg Location deriving Show
type Label = Int
type Location = Int

Program code is a sequence of instructions (i.e. a list in Haskell)

type Code = [Instruction]

The VM state is a pair consisting of the stack and memory.

type VMState = (Stack, Mem)

VM instructions are interpreted.

interp :: Code -> Code -> State VMState ()

The first parameter of interp is the to be interpreted program code and the second argument is the program counter (PC). The PC is simply a sequence of instructions where the first instruction corresponds to the current point of execution. See below for details.

Source


-- A simple stack-based virtual machine

module VM where

import Control.Monad
import Control.Monad.State
import Control.Monad.Trans

-- linear address space
-- variables stored on (pre-allocated) heap
-- values are all Ints
-- represent true by 1 and false by 0

type Label = Int
type Location = Int

-- Memory starts at location 0 !!!
type Mem = [Int]

-- computations performed on stack
type Stack = [Int]

-- VM instructions

-- Add, Minus, Lt, Gt, Div, Mult, Eq
-- operands are poped from stack (op1 top-most element),
-- result (op1 op op 2) is pushed onto stack

-- Push value
-- push value onto stack

-- Lbl l
-- introduces label l, skip statement

-- NonZero l, Zero l
-- jump to location l if poped value is (non)zero

-- Jump l
-- jump to location l

-- Dref l
-- lookup value at location l, push onto stack

-- Asg l
-- assign poped value to location l

data Instruction = Add | Minus | Lt | Gt | Div | Mult | Eq
                 | Push Int
                 | Lbl Label | NonZero Label | Zero Label
                 | Jump Label
                 | Dref Location | Asg Location
                 | Output Location deriving Show


type Code = [Instruction]


type VMState = (Stack, Mem)

type VM a = StateT VMState IO a

-- stack operations

pop :: Stack -> (Int,Stack)
pop [] = error "Empty stack"
pop (x:xs) = (x,xs)

push :: Stack -> Int -> Stack
push xs x = x:xs

top :: Stack -> Int
top [] = error "Empty stack"
top (x:xs) = x

popS :: VM Int
popS = do (s,m) <- get
          let (v,s') = pop s
          put (s',m)
          return v

pushS :: Int -> VM ()
pushS v = do (s,m) <- get
             put (push s v, m)

topS :: VM Int
topS = do (s,_) <- get
          return $ top s


-- memory operations

getValue :: Location -> VM Int
getValue l = do (_,m) <- get
                return (m !! l)

setValue :: Location -> Int -> VM ()
setValue l v = let update (x:xs) 0 v = v:xs
                   update (x:xs) l v = x:(update xs (l-1) v)
                   -- Option: employ exception monad for better error handling
                   update _ _ _      = error "invalid memory location access"
               in do (s,m) <- get
                     put (s, update m l v)


---- Interpreter -----

-- Booleans are represented by Ints
coerce :: Bool -> Int
coerce True = 1
coerce False = 0

-- jump to location l
locate :: Label -> Code -> Code
locate l [] = error "Label not found"
locate l (Lbl l':next)
  | l == l'    = next
  | otherwise  = locate l next
locate l (_:next) = locate l next




-- interpreter pc c runs program c with program counter pc
interp :: Code -> Code -> VM ()
interp [] p = return ()
-- operands are poped from stack, result is pushed onto stack
interp (Add:next) p = do op1 <- popS
                         op2 <- popS
                         pushS (op1 + op2)
                         interp next p
interp (Minus:next) p = do op1 <- popS
                           op2 <- popS
                           pushS (op1 - op2)
                           interp next p
interp (Lt:next) p = do op1 <- popS
                        op2 <- popS
                        pushS (coerce (op1 < op2))
                        interp next p
interp (Gt:next) p = do op1 <- popS
                        op2 <- popS
                        pushS (coerce (op1 > op2))
                        interp next p
interp (Div:next) p = do op1 <- popS
                         op2 <- popS
                         if op2 == 0 then error "divison by zero"
                          else do pushS (op1 `div` op2)
                                  interp next p
interp (Mult:next) p = do op1 <- popS
                          op2 <- popS
                          pushS (op1 * op2)
                          interp next p
interp (Eq:next) p = do op1 <- popS
                        op2 <- popS
                        pushS (coerce (op1 == op2))
                        interp next p
-- push value onto stack
interp ((Push v):next) p = do pushS v
                              interp next p
-- introduces label l, skip statement
interp ((Lbl l):next) p = interp next p
-- jump if poped value is non zero
interp ((NonZero l):next) p = do v <- popS
                                 if not (v == 0) then interp ((Jump l):next) p
                                  else interp next p
-- jump if poped value is zero
interp ((Zero l):next) p = do v <- popS
                              if v == 0 then interp ((Jump l):next) p
                               else interp next p
-- jump to l
interp ((Jump l):next) p = interp (locate l p) p
-- get value at location l, push onto stack
interp ((Dref l):next) p = do v <- getValue l
                              pushS v
                              interp next p
-- assign poped value to location l
interp ((Asg l):next) p = do v <- popS
                             setValue l v
                             interp next p

-- print location
interp ((Output l):next) p = do n <- getValue l
                                liftIO $ putStrLn $ show n
                                interp next p

run :: Code -> IO Stack
run code = let mem :: [Int]
               mem = 0:mem -- memory infinite, initially zero!
               st = []

           in do (_,(st',_)) <- runStateT (interp code code) (st,mem)
                 return st'

Compiler

The compiler performs the following steps:

  1. Rename the program such that each “Newvar” introduces a fresh variable
  2. Assign memory locations to “Newvar” variables
  3. Compile the renamed program
compile :: Cmd -> Code
compile cmd =
  let (cmdFresh,_) = runState (freshNewVar cmd) 1
      (env,_) = runState (memLoc cmdFresh) 1
      (code,_) = runState (compileCmd env cmdFresh) World{lbl = 1}
  in code

We generally assume that only closed programs will be evaluated. That is, all variables are introduced by “Newvar” statements.

Details of the compilation steps are given below.

Source



-- Compile to VM code

module Compiler where

import Control.Monad
import Control.Monad.State

import qualified Syntax as S
import VM


compile :: S.Cmd -> Code
compile cmd =
  let (cmdFresh,_) = runState (freshNewVar cmd) 1
      (env,_) = runState (memLoc cmdFresh) 1
      (code,_) = runState (compileCmd env cmdFresh) World{lbl = 1}
  in code

-- | Rename variables introduced via Newvar such that
-- their names is fresh
freshNewVar :: S.Cmd -> State Int S.Cmd
freshNewVar (S.Newvar v e c) = do
   i <- get
   put (i+1)
   let new = "freshVarName" ++ show i
   let old = v
   let renameCmd = replaceCmd (new,old) c
   cmd' <- freshNewVar renameCmd
   return $ S.Newvar new e cmd'
freshNewVar S.Skip = return S.Skip
freshNewVar (a@S.Assign{}) = return a
freshNewVar (S.Seq c1 c2) = do
   c1' <- freshNewVar c1
   c2' <- freshNewVar c2
   return (S.Seq c1' c2')
freshNewVar (S.ITE e c1 c2) = do
   c1' <- freshNewVar c1
   c2' <- freshNewVar c2
   return (S.ITE e c1' c2')
freshNewVar (S.While e c) = do
   c' <- freshNewVar c
   return (S.While e c')
freshNewVar (p@S.Print{}) = return p

replaceExp :: (S.Var,S.Var) -> S.Exp -> S.Exp
replaceExp _ (v@S.Val{}) = v
replaceExp (new,old) (S.Id v)
   | v == old  = S.Id new
   | otherwise = S.Id v
replaceExp no (S.Plus e1 e2) =
  S.Plus (replaceExp no e1) (replaceExp no e2)
replaceExp no (S.Minus e1 e2) =
  S.Minus (replaceExp no e1) (replaceExp no e2)
replaceExp no (S.Times e1 e2) =
  S.Times (replaceExp no e1) (replaceExp no e2)
replaceExp no (S.Div e1 e2) =
  S.Div (replaceExp no e1) (replaceExp no e2)
replaceExp no (S.Equal e1 e2) =
  S.Equal (replaceExp no e1) (replaceExp no e2)
replaceExp no (S.LessThan e1 e2) =
  S.LessThan (replaceExp no e1) (replaceExp no e2)
replaceExp no (S.And e1 e2) =
  S.And (replaceExp no e1) (replaceExp no e2)
replaceExp no (S.Not e) =
  S.Not (replaceExp no e)

replaceCmd :: (S.Var,S.Var) -> S.Cmd -> S.Cmd
replaceCmd (new,old) (S.Newvar v e c)
  | v == old  = S.Newvar v (replaceExp (new,old) e) c
  | otherwise = S.Newvar v (replaceExp (new,old) e) (replaceCmd (new,old) c)
replaceCmd _ S.Skip = S.Skip
replaceCmd (new,old) (S.Assign v e)
  | v == old  = S.Assign new (replaceExp (new,old) e)
  | otherwise = S.Assign v (replaceExp (new,old) e)
replaceCmd no (S.Seq c1 c2) =
  S.Seq (replaceCmd no c1) (replaceCmd no c2)
replaceCmd no (S.ITE e c1 c2) =
  S.ITE (replaceExp no e) (replaceCmd no c1) (replaceCmd no c2)
replaceCmd no (S.While e c) =
  S.While (replaceExp no e) (replaceCmd no c)
replaceCmd (new, old) (S.Print v)
  | v == old  = S.Print new
  | otherwise = S.Print v


-- | Mapping of variables to memory locations
type Env = [(String,Int)]

applyEnv env s =
  case (lookup s env) of
    Just l -> l
    Nothing -> error "location for variable not found"


-- | Assign memory locations to variables
memLoc :: S.Cmd -> State Int Env
memLoc S.Skip = return []
memLoc (S.Assign{}) = return []
memLoc (S.Seq c1 c2) = do
    m1 <- memLoc c1
    m2 <- memLoc c2
    return $ m1 ++ m2
memLoc (S.ITE _ c1 c2) = do
    m1 <- memLoc c1
    m2 <- memLoc c2
    return $ m1 ++ m2
memLoc (S.While _ c) = memLoc c
memLoc (S.Newvar v _ c) = do
  i <- get
  put $ i+1
  m <- memLoc c
  return $ (v,i) : m
memLoc (S.Print{}) = return []

-- | Compile expressions.
-- Invariant: Result (evaluated expression) will be on top of stack
compileExp :: Env -> S.Exp -> State World Code
compileExp _ (S.Val (S.N i)) = return [Push i]
compileExp _ (S.Val S.BTrue) = return [Push 1]
compileExp _ (S.Val S.BFalse) = return [Push 0]
compileExp env (S.Id v) = return [Dref $ applyEnv env v]
compileExp env (S.Plus e1 e2) = do
   c1 <- compileExp env e1
   c2 <- compileExp env e2
   return $ c2 ++ c1 ++ [Add]
      -- first push e2 then e1
compileExp env (S.Minus e1 e2) = do
   c1 <- compileExp env e1
   c2 <- compileExp env e2
   return $ c2 ++ c1 ++ [Minus]
compileExp env (S.Times e1 e2) = do
   c1 <- compileExp env e1
   c2 <- compileExp env e2
   return $ c2 ++ c1 ++ [Mult]
compileExp env (S.Div e1 e2) = do
   c1 <- compileExp env e1
   c2 <- compileExp env e2
   return $ c2 ++ c1 ++ [Div]
compileExp env (S.Not e) = do
   c <- compileExp env e
   setTrue <- freshLabel
   continue <- freshLabel
   return $ c
            ++ [Zero setTrue]
            ++ [Push 0, Jump continue]
            ++ [Lbl setTrue, Push 1]
            ++ [Lbl continue]
compileExp env (S.And e1 e2) = do
   c1 <- compileExp env e1
   c2 <- compileExp env e2
   setFalse <- freshLabel
   continue <- freshLabel
   return $ c1
            ++ [Zero setFalse]
            ++ c2
            ++ [Zero setFalse]
            ++ [Push 1, Jump continue]
            ++ [Lbl setFalse, Push 0]
            ++ [Lbl continue]
compileExp env (S.Equal e1 e2) = do
   c1 <- compileExp env e1
   c2 <- compileExp env e2
   return $ c2 ++ c1 ++ [Eq]
compileExp env (S.LessThan e1 e2) = do
   c1 <- compileExp env e1
   c2 <- compileExp env e2
   return $ c2 ++ c1 ++ [Lt]

-- Some global state we thread through during compilation of commands.
-- Currently, we only require a label supply
data World = World { lbl :: Label }

freshLabel :: State World Label
freshLabel = do
  s <- get
  let l = lbl s
  put s { lbl = l + 1 }
  return l

-- | Compile commands.
-- Assumes that all new variables are fresh and thus we can
-- map NewVar to Assign
compileCmd :: Env -> S.Cmd -> State World Code
compileCmd env (S.Newvar v e c) =
   compileCmd env (S.Seq (S.Assign v e) c)
compileCmd _ S.Skip = return []
compileCmd env (S.Assign v e) = do
    c <- compileExp env e
    return $ c ++ [Asg $ applyEnv env v]
compileCmd env (S.Seq c1 c2) = do
   code1 <- compileCmd env c1
   code2 <- compileCmd env c2
   return $ code1 ++ code2
compileCmd env (S.ITE e c1 c2) = do
   codeE <- compileExp env e
   codeThen <- compileCmd env c1
   codeElse <- compileCmd env c2
   labelElse <- freshLabel
   labelEndITE <- freshLabel
   return $    codeE
            ++ [Zero labelElse]
            ++ codeThen
            ++ [Jump labelEndITE]
            ++ [Lbl labelElse]
            ++ codeElse
            ++ [Lbl labelEndITE]
compileCmd env (S.While e c) = do
   codeE <- compileExp env e
   codeBody <- compileCmd env c
   startWhile <- freshLabel
   endWhile <- freshLabel
   return $    [Lbl startWhile]
            ++ codeE
            ++ [Zero endWhile]
            ++ codeBody
            ++ [Jump startWhile]
            ++ [Lbl endWhile]
compileCmd env (S.Print v) =
   return $ [Output $ applyEnv env v]