14
Help us understand the problem. What are the problem?

More than 3 years have passed since last update.

posted at

updated at

# SECDマシン

SECDマシン

SECDマシンとは、関数型言語のコンパイラのターゲット（目的機械）を意図し、後に大きな影響を与えた抽象機械である。SECD は Stack（スタック）、Environment（環境）、Code（コード）、Dump（ダンプ）の略であり、それぞれ仮想機械にあるレジスタの名称となっている

SECDマシンで純Lispを実装します

github

# Spec

defの代わりにlet/letrecを使用

EnvironmentはMapで変数管理

# Internal

SECD/Internal.hs
``````module SECD.Internal where

import Prelude hiding (EQ)
import qualified Data.Map as M
import Data.List (intersperse)

data SECD
= SECD {
stack :: Stack,
env   :: Env,
code  :: Code,
dump  :: Dump
} deriving Show

type Stack = [Lisp]
type Env = M.Map String Lisp
type Code = [CodeOP]
type Dump = [DumpOP]

data CodeOP
= LET String
| LD String
| LDC Lisp
| LDF [String] Code
| LIST Int
| AP
| RET
| RAP
| SEL Code Code
| JOIN
| CONS
| CAR
| CDR
| EQ
| ATOM
| PUTS
| DEBUG
| STOP
deriving Show

data DumpOP
= DumpAP Stack Env Code
| DumpSEL Code
deriving Show

data Lisp
= LList [Lisp]
| LAtom String
| LNum Int
| LTrue
| LFalse
| LNil
| LCons Lisp Lisp
| LClosure [String] Code Env
| LError String

instance Eq Lisp where
LList a == LList b = a == b
LCons a b == LCons c d = a == c && b == d
LAtom a == LAtom b = a == b
LNum a  == LNum b  = a == b
LTrue   == LTrue   = True
LFalse  == LFalse  = True
LNil    == LNil    = True
_       == _       = False

instance Show Lisp where
show l = case l of
LList ls -> "(" ++ (concat \$ intersperse " " \$ map show ls) ++ ")"
LAtom s -> s
LNum n -> show n
LTrue -> "#true"
LFalse -> "#false"
LNil -> "#nil"
LCons a b -> "(cons " ++ show a ++ " " ++ show b ++ ")"
LClosure as c e -> "(lam (" ++ (concat \$ intersperse " " \$ as) ++ ") Code"
LError e -> "ERROR(" ++ e ++ ")"
``````

# Parser

parsec様様

SECD/Parser.hs
``````module SECD.Parser (parse) where

import SECD.Internal

import Control.Applicative
import qualified Text.Parsec as T

parse :: T.SourceName -> String -> Either T.ParseError Lisp
parse = T.parse sexpr

sexpr = spaces *> (atom <|> list) <* spaces

t p = spaces *> p <* spaces

spaces = T.skipMany (T.space <|> T.tab <|> T.newline)

atom =
(LNum . read) <\$> ((++) <\$> T.option "" (T.string "-")  <*> (T.many1 \$ T.digit)) <|>
(T.string "#" *>
(LFalse <\$ T.string "false" <|>
LTrue <\$ T.string "true" <|>
LNil <\$ T.string "nil")) <|>
LAtom <\$> (T.many1 \$ T.noneOf "(#)' \t\n")

list = LList <\$> (T.string "(" *> T.many sexpr  <* T.string ")")
``````

# Compiler

ASTから機械語へ変換

SECD/Compiler.hs
``````module SECD.Compiler (compile) where

import SECD.Internal
import Prelude hiding (EQ)

compile :: Lisp -> Either String Code
compile = compile' []

compile' :: [String] -> Lisp -> Either String Code
compile' rs lisp = case lisp of
LAtom "debug" -> Right \$ [DEBUG]
LAtom a -> Right \$ [LD a]
LList ls' -> case ls' of
[] -> Right \$ [LDC \$ LList []]
LAtom "let"    : ls -> let' rs ls
LAtom "letrec" : ls -> letrec rs ls
LAtom "lam"    : ls -> lam rs ls
LAtom "if"     : ls -> if' rs ls
LAtom "list"   : ls -> list rs ls
LAtom "eq"     : ls -> eq rs ls
LAtom "atom"   : ls -> atom rs ls
LAtom "cons"   : ls -> cons rs ls
LAtom "car"    : ls -> car rs ls
LAtom "cdr"    : ls -> cdr rs ls
LAtom "+"      : ls -> add rs ls
LAtom "puts"   : ls -> puts rs ls
LAtom "do"     : ls -> do' rs ls
_ -> apply rs ls'
_ -> Right \$ [LDC lisp]

let' rs ls = case ls of
LList [LAtom name, expr] : body -> do
let rs' = filter (/= name) rs
e <- compile' rs' expr
b <- concat <\$> mapM (compile' rs') body
pure \$ e ++ [LET name] ++ b
_ ->
Left \$ "syntax error let: " ++ show ls

letrec rs ls = case ls of
LList [LAtom name, expr] : body -> do
let rs' = name : rs
e <- compile' rs' expr
b <- concat <\$> mapM (compile' rs') body
pure \$ e ++ [LET name] ++ b
_ ->
Left \$ "syntax error letrec: " ++ show ls

