repos / machines.hs.git

CLS.hs

 1{-# language LambdaCase #-}
 2
 3module Virtual.CLS 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 Int | Lam Term | App Term Term
10data Inst = Access Int | ILam [Inst] | Ap | Push
11  deriving (Show)
12type Env = [Val]
13data Val = Closure [Inst] Env 
14  deriving (Show)
15
16compile :: Term -> [Inst]
17compile = \case
18  (Var n) -> [Access n]
19  (Lam t) -> [ILam $ compile t]
20  (App t0 t1) -> Push : compile t0 ++ compile t1 ++ [Ap]
21
22
23step :: [Inst] -> [Env] -> [Val] -> Val
24step (Access 0 : c) ((v : _) : l) s = step c l (v : s) 
25step (Access n : c) ((_ : e) : l) s = step (Access (n - 1) : c) (e : l) s
26step (ILam c : c') (e : l) s = step c' l (Closure c e : s)
27step (Ap : c) l (v : (Closure c' e) : s) = step (c' ++ c) ((v : e) : l) s
28step (Push : c) (e : l) s = step c (e : e : l) s
29step [] _ (v : _) = v
30
31eval :: Term -> Val
32eval t = step  (compile t) [[]] []
33
34-- (\ 0 0) (\ 0)
35t1 :: Term
36t1 = App (Lam (App (Var 0) (Var 0))) (Lam (Var 0))
37
38ex1 :: Val
39ex1 = eval t1
40
41--((λ 0) (λ 0)) (λ 0)
42t2 :: Term
43t2 = App (App (Lam $ Var 0) (Lam $ Var 0)) (Lam $ Var 0)
44
45ex2 :: Val
46ex2 = eval t2