An abstract machine obtained by transforming the toy interpreter for call-by-value lambda calculus at https://gist.github.com/suhorng/5355222. See A Functional Correspondence between Evaluators and Abstract Machines, by O. Danvy

interpreter-machine-like.hs

{-
  The abstract machine obtained by transforming
  the original direct evaluator.

  Previous codes: https://gist.github.com/suhorng/5355222
-}

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)]
type Machine = (Maybe Term, Stack, Env, Code)

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)

-- Machine = (Maybe Value, Stack, Env, Code)
run :: Machine -> Term

run (Just t, Halt, _, _) = t

run (Just (Closure env' x' e'), Arg env e2 k, _, _) =
  run (Nothing, Jump env' x' e' k, env, e2)

run (Just v, Jump env' x' e' k, _, _) =
  run (Nothing, k, ((x',v):env'), e')

run (Nothing, k, env, Push value) =
  case value of
    Var x -> run (Just (varLookup env x), k, env, undefined)
    Lambda x e -> run (Just (Closure env x e), k, env, undefined)

run (Nothing, k, env, Call e1 e2) =
  run (Nothing, Arg env e2 k, env, e1)

-- well-typed program won't get stuck
--run _ = error "The machine has gotten stuck"

eval e = run (Nothing, Halt, [], e)

-- \x. x
pid = Push (Lambda "x" (Push (Var "x")))

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

-- \n. \f s. f (n f s)
psuc = (Push (Lambda "n" (Push (Lambda "f" (Push (Lambda "s"
        (Call (Push (Var "f"))
         (Call (Call (Push (Var "n")) (Push (Var "f"))) (Push (Var "s"))))))))))

-- \m n. m pSuc n
padd = (Push (Lambda "m" (Push (Lambda "n"
        (Call (Call (Push (Var "m")) psuc) (Push (Var "n")))))))

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

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

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


{-
  Rewrite value handling, making it more like an
  abstract machine.

  Just don't understand how the CEK machine works..
-}

data Code = Var Value
          | Lambda String Code
          | Call Code Code
          | Return Term

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)]
type Machine = (Code, Env, Stack)

instance Show Code where
  show (Var x) = x
  show (Lambda x e) = "(\\" ++ x ++ "." ++ show e ++ ")"
  show (Call e1 e2) = "(" ++ show e1 ++ show e2 ++ ")"
  show (Return t)= "(Return " ++ show t ++ ")"

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

-- Machine = (Code, Env, Stack)
run :: Machine -> Term

run (Return t, _, Halt) = t

run (Return (Closure env' x' e'), _, Arg env e2 k) =
  run (e2, env, Jump env' x' e' k)

run (Return v, _, Jump env' x' e' k) =
  run (e', ((x',v):env'), k)

run (Var x, env, k) =
  run (Return (varLookup env x), k, env)

run (Lambda x e, env, k) =
  run (Return (Closure env x e), k, env)

run (Call e1 e2, env, k) =
  run (e1, env, Arg env e2 k)

-- well-typed program won't get stuck
--run _ = error "The machine has gotten stuck"

eval e = run (Nothing, Halt, [], e)

-- \x. x
pid = Lambda "x" (Var "x")

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

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

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

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

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

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


{-
  An abstract machine for call-by-value* lambda calculus.
  https://gist.github.com/suhorng/5355222
  https://gist.github.com/suhorng/5355378

  The codes are 'flatten'. Environment/stack manipulations are changed.
  So this looks more like a machine, and now implementing the machine
  in C is quite straightforward.

  The machine codes might lead to uncovered transition now.

  *: arguments are evaluated precede function body
-}

import Control.Monad.State
import System.IO -- for writeAll

data Code = Access String Code
          | Function String Code Code
          | Save Code
          | Restore Code
          | Call Code
          | Return
          | Halt
          deriving Show

data Value = Closure Env String Code
           deriving Show

type Env = [(String, Value)]

type Values = [Value]
type Stack = [Either Code Env]

data Expr = Var String
          | Lambda String Expr
          | Ap Expr Expr
          deriving Show

type Machine = (Code, Values, Stack, Env)

compile' :: Expr -> Code -> Code
compile' (Var x) c = Access x c
compile' (Lambda x e) c = Function x c (compile' e Return)
compile' (Ap e1 e2) c = Save $
                        compile' e2 $
                        Restore $
                        compile' e1 $
                        Call $
                        c
{-
  Save; e2; Restore; e1; Call; rest

  Variant of the defunctionalized continuation:
    Empty
  | Arg0 Env Code Cont
  | Jump Value Cont

  where the save/restore of Env is writing out explicitly.
-}

type EnvClean = Bool

{-
  remove redundant Save/Restore instruction of the form
        Save; e1; Restore; rest
  where e1 does not modify the environment
  (that is, doesn't contain function calls)
-}
removeEnv :: EnvClean -> Code -> ([EnvClean] -> Code -> Code) -> Code
removeEnv clean (Access x c) k =
  removeEnv clean c $ \bs rest ->
  k bs (Access x rest)
removeEnv clean (Function x c e) k =
  removeEnv clean c $ \bs rest ->
  k bs (Function x rest (removeEnv True e (const id)))
removeEnv _ (Save c) k =
  removeEnv True c $ \bs rest ->
  let c' = case bs of
             True:_  -> rest
             False:_ -> Save rest
             _       -> error "Mismatched Save/Restore pair"
  in k (tail bs) c'
removeEnv clean (Restore c) k =
  removeEnv True c $ \bs rest ->
  let c' = case clean of
             True -> rest
             False -> Restore rest
  in k (clean:bs) c'
removeEnv _ (Call c) k =
  removeEnv False c $ \bs rest ->
  k bs (Call rest)
removeEnv _ c k = k [] c

compile e = removeEnv undefined (compile' e Halt) (const id)

run :: Machine -> Value
run (Access x c, vs, stk, env) =
  run (c, v:vs, stk, env)
  where Just v = lookup x env
run (Function x c e, vs, stk, env) =
  run (c, (Closure env x e):vs, stk, env)
run (Save c, vs, stk, env) =
  run (c, vs, (Right env):stk, env)
run (Restore c, vs, (Right env):stk, _) =
  run (c, vs, stk, env)
run (Call c, (Closure env' x' e'):v:vs, stk, _) =
  run (e', vs, (Left c):stk, (x',v):env')
run (Return, vs, (Left c):stk, env') =
  run (c, vs, stk, env')
run (Halt, v:_, _, _) = v
run _ = error "Undefined state transition"

go c = run (c, [], [], [])

-- \x. x
pid = Lambda "x" (Var "x")

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

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

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

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

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

-- \f x y. f y x
pflip = Lambda "f" (Lambda "x" (Lambda "y" (Ap (Ap (Var "f") (Var "y")) (Var "x"))))

-- test
ptest1 = Ap (Ap padd (Ap psuc (Ap psuc pzero))) (Ap psuc pzero)
ptest2 = Ap (Ap p1 pzero) pid
ptest3 = Ap (Ap p1 pid) p1
ptest4 = Ap (Ap (Ap pflip p1) pid) p1

newName :: State Int String
newName = do
  n <- get
  modify (+1)
  return ('L' : show n)

{-
data Code = Access String Code
          | Function String Code Code
          | Save Code
          | Restore Code
          | Call Code
          | Return
          | Halt
          deriving Show

-}

printCode' :: Code -> State Int (String -> String)
printCode' (Save c) = do
  showRest <- printCode' c
  return $ ("    Save\n" ++) . showRest
printCode' (Restore c) = do
  showRest <- printCode' c
  return $ ("    Restore\n" ++) . showRest
printCode' (Call c) = do
  showRest <- printCode' c
  return $ ("    Call\n" ++) . showRest
printCode' Return = do
  return ("    Return\n" ++)
printCode' Halt =
  return ("    Halt\n" ++)
printCode' (Access x c) = do
  showRest <- printCode' c
  return $ (("    Access " ++ x ++ "\n") ++) . showRest
printCode' (Function x c e) = do
  label <- newName
  showRest <- printCode' c
  showFunction <- printCode' e
  return $ (("    Function \\" ++ x ++ " -> " ++ label ++ "\n") ++)
           . showRest
           . ((label ++ ":\n") ++)
           . showFunction

printCode c = fst (runState (printCode' c) 0) ""

cid = compile pid
czero = compile pzero
csuc = compile psuc
cadd = compile padd
c1 = compile p1
c2 = compile p2
cflip = compile pflip
ctest1 = compile ptest1
ctest2 = compile ptest2
ctest3 = compile ptest3
ctest4 = compile ptest4

writeCode code handle = hPutStr handle (printCode code)

writeAll = do
  withFile "ctest1-intr.s" WriteMode (writeCode ctest1)
  withFile "ctest2-intr.s" WriteMode (writeCode ctest2)
  withFile "ctest3-intr.s" WriteMode (writeCode ctest3)
  withFile "ctest4-intr.s" WriteMode (writeCode ctest4)
  withFile "cflip-intr.s" WriteMode (writeCode cflip)
  withFile "cid-intr.s" WriteMode (writeCode cid)
  withFile "czero-intr.s" WriteMode (writeCode czero)
  withFile "csuc-intr.s" WriteMode (writeCode csuc)
  withFile "cadd-intr.s" WriteMode (writeCode cadd)
  withFile "c1-intr.s" WriteMode (writeCode c1)
  withFile "c2-intr.s" WriteMode (writeCode c2)

{-

eval' :: [(String, Term)] -> Expr -> (Expr -> Term) -> Term
eval' env (Var x) k = k (variableLookup env x)
eval' env (Lambda x e) k = k (Closure env x e)
eval' env (Ap e1 e2) k =
  eval' env e2 $ \v ->
  eval' env e1 $ \(Closure env' x' e') ->
  eval' ((x',v):env') e' k

eval e = eval' [] e id

-}