GMachine on Haskell

-- 相変わらずParse Monadをぴゃぴゃっと書いてる
module Parser where

import Data.Char
import Control.Monad

data Result val rem = Parsed val rem
                    | NoParse
                      deriving Show

data Parser a = Parser (String -> Result a String)

ext_parser :: Parser a -> (String -> Result a String)
ext_parser (Parser p) = p

get_value :: Result val rem -> val
get_value (Parsed val rem) = val

instance Monad Parser where
    return a = Parser (\cs -> Parsed a cs)
                      
    p1 >>= f = Parser parse
        where parse cs = first ( (ext_parser p1) cs )
              first (Parsed val rem) =
                  let Parser p2 = f val
                  in second (p2 rem)
              first NoParse = NoParse

              second (Parsed val rem) = Parsed val rem
              second NoParse          = NoParse

instance MonadPlus Parser where
    mzero = Parser (\cs -> NoParse)

(Parser p) <|> (Parser q) = Parser (\cs -> case p cs of
                                             Parsed val rem -> Parsed val rem
                                             NoParse        -> q cs)

item :: Parser Char
item = Parser (\str -> case str of
                         ""     -> NoParse
                         (c:cs) -> Parsed c cs)

satisfy :: (Char -> Bool) -> Parser Char
satisfy p = do c <- item
               if p c
                 then return c
                 else mzero

char :: Char -> Parser Char
char c = satisfy (c ==)

string :: String -> Parser String
string ""     = return ""
string (c:cs) = do char c
                   string cs
                   return (c:cs)

many :: Parser a -> Parser [a]
many p = many1 p <|> return []

many1 :: Parser a -> Parser [a]
many1 p = do {a <- p;as <- many p; return (a:as)}

sepby :: Parser a -> Parser b -> Parser [a]
p `sepby` sep = (p `sepby1` sep) <|> return []

sepby1 :: Parser a -> Parser b -> Parser [a]
p `sepby1` sep = do a <- p
                    as <- many $ sep >> p -- セパレータの食い残しをpに食わせる
                    return (a:as)

white1 :: Parser String
white1 = many1 $ satisfy isSpace

word :: Parser String
word = many1 $ satisfy isAlpha

i_int :: Parser Int
i_int = do a <- many1 $ satisfy isDigit
           return $ read a

s_int :: Parser String
s_int = many1 $ satisfy isDigit

-- Version2
import Data.Char
import Data.List
import Parser

data Prog = Prog [SC] Exp deriving Show
data SC   = SC String [String] Exp deriving Show
data Exp  = Const Int | Var String | GFun String | App Exp Exp deriving Show
data Ope  = Pushint Int | Pushglobal String | Update Int | Push Int | Pop Int | Mkap | Unwind
          | Eval | Add | Les | Gre | Eq | Cond [Ope] [Ope] deriving Show

-- data HeapTree = NNum Int | NGlobal Int [Ope] | NAp Point Point | NInd Point
data HeapNode = NNum Int | NBool Bool | NGlobal Int [Ope] | NAp Point Point | NInd Point deriving Show

{-
NAp NIndは、ヒープ上のHeapNodeを指す為にインデックスを使っている。
-}
type Point  = Int -- インデックスを表す。
type Code   = [Ope]
type Stack  = [Point] -- ヒープ上のインデックス
type Dump   = [(Code,Stack)]
type Heap   = [HeapNode] -- tree作ってるから本当はHeapTreeの方が適当な気もする
type Global = [String] -- 関数名が入っている
type MachineState = (Code,Stack,Dump,Heap,Global)

int :: Int -> Exp
int x = Const x

var :: String -> Exp
var x = Var x

make_cenv :: [String] -> [(String,Int)]
make_cenv arg = zip arg [0..]

sc_scheme :: SC -> [Ope]
sc_scheme (SC name arg exp) = r_scheme exp (make_cenv arg) (length arg)

r_scheme :: Exp -> [(String,Int)] -> Int -> [Ope]
r_scheme exp cenv n = (c_scheme exp cenv) ++ [Update n,Pop n,Unwind]

lookup_var :: String -> [(String,Int)] -> Int
lookup_var var cenv = case lookup var cenv of
                        Just offset -> offset
                        Nothing     -> -1

