Edited at

素朴なlispインタープリター

More than 1 year has passed since last update.

純Lisp実装シリーズ第3回です

第1回 小さなLisp

第2回 SECDマシン

今回は第1回で書いた物をrubyからhaskellへ書き直しただけですので悪しからず

なぜそのような事をしたかというとSECDマシン(VM)と素朴な再帰ベースの実装とを比べて見たかったからです

では見ていきましょう

source


AST

Abstract Syntax Tree略してAST

構文木ですね

S式は非常にシンプルでListとAtomで事足ります

今回は数字用にNatを追加

Posはソースコード中の位置情報です

エラーメッセージ用に入れておきます


Lisp/AST.hs

module Lisp.AST where

import Data.List

type Pos = (Int,Int)
data AST
= Atom Pos String
| Nat Pos Int
| List Pos [AST]

instance Show AST where
show (Atom _ s) = s
show (Nat _ n) = show n
show (List _ ls) = "(" ++ (concat $ intersperse " " $ map show ls) ++ ")"

instance Eq AST where
Atom _ a == Atom _ b = a == b
Nat _ a == Nat _ b = a == b
List _ a == List _ b = a == b
a == b = False



Parser

文字列からASTへ変換するのがparseですね

parsecを使ってparseします

((,) <$> P.sourceLine <*> P.sourceColumn) <$> P.getPosition

位置情報はこれで取れます


Lisp/Parser.hs