lam rs ls = case ls of
[LList args, body] ->
(\a -> [LDF (map (\(LAtom a) -> a) args) \$ a ++ [RET]]) <\$> compile' rs body
[LAtom args, body] ->
(\a -> [LDF [args] \$ a ++ [RET]]) <\$> compile' rs body
_ ->
Left \$ "syntax error lam: " ++ show ls

if' rs ls = case ls of
[b, t, f] -> do
b' <- compile' rs b
t' <- compile' rs t
f' <- compile' rs f
pure \$ b' ++ [SEL (t' ++ [JOIN]) (f' ++ [JOIN])]
_ ->
Left \$ "syntax error if: " ++ show ls

list rs ls = case ls of
list ->
((++ [LIST \$ length list]) . concat) <\$> mapM (compile' rs) ls

eq rs ls = case ls of
[a, b] ->
(++ [EQ]) <\$> ((++) <\$> compile' rs b <*> compile' rs a)
_ ->
Left \$ "syntax error eq: " ++ show ls

atom rs ls = case ls of
[a] ->
(++ [ATOM]) <\$> compile' rs a
_ ->
Left \$ "syntax error atom: " ++ show ls

cons rs ls = case ls of
[a, b] ->
(++ [CONS]) <\$> ((++) <\$> compile' rs b <*> compile' rs a)
_ -> Left \$ "syntax error cons: " ++ show ls

car rs ls = case ls of
[a] ->
(++ [CAR]) <\$> compile' rs a
_ ->
Left \$ "syntax error car: " ++ show ls

cdr rs ls = case ls of
[a] ->
(++ [CDR]) <\$> compile' rs a
_ ->
Left \$ "syntax error cdr: " ++ show ls

add rs ls = case ls of
[a,b] ->
(++ [ADD]) <\$> ((++) <\$> compile' rs b <*> compile' rs a)
_ ->
Left \$ "syntax error +: " ++ show ls

puts rs ls = case ls of
[a] ->
(++ [PUTS]) <\$> compile' rs a
_ ->
Left \$ "syntax error puts: " ++ show ls

do' rs ls =
concat <\$> mapM (compile' rs) ls

apply rs (lam : args) = do
args' <- mapM (compile' rs) \$ reverse args
lam' <- compile' rs lam
pure \$ concat args' ++ [LIST \$ length args] ++ lam' ++ ap
where
ap = case lam of
LAtom name -> if elem name rs then [RAP] else [AP]
_ -> [AP]
``````

# VM

SECDマシン本体
RAPをうまく実装できず一月ハマっていた(・ω・｀)

SECD/VM.hs
``````module SECD.VM (initVM,runVM) where

import SECD.Internal

import Prelude hiding (EQ)
import qualified Data.Map as M

initVM :: SECD
initVM = SECD [] M.empty [] []

runVM :: SECD -> IO SECD
runVM secd@SECD {..} = case code of
[] -> pure secd
DEBUG:ops -> do
putStrLn \$ "SECD:"
putStrLn \$ "stack: " ++ show stack
putStrLn \$ "code: " ++ show code
putStrLn \$ "env: " ++ show env
putStrLn \$ "dump: " ++ show dump
runVM \$ secd { code = ops }
PUTS:ops -> do
runVM \$ secd { stack = stack, code = ops }
STOP:_ -> pure secd
op:ops -> runVM \$ flip (\$) secd { code = ops } \$ case op of
LET a   -> let' a
LD a    -> ld a
LDC l   -> ldc l
LDF a c -> ldf a c
LIST n  -> list n
AP      -> ap
RET     -> ret
RAP     -> rap
SEL a b -> sel a b
JOIN    -> join
CONS    -> cons
CAR     -> car
CDR     -> cdr
EQ      -> eq
ATOM    -> atom

vmError :: String -> SECD -> SECD
vmError s secd@SECD {..} =
secd {
stack = LError s : stack,
code = STOP : code
}

ld :: String -> SECD -> SECD
ld a secd@SECD {..} =
if M.member a env then
secd {
stack = (env M.! a) : stack
}
else

ldc :: Lisp -> SECD -> SECD
ldc l secd@SECD {..} =
secd {
stack = l : stack
}

ldf :: [String] -> Code -> SECD -> SECD
ldf as c secd@SECD {..} =
secd {
stack = LClosure as c env : stack
}

list :: Int -> SECD -> SECD
list n secd@SECD {..} =
secd {
stack = LList (take n stack) : drop n stack
}

ap :: SECD -> SECD
ap secd@SECD { stack = LClosure as c e : LList args : ss, ..} =
secd {
stack = [],
env = M.union (M.fromList (zip as args)) e,
code = c,
dump = DumpAP ss env code : dump
}
ap secd = vmError "ap error" secd

ret :: SECD -> SECD
ret secd@SECD {stack = s : ss, dump = DumpAP stack env code : dump } =
secd {
stack = s : stack,
env = env,
code = code,
dump = dump
}
ret secd = vmError "ret error" secd

rap :: SECD -> SECD
rap secd@SECD { stack = LClosure as c e : LList args : ss, ..} =
secd {
stack = [],
env = M.union (M.union (M.fromList \$ zip as args) e) env,
code = c,
dump = DumpAP ss env code : dump
}

sel :: Code -> Code -> SECD -> SECD
sel t f secd@SECD {stack = s : ss, ..} = case s of
LTrue  -> secd { code = t, dump = DumpSEL code : dump }
LFalse -> secd { code = f, dump = DumpSEL code : dump }
_      -> vmError ("sel error: expect bool. not " ++ show s) secd
sel t f secd@SECD { stack = [] } =
vmError ("vm error sel: expect bool. stack is empty") secd

join :: SECD -> SECD
join secd@SECD { dump = DumpSEL c : ds } =
secd {
code = c,
dump = ds
}

let' :: String -> SECD -> SECD
let' a secd@SECD { stack = s : ss } =
secd {
stack = ss,
env = M.insert a s \$ env secd
}

cons :: SECD -> SECD
cons secd@SECD { stack =  a : b : ss } =
secd {
stack = LCons a b : ss
}

car :: SECD -> SECD
car secd@SECD { stack = LCons a _ : ss } =
secd {
stack = a : ss
}
car secd@SECD { stack = s : ss } =
vmError ("car expect cons. not " ++ show s) secd

cdr :: SECD -> SECD
cdr secd@SECD { stack = LCons _ a : ss } =
secd {
stack = a : ss
}
cdr secd@SECD { stack = s : ss } =
vmError ("cdr expect cons. not " ++ show s) secd

eq :: SECD -> SECD
eq secd@SECD { stack = a : b : ss } =
secd {
stack = (if a == b then LTrue else LFalse) : ss
}

atom :: SECD -> SECD
atom secd@SECD { stack = a : ss } =
secd {
stack = s : ss
}
where
s = case a of
LClosure _ _ _ -> LFalse
LList _ -> LFalse
LCons _ _ -> LFalse
LError _ -> LFalse
_ -> LTrue

add secd@SECD { stack = LNum a : LNum b : ss } =
secd {
stack = LNum (a + b) : ss
}
``````

# SECD

SECD.hs
``````module SECD (runLisp, runLispFile) where

import SECD.Internal
import SECD.Parser
import SECD.Compiler
import SECD.VM

runLisp' :: String -> String -> IO ()
runLisp' s ss = do
case parse s ss of
Left err -> print err
Right ast ->
case compile ast of
Left err -> putStrLn err
Right code -> do
secd <- runVM \$ initVM { code = code }
print \$ head \$ stack secd

runLisp :: String -> IO ()
runLisp = runLisp' "runLisp"

runLispFile :: String -> IO ()
runLispFile s = do
runLisp' s ss
``````

# fib

フィボナッチ数でもやって見ましょ

``````(letrec
(fib
(lam n
(if (eq n 0)
0
(if (eq n 1)
1
(+ (fib (+ n -2)) (fib (+ n -1)))))))
(fib 30))
``````
``````❯ time stack exec lisp lisp/fib.lisp
832040
stack exec lisp lisp/fib.lisp  6.02s user 1.14s system 148% cpu 4.819 total
``````

ちなみにrubyだと

fib.rb
``````def fib n
if n == 0
0
elsif n == 1
1
else
fib(n - 2) + fib(n - 1)
end
end

p fib(30)
``````
``````❯ time ruby fib.rb
832040
ruby fib.rb  0.27s user 0.01s system 97% cpu 0.292 total
``````

30倍も遅いけど、しょうがないね

# Strict, StrictData

`{-# LANGUAGE Strict, StrictData #-}`と全ファイルの頭につけてrebuild
17倍まで改善

``````❯ time stack exec lisp lisp/fib.lisp
832040
stack exec lisp lisp/fib.lisp  4.69s user 0.79s system 133% cpu 4.117 total
``````

# stack build --fast

ghcの最適化オプションをオンにしてrebuild
56倍まで悪化
fastとは一体

--fastオプションは最適化をオフにするみたいです、紛らわしいね

``````❯ time stack exec lisp lisp/fib.lisp
832040
stack exec lisp lisp/fib.lisp  15.12s user 2.39s system 136% cpu 12.847 total
``````

# Z Combinator

おまけ
Y Combinatorの値渡し評価版

z.lisp
``````(let
(z
(lam f
((lam x
(f
(lam y ((x x) y))))
(lam x
(f
(lam y ((x x) y)))))))

(let
(sum
(lam f
(lam x
(if (eq x 1)
x
(+ x (f (+ x -1)))))))

((z sum) 10))) ; => 55
``````

# 小並まとめ

SECDマシンわりと簡単ながらも十分な表現力があり素晴らしい
RAPがたまらんです

Why not register and get more from Qiita?
1. We will deliver articles that match you
By following users and tags, you can catch up information on technical fields that you are interested in as a whole
2. you can read useful information later efficiently
By "stocking" the articles you like, you can search right away
14
Help us understand the problem. What are the problem?