c_scheme :: Exp -> [(String,Int)] -> [Ope]
c_scheme (GFun f)  p = [Pushglobal f]
c_scheme (Var x)   p = [Push $ lookup_var x p]
c_scheme (Const i) p = [Pushint i]
c_scheme (App e0 e1) p = (c_scheme e1 p) ++ (c_scheme e0 (p_n 1 p)) ++ [Mkap]
    where p_n n p = map (\(var,offset) -> (var,offset+n)) p

parse_term :: [String] -> Parser Exp
parse_term args = (parse_call args) <|> tfunc <|> tint
    where tfunc = do str <- fname
                     if elem str args
                       then return (Var str)
                       else return (GFun str)
          tint  = do int <- i_int
                     return (Const int)
          fname = do w  <- satisfy isAlpha <|> satisfy isSymbol
                     ws <- many (satisfy isAlpha <|> satisfy isNumber <|> satisfy isSymbol)
                     return (w:ws)

parse_call :: [String] -> Parser Exp
parse_call args = do char '('
                     fun_name <-  (parse_term args) `sepby1` white1
                     char ')'
                     return $ make_term fun_name
    where make_term :: [Exp] -> Exp
          make_term terms = foldl (App) (App (terms!!0) (terms!!1)) (drop 2 terms)

def_fun :: String -> [String] -> String -> SC
def_fun str args exp = def_fun' str args (get_value $ ext_parser (parse_term args) exp)
    where def_fun' :: String -> [String] -> Exp -> SC
          def_fun' f xn exp = SC f xn exp

parse_exp :: String -> Exp
parse_exp exp = get_value $ ext_parser (parse_term []) exp

eval :: [Ope] -> [Int] -> [([Ope], [Int])] -> [HeapNode] -> [String] -> [[String]] -> (Int, [[String]])
eval ((Pushint int):codes) stack dump heap global log = eval codes ((length heap):stack) dump (heap++[NNum int]) global log

eval ((Pushglobal f):codes) stack dump heap global log = eval codes ((find f global):stack) dump heap global log
    where find :: String -> [String] -> Int
          find f' global' = case elemIndex f' global' of
                              Just pos -> pos
                              Nothing  -> -1

eval ((Mkap):codes) (a1:a2:s) dump heap global log = eval codes ((length heap):s) dump (heap++[NAp a1 a2]) global log

eval ((Push n):codes) stack dump heap global log = eval codes ((stack!!n):stack) dump heap global log

eval ((Pop n):codes) stack dump heap global log = eval codes (drop n stack) dump heap global log

eval ((Update n):codes) stack dump heap global log = eval codes update_stack dump update_heap global log
    where update_heap = (take (stack!!(n+1)) heap) ++ [NInd (head stack)] ++ (drop ((stack!!(n+1))+1) heap)
          update_stack = tail stack

eval (Eval:codes) (a:s) dump heap global log = eval [Unwind] [a] ((codes,s):dump) heap global log

eval (Unwind:codes) stack dump heap global log = eval_unwind codes stack dump heap global log

{-
ユーザ定義(?)の関数群
-}
eval (Add:codes) (a0:a1:s) dump heap global log = eval codes ((length heap):s) dump (heap++[NNum (lval + rval)]) global log
    where (NNum lval) = heap!!a0
          (NNum rval) = heap!!a1
eval (Les:codes) (a0:a1:s) dump heap global log = eval codes ((length heap):s) dump (heap++[nnum (lval < rval)]) global log
    where (NNum lval) = heap!!a0
          (NNum rval) = heap!!a1
eval (Gre:codes) (a0:a1:s) dump heap global log = eval codes ((length heap):s) dump (heap++[nnum (lval > rval)]) global log
    where (NNum lval) = heap!!a0
          (NNum rval) = heap!!a1
eval (Eq:codes) (a0:a1:s) dump heap global log = eval codes ((length heap):s) dump (heap++[nnum (lval == rval)]) global log
    where (NNum lval) = heap!!a0
          (NNum rval) = heap!!a1
eval ((Cond i1 i2):codes) (a:s) dump heap global log = case heap!!a of
                                                         NNum 1  -> eval (i1++codes) s dump heap global log
                                                         NNum 0  -> eval (i2++codes) s dump heap global log
