repos / machines.hs.git

commit

7ae50ab

parent

b3d223c

author

Evgenii Akentev

date

2024-09-07 19:16:54 +0400 +04

Add Virtual VEC machine

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

 1@@ -0,0 +1,64 @@
 2+{-# language LambdaCase #-}
 3+
 4+module Virtual.VEC 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 = App Term Term | CBNLam String Term | CBVLam String Term | Var String | Lit Literal | Succ Term | IfThenElse Term Term Term 
11+data Literal = BoolLit Bool | NumLit Int
12+  deriving (Show)
13+data Inst = Pushclosure [Inst] | Pushconst Literal | Call | Return | Push String | Bind String | Incr | Test [Inst] [Inst]
14+  deriving (Show)
15+type Env = [(String, Val)]
16+data Val = Closure [Inst] Env | Primitive Literal
17+  deriving (Show)
18+
19+compile :: Term -> [Inst]
20+compile = \case
21+  (App t0 t1) -> Pushclosure (compile t1 ++ [Return]) : compile t0 ++ [Call] 
22+  (CBNLam x t) -> [Pushclosure (Bind x : compile t ++ [Return])]
23+  (CBVLam x t) -> [Pushclosure (Call : Bind x : compile t ++ [Return])]
24+  (Var x) -> [Push x]
25+  (Lit l) -> [Pushconst l]
26+  (Succ t) -> compile t ++ [Incr]
27+  (IfThenElse t0 t1 t2) -> compile t0 ++ [Test (compile t1) (compile t2)]
28+
29+run :: [Val] -> [Env] -> [Inst] -> Val
30+run vs (e : es) (Pushclosure c':cs) = run (Closure c' e : vs) (e : es) cs
31+run vs es (Pushconst l : cs) = run (Primitive l:vs) es cs
32+run (Closure c' e : vs) es (Call : cs) = run vs (e : es) (c' ++ cs)
33+run vs (_:es) (Return : cs) = run vs es cs
34+run vs (e:es) (Push x : cs) = case lookup x e of
35+  Just v@(Primitive _) -> run (v : vs) (e : es) cs
36+  Just (Closure c' e') -> run vs (e' : e : es) (c' ++ cs) 
37+  Nothing -> error "var not in scope"
38+run (v : vs) (e : es) (Bind x : cs) = run vs (((x, v):e) : es) cs
39+run (Primitive (NumLit n) : vs) es (Incr : cs) = run (Primitive (NumLit $ n + 1) : vs) es cs
40+run (Primitive (BoolLit True) : vs) es (Test c1 _ : cs) = run vs es (c1 ++ cs)
41+run (Primitive (BoolLit False) : vs) es (Test _ c2 : cs) = run vs es (c2 ++ cs)
42+run (v:_) _ [] = v 
43+run _ _ _ = error "Impossible"
44+
45+eval :: Term -> Val
46+eval t = run [] [[]] $ compile t
47+
48+t1 :: Term
49+t1 = Succ $ (Lit $ NumLit 2)
50+
51+ex1 :: Val 
52+ex1 = eval t1
53+
54+--((λ 0) (λ 0)) (λ 0)
55+t2 :: Term
56+t2 = App (App (CBNLam "x" $ Var "x") (CBNLam "x" $ Var "x")) (CBNLam "x" $ Var "x")
57+
58+ex2 :: Val 
59+ex2 = eval t2
60+
61+t3 :: Term
62+t3 = App (App (App (CBNLam "x" $ CBNLam "y" $ CBNLam "z" $ IfThenElse (Var "x") (Succ $ Var "y") (Var "z")) (Lit $ BoolLit True)) (Lit $ NumLit 2)) (Lit $ NumLit 7)
63+
64+ex3 :: Val
65+ex3 = eval t3