A toy interpreter for call-by-value lambda calculus. To be transformed to an abstract machine. See A Functional Correspondence between Evaluators and Abstract Machines, by O. Danvy

interpreter-original.hs

{-
  The original evaluator to be transformed.
  See A Functional Correspondence between Evaluators and Abstract Machines, by O. Danvy
  www.brics.dk/RS/03/13/BRICS-RS-03-13.pdf
-}
data Value = Var String
           | Lambda String Expr

data Expr = Val Value
          | Ap Expr Expr

data Term = Closure Env String Expr
          deriving Show

type Env = [(String, Term)]

instance Show Value where
  show (Var x) = x
  show (Lambda x e) = "(\\" ++ x ++ "." ++ show e ++ ")"

instance Show Expr where
  show (Val v) = show v
  show (Ap e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"

varLookup :: Env -> String -> Term
varLookup env x = case lookup x env of
                    Just v -> v
                    Nothing -> error ("Unbound variable: " ++ x)

eval' :: Env -> Expr -> Term

eval' env (Val value) =
  case value of
    Var x -> varLookup env x
    Lambda x e -> Closure env x e

eval' env (Ap e1 e2) =
  case eval' env e1 of
    Closure env' x' e' ->
      case eval' env e2 of
        v -> eval' ((x',v):env') e'

eval = eval' []

{-
   The second step, CPS-transformed version
-}
data Value = Var String
           | Lambda String Expr

data Expr = Val Value
          | Ap Expr Expr

data Term = Closure Env String Expr
          deriving Show

type Env = [(String, Term)]

instance Show Value where
  show (Var x) = x
  show (Lambda x e) = "(\\" ++ x ++ "." ++ show e ++ ")"

