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を実装します
今回は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も手軽で良し

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?