Edited at

SECDマシン

More than 1 year has passed since last update.

SECDマシン


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


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

今回はhaskellで書きます、やったね

github


Spec

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

足し算と数値リテラルを追加

EnvironmentはMapで変数管理


Internal

内部で共用するdataやtypeなど


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
| ADD
| 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から機械語へ変換

パターンマッチとEither Functor/Monadでスッキリしてます

良い


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
print $ head stack
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
ADD -> add

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
vmError ("ld not found " ++ a) secd

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
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
ss <- readFile s
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がたまらんです

久しぶりにhaskell書いて見ましたが気持ちよすぎ、stackも手軽で良し