repos / machines.hs.git

commit

b3d223c

parent

d487e9f

author

Evgenii Akentev

date

2024-09-07 15:20:52 +0400 +04

Add CAM virtual machine

 1@@ -20,7 +20,8 @@ library
 2                       Abstract.EC,
 3 
 4                       Virtual.CEK,
 5-                      Virtual.Krivine
 6+                      Virtual.Krivine,
 7+                      Virtual.CAM,
 8     build-depends:    base ^>=4.18.2.1
 9     hs-source-dirs:   src
10     default-language: Haskell2010

 1@@ -0,0 +1,56 @@
 2+{-# language LambdaCase #-}
 3+
 4+module Virtual.CAM where
 5+
 6+-- From Interpreter to Compiler and
 7+-- Virtual Machine: A Functional Derivation
 8+-- https://pdfs.semanticscholar.org/08f9/c12239dd720cb28a1039db9ce706cc7ee3b2.pdf
 9+
10+data Term = Var Int | Lam Term | App Term Term | Nil | MkPair Term Term | Car Term | Cdr Term | Lit Int
11+
12+data Inst = Fst | Snd | Push | Swap | Cons | Call | Cur [Inst] | Quote Val
13+  deriving (Show)
14+
15+data Val = Null | Pair Val Val | Closure Val [Inst] | Num Int
16+  deriving (Show)
17+
18+type Stack = [Val]
19+
20+compile :: Term -> [Inst]
21+compile = \case
22+  (Var 0) -> [Snd]
23+  (Var n) -> Fst : compile (Var $ n - 1)
24+  (Lam t) -> [Cur $ compile t]
25+  (App t0 t1) -> Push : compile t0 ++ (Swap : compile t1) ++ [Cons, Call]
26+  Nil -> [Quote Null]
27+  (MkPair t0 t1) -> Push : compile t0 ++ (Swap : compile t1) ++ [Cons]
28+  (Car t) -> compile t ++ [Fst]
29+  (Cdr t) -> compile t ++ [Snd]
30+  (Lit n) -> [Quote $ Num n]
31+
32+run :: [Inst] -> Val -> Stack -> Val
33+run (Fst : c) (Pair v1 _) s = run c v1 s
34+run (Snd : c) (Pair _ v2) s = run c v2 s
35+run (Quote v': c) _ s = run c v' s
36+run (Cur c' : c) v s = run c (Closure v c') s
37+run (Push : c) v s = run c v (v : s)
38+run (Swap : c) v (v' : s) = run c v' (v : s)
39+run (Cons : c) v (v' : s) = run c (Pair v' v) s 
40+run (Call : c) (Pair (Closure v c') v') s = run (c' ++ c) (Pair v v') s
41+run [] v [] = v
42+
43+eval :: Term -> Val
44+eval t = run (compile t) Null []
45+
46+t1 :: Term
47+t1 = Car $ MkPair (Lit 1) (Lit 2)
48+
49+ex1 :: Val 
50+ex1 = eval t1
51+
52+--((λ 0) (λ 0)) (λ 0)
53+t2 :: Term
54+t2 = App (App (Lam $ Var 0) (Lam $ Var 0)) (Lam $ Var 0)
55+
56+ex2 :: Val 
57+ex2 = eval t2