instance Show Expr where
  show (Val v) = show v
  show (Ap e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"

varLookup :: Env -> String -> Term
varLookup env x = case lookup x env of
                    Just v -> v
                    Nothing -> error ("Unbound variable: " ++ x)

cpseval :: Env -> Expr -> (Term -> a) -> a

cpseval env (Val value) k =
  case value of
    Var x -> k (varLookup env x)
    Lambda x e -> k (Closure env x e)

cpseval env (Ap e1 e2) k =
  cpseval env e1 (\f ->
    case f of
      Closure env' x' e' ->
        cpseval env e2 (\v ->
          cpseval ((x',v):env') e' k))

eval e = cpseval [] e id

{-
  Defunctionalization, replace by data types the
  higher-order functions introduced by the CPS-transformation
  and use an 'apply' function to do the works.

  It's kind of similar to closure conversion, that both use
  data types to capture free variables in the function.

  But closure-conversion is a local transformation whereas
  defunctionalization is a whole program transformation.
-}

data Value = Var String
           | Lambda String Expr

data Expr = Val Value
          | Ap Expr Expr

data Term = Closure Env String Expr
          deriving Show

data Cont = Cont0 --id
          | Cont1 Env Expr Cont -- cpseval e1, free: env e2
          | Cont2 Env String Expr Cont -- cpseval e2, free: env' x' e'
          deriving Show

type Env = [(String, Term)]

instance Show Value where
  show (Var x) = x
  show (Lambda x e) = "(\\" ++ x ++ "." ++ show e ++ ")"

instance Show Expr where
  show (Val v) = show v
  show (Ap e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"

varLookup :: Env -> String -> Term
varLookup env x = case lookup x env of
                    Just v -> v
                    Nothing -> error ("Unbound variable: " ++ x)

applyCont :: Cont -> Term -> Term

applyCont Cont0 t = t

applyCont (Cont1 env e2 k) f =
  case f of
    Closure env' x' e' ->
      cpseval env e2 (Cont2 env' x' e' k)

applyCont (Cont2 env' x' e' k) v =
  cpseval ((x',v):env') e' k

cpseval :: Env -> Expr -> Cont -> Term

cpseval env (Val value) k =
  case value of
    Var x -> applyCont k (varLookup env x)
    Lambda x e -> applyCont k (Closure env x e)

cpseval env (Ap e1 e2) k =
  cpseval env e1 (Cont1 env e2 k)

eval e = cpseval [] e Cont0

-- Some tests
-- \x. x
pid = Val (Lambda "x" (Val (Var "x")))

-- \f s. s
pzero = Val (Lambda "f" (Val (Lambda "s" (Val (Var "s")))))

-- \n. \f s. f (n f s)
psuc = (Val (Lambda "n" (Val (Lambda "f" (Val (Lambda "s"
        (Ap (Val (Var "f"))
         (Ap (Ap (Val (Var "n")) (Val (Var "f"))) (Val (Var "s"))))))))))

-- \m n. m pSuc n
padd = (Val (Lambda "m" (Val (Lambda "n"
        (Ap (Ap (Val (Var "m")) psuc) (Val (Var "n")))))))

-- \p q. p
p1 = (Val (Lambda "p" (Val (Lambda "q" (Val (Var "p"))))))

-- \p q. q
p2 = (Val (Lambda "p" (Val (Lambda "q" (Val (Var "q"))))))

-- test
test = Ap (Ap padd (Ap psuc (Ap psuc pzero))) (Ap psuc pzero)
test2 = Ap (Ap p1 pzero) pid

{-
  Just replace names of the constructors so that it
  looks more like machine instructions!
-}

data ExprValue = EVar String
           | ELambda String Expr

data Expr = Val ExprValue
          | Ap Expr Expr

data Value = Var String
           | Lambda String Code

data Code = Push Value
          | Call Code Code

data Term = Closure Env String Code
          deriving Show

data Stack = Halt --id
           | Arg Env Code Stack -- cpseval e1, free: env e2
           | Jump Env String Code Stack -- cpseval e2, free: env' x' e'
          deriving Show

type Env = [(String, Term)]

instance Show Value where
  show (Var x) = x
  show (Lambda x e) = "(\\" ++ x ++ "." ++ show e ++ ")"

instance Show Code where
  show (Push v) = show v
  show (Call e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"

varLookup :: Env -> String -> Term
varLookup env x = case lookup x env of
                    Just v -> v
                    Nothing -> error ("Unbound variable: " ++ x)

applyCont :: Stack -> Term -> Term

applyCont Halt t = t

applyCont (Arg env e2 k) f =
  case f of
    Closure env' x' e' ->
      cpseval env e2 (Jump env' x' e' k)

applyCont (Jump env' x' e' k) v =
  cpseval ((x',v):env') e' k

cpseval :: Env -> Code -> Stack -> Term

cpseval env (Push value) k =
  case value of
    Var x -> applyCont k (varLookup env x)
    Lambda x e -> applyCont k (Closure env x e)

cpseval env (Call e1 e2) k =
  cpseval env e1 (Arg env e2 k)

eval env e = cpseval env e Halt

compile :: Expr -> Code
compile (Ap e1 e2) = Call (compile e1) (compile e2)
compile (Val (EVar x)) = Push (Var x)
compile (Val (ELambda x e)) = Push (Lambda x (compile e))

-- \x. x
pid = compile $ Val (ELambda "x" (Val (EVar "x")))

-- \f s. s
pzero = compile $ Val (ELambda "f" (Val (ELambda "s" (Val (EVar "s")))))

-- \n. \f s. f (n f s)
psuc' = (Val (ELambda "n" (Val (ELambda "f" (Val (ELambda "s"
         (Ap (Val (EVar "f"))
          (Ap (Ap (Val (EVar "n")) (Val (EVar "f")))
              (Val (EVar "s"))))))))))
psuc = compile psuc'
        

-- \m n. m pSuc n
padd = compile $
        (Val (ELambda "m" (Val (ELambda "n"
         (Ap (Ap (Val (EVar "m")) psuc') (Val (EVar "n")))))))

-- \p q. p
p1 = compile $
      (Val (ELambda "p" (Val (ELambda "q" (Val (EVar "p"))))))

-- \p q. q
p2 = compile $
      (Val (ELambda "p" (Val (ELambda "q" (Val (EVar "q"))))))

-- test
test = Call (Call padd (Call psuc (Call psuc pzero))) (Call psuc pzero)
test2 = Call (Call p1 pzero) pid