nnum :: Bool -> HeapNode
nnum True  = NNum 1
nnum False = NNum 0


eval_unwind :: [Ope] -> [Int] -> [([Ope], [Int])] -> [HeapNode] -> [String] -> [[String]] -> (Int, [[String]])
eval_unwind code stack@(top:lefts) dump heap global log = 
    case heap!!top of
      NNum n -> if null dump
                then (n,log)
                else eval (fst $ head dump) (top:(snd $ head dump)) (tail dump) heap global log
      NAp a1 a2 -> eval_unwind code (a1:stack) dump heap global log
      NInd a -> eval_unwind code (a:lefts) dump heap global log
      NGlobal n c -> if (length lefts) < n
                     then eval (fst $ head dump) ((head $ reverse lefts):(snd $ head dump)) (tail dump) heap global log
                     else eval new_code new_stack dump heap global
                              (log++[[show new_code,
                                      show $ get_heap $ take n new_stack,
                                      show $ heap]])
    where (new_code,new_stack) = goto_globalfunc (heap!!top)
          goto_globalfunc (NGlobal arity fcode) = (fcode,
                                                   (get_args $ take arity $ tail stack) ++ [stack!!arity])
          get_args points = map (\x -> let (NAp l r) = (heap!!x) in r) points
          get_heap points = map (\x -> heap!!x) points


make_heap_global :: [SC] -> ([HeapNode], [String])
make_heap_global scs = (make_heap scs,make_global scs)

make_heap :: [SC] -> [HeapNode]
make_heap []                      = []
make_heap ((SC name arg exp):scs) = (NGlobal (length arg) (sc_scheme (SC name arg exp))):(make_heap scs)

make_global :: [SC] -> [String]
make_global []                    = []
make_global ((SC name arg exp):scs) = name:(make_global scs)


main_exp str = (c_scheme (parse_exp str) []) ++ [Unwind]
(heap',global') = make_heap_global [def_fun "f1" ["x1","x2"] "x1",def_fun "f2" ["x1","x2"] "x2"]
(gm_add_heap,gm_add_global) =  ([NGlobal 2 [Push 1,Eval,Push 1,Eval,Add,Update 2,Pop 2,Unwind]],["+"])
(gm_les_heap,gm_les_global) =  ([NGlobal 2 [Push 1,Eval,Push 1,Eval,Les,Update 2,Pop 2,Unwind]],["<"])
(gm_gre_heap,gm_gre_global) =  ([NGlobal 2 [Push 1,Eval,Push 1,Eval,Gre,Update 2,Pop 2,Unwind]],[">"])
(gm_eq_heap,gm_eq_global) =  ([NGlobal 2 [Push 1,Eval,Push 1,Eval,Eq,Update 2,Pop 2,Unwind]],["=="])
(gm_if_heap,gm_if_global) =  ([NGlobal 3 [Push 0,Eval,Cond [Push 1] [Push 2],Update 3,Pop 3,Unwind]],["if"])
(gm_heap,gm_global) = (heap' ++ gm_add_heap ++ gm_les_heap ++ gm_gre_heap ++ gm_eq_heap ++ gm_if_heap,
                       global' ++ gm_add_global ++ gm_les_global ++ gm_gre_global ++ gm_eq_global ++ gm_if_global)
ope' = main_exp "(if (< 1 2) 1 2)"

main = print $ eval ope' [] [] gm_heap gm_global []

コードの殴り書き。

http://www.jaist.ac.jp/~kiyoshiy/writing/gmachine.pdf

ちょっと前に書いた似非は似非で動いたのですが、SECDを元(にしてるのかしらこれは??)な感じでgraph-reductionを適当な命令群だけで実行出来る様にしたmachineの事です。

ただコードを書き直しただけな気がしますが、これでも色々とピンと来ない所もあったので、自分でstackやらheapを紙に書きまくって色々と理解しました。

突っかかってたのはpushする所かなーとかそんな感じかもしれません。

超似非との違いは・・・まぁよりgraph弄ってるっていう感じがあるのと、call-by-needはheap上で見やすい形で展開されていくとかそんな感じかもしれません。

何か習得した気はしないのですが、1週間近くも無い頭で色々と考えていたので、多分何かしら力に成ってくれたとは思います。