repos / machines.hs.git

SECD.hs

 1{-# language LambdaCase #-}
 2
 3module Virtual.SECD where
 4
 5-- From Interpreter to Compiler and
 6-- Virtual Machine: A Functional Derivation
 7-- https://pdfs.semanticscholar.org/08f9/c12239dd720cb28a1039db9ce706cc7ee3b2.pdf
 8
 9data Term = Var String | Lam String Term | App Term Term
10data Inst = Access String | Close String [Inst] | Call
11  deriving (Show)
12type Env = [(String, Val)]
13data Val = Closure String [Inst] Env 
14  deriving (Show)
15
16compile :: Term -> [Inst]
17compile = \case
18  (Var x) -> [Access x]
19  (Lam x t) -> [Close x $ compile t]
20  (App t0 t1) -> compile t1 ++ compile t0 ++ [Call]
21
22
23step :: [Inst] -> Env -> [Val] -> Val
24step (Access x : c) e s = case lookup x e of
25  Just v -> step c e (v:s)
26  Nothing -> error "Var not in scope"
27step (Close x c' : c) e s = step c e (Closure x c' e : s)
28step (Call : c) e (Closure x c' e' : v : s) = step (c' ++ c) ((x, v):e') s
29step [] e (v:_) = v
30
31eval :: Term -> Val
32eval t = step (compile t) [] []
33
34-- (\ 0 0) (\ 0)
35t1 :: Term
36t1 = App (Lam "x" (App (Var "x") (Var "x"))) (Lam "x" (Var "x"))
37
38ex1 :: Val
39ex1 = eval t1
40
41--((λ 0) (λ 0)) (λ 0)
42t2 :: Term
43t2 = App (App (Lam "x" $ Var "x") (Lam "x" $ Var "x")) (Lam "x" $ Var "x")
44
45ex2 :: Val
46ex2 = eval t2