SECDマシン

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も手軽で良し