{-# LANGUAGE TupleSections #-}

module Lisp.Parser where

import Lisp.AST
import Control.Applicative
import qualified Text.Parsec as P

parse :: String -> Either P.ParseError AST
parse = P.parse sexpr ""

-- top = List <$> pos <*> (P.many (sexpr <* spaces) <* P.eof)

sexpr = atom <|> list

pos = ((,) <$> P.sourceLine <*> P.sourceColumn) <$> P.getPosition

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

comment = P.string ";" *> P.noneOf "\n" <* P.newline

atom
= Atom <$> pos <*> P.many1 (P.noneOf "0123456789()' \t\r\n")
<|> Nat <$> pos <*> (read <$> P.many1 P.digit)

list = P.string "(" *> (List <$> pos <*> P.many (sexpr <* spaces)) <* P.string ")"



Eval

実行系本体になります

VMと違いコンパイルしてVM用の命令を生成する必要がなく

素朴に逐次実行していきます

ひたすらパターンマッチング


Lisp/Eval.hs

{-# LANGUAGE RecordWildCards #-}

module Lisp.Eval where

import Lisp.AST
import Control.Monad
import qualified Data.Map as M

type Env = M.Map String AST

data LispState
= LispState {
ast :: AST,
env :: Env,
ref :: Maybe LispState
}
deriving Show

eval :: AST -> IO AST
eval a = do
ls <- evalState $ initLispState { ast = a }
pure $ ast ls

initLispState = LispState (Atom (0,0) "#nil") M.empty Nothing

evalError :: LispState -> String -> IO LispState
evalError ls msg = do
let
(p, a) = case ast ls of
Atom p a -> (p, show a)
Nat p n -> (p, show n)
List p l -> (p, show $ ast ls)
fail $ show p ++ " " ++ msg ++ " " ++ a
pure ls

evalState :: LispState -> IO LispState
evalState ls = case ast ls of
Atom _ a -> pure $ ls { ast = lookup $ env ls }
where
lookup e = case M.lookup a e of
Just a' -> a'
Nothing -> case ref ls of
Just e' -> lookup $ env e'
Nothing -> ast ls

Nat _ a -> pure ls

List _ [] -> pure ls

List _ (Atom _ "do" : body) -> foldM go ls body
where
go ls' expr = evalState $ ls' { ast = expr }

List _ [Atom _ "def", Atom _ name, body] ->
pure $ ls { env = M.insert name body $ env ls }

List pos (Atom _ "def" : _) ->
evalError ls "syntax error"

List _ [Atom _ "lam", List _ names, body] ->
pure ls

List pos (Atom _ "lam" : _) ->
evalError ls "syntax error"

List _ [Atom pos "+", a, b] -> do
a' <- evalState $ ls { ast = a }
b' <- evalState $ ls { ast = b }

case (ast a', ast b') of
(Nat _ a, Nat _ b) -> pure $ ls { ast = Nat pos (a + b) }
_ -> evalError ls "+ expect nat"

List _ [Atom pos "-", a, b] -> do
a' <- evalState $ ls { ast = a }
b' <- evalState $ ls { ast = b }

case (ast a', ast b') of
(Nat _ a, Nat _ b) -> pure $ ls { ast = Nat pos (a - b) }
_ -> evalError ls "- expect nat"

List _ (Atom _ "puts" : args) -> mapM_ puts args >> pure ls
where
puts arg = do
a <- evalState $ ls { ast = arg }
print a

List _ [Atom _ "if", bool, true, false] -> do
b <- evalState $ ls { ast = bool }
case ast b of
Atom _ "#t" -> evalState $ ls { ast = true }
Atom _ "#f" -> evalState $ ls { ast = false }
_ -> evalError ls "if expect #t or #f"

List pos [Atom _ "atom", a] -> do
a' <- evalState $ ls { ast = a }
case ast a' of
Atom _ _ -> pure $ ls { ast = Atom pos "#t" }
List _ _ -> pure $ ls { ast = Atom pos "#f" }

List _ ((Atom _ "atom"):_) ->
evalError ls "syntax error"

List _ [Atom pos "eq", a, b] -> do
a' <- evalState $ ls { ast = a }
b' <- evalState $ ls { ast = b }
if ast a' == ast b' then
pure $ ls { ast = Atom pos "#t" }
else
pure $ ls { ast = Atom pos "#f" }

List _ ((Atom _ "eq"):_) ->
evalError ls "syntax error"

List p1 [Atom p2 "cons", a, b] -> do
a' <- evalState $ ls { ast = a }
b' <- evalState $ ls { ast = b }
pure $ ls { ast = List p1 [Atom p2 "cons", ast a', ast b'] }

List p1 ((Atom p2 "cons"):_) ->
evalError ls "syntax error"

List _ [Atom _ "car", a] -> do
a' <- evalState $ ls { ast = a }
case ast a' of
List _ [Atom _ "cons", a'', b] -> pure $ ls { ast = a'' }
_ -> evalError ls "car expect cons"

List _ ((Atom _ "car"):_) ->
evalError ls "syntax error"

List _ [Atom _ "cdr", a] -> do
a' <- evalState $ ls { ast = a }
case ast a' of
List _ [Atom _ "cons", a'', b] -> pure $ ls { ast = b }
_ -> evalError ls "car expect cons"

List _ ((Atom _ "cdr"):_) ->
evalError ls "syntax error"

-- apply
List pos (lambda : args) -> do
lambda' <- evalState $ ls { ast = lambda }
case ast lambda' of
List _ [Atom _ "lam", List _ names, body] ->
if length names == length args then do
args' <- mapM (\a -> ast <$> (evalState $ ls { ast = a })) args
let env' = M.union (M.fromList $ zip (map (\(Atom _ n) -> n) names) args') $ env ls
evalState $ ls { ast = body, env = env' }
else
evalError ls $
"lam expect " ++ (show $ length names) ++ " unexpect " ++ (show $ length args)

_ -> evalError lambda' "apply expect lam"



Lisp

トップレベルのインターフェイス関数群

文字列から実行したり、ファイルから実行したり


Lisp.hs

module Lisp where

import Lisp.AST
import Lisp.Parser
import Lisp.Eval

import System.Directory

runLisp' :: String -> String -> IO ()
runLisp' fn s = do
case parse s of
Left err -> print err
Right ast -> do
ast' <- eval ast
print ast'

runLisp = runLisp' "runLisp"

runLispFile f = do
bool <- doesFileExist f
if bool then do
s <- readFile f
runLisp' f s
else
fail $ f ++ " does not exist"



比較

と言っても単純なベンチマークです

フィボナッチ数計算で比べます

まず今回の再帰ベースのlispから

(do

(def 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 fib.lisp

832040
stack exec lisp example/fib.lisp 6.91s user 0.75s system 120% cpu 6.383 total

次に前回のSECDマシンのlisp

少々言語仕様が違いますが

(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 fib.lisp

832040
stack exec lisp lisp/fib.lisp 4.80s user 0.71s system 128% cpu 4.276 total

ふむ

- 素朴再帰 6.91s user 0.75s system 120% cpu 6.383 total

- SECDマシン 4.80s user 0.71s system 128% cpu 4.276 total

意外と開きましたね

コンパイルのオーバーヘッドがあるSECDマシンが不利かと思ったんですがそうでも無いみたいですね

SECDマシンすごい


次回

3impのヒープモデルを実装予定(未定(多分やらない))