Help us understand the problem. What is going on with this article?

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

More than 3 years have 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のヒープモデルを実装予定(未定(多分やらない))

kmtoki
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