Implementing functional languages を頑張って読む.20日目

20日目

やっと算術演算を実装する.
時間をかけて読んでるからここまで来るのがすごい時間かかった.

2.6 Mark 4: Adding arithmetic

dumpを使う初めてのセクション.

2.6.1 Transition rules for arithmetic

算術演算のための状態遷移を考えることから始める.
まず,一番シンプルな単項演算子の符号反転から考える.
その他の算術演算子も同様.

a : a1 : []	d	h	f
a1 : []	d	h'	f

h
a	NPrim Neg
a1	NAp a b
b	NNum n

h'
a1	NNum (-n)

と,なりそう.

これは,今スタックには符号反転とその引数しか積まれていないことに注意.それ以外の場合はエラーが起きる.

引数が(NNumではなく)まだ評価されていないとしたら,一体何が起こるだろうか?
引数を(これまでのスタックと混同しないために)新しいスタックに積んで評価する必要があり,これが終了したら,古いスタックを戻して再び符号反転に挑戦する.
これには古いスタックをどうにかして保存しておく必要があるので,dumpの使い方を説明しよう.
dumpは単なる,「スタックが要素となる」スタックである.

Negを評価するときのルールは,次のようになる:

a : a1 : []	d	h	f
b : []	(a : a1 : []) : d	h	f

これは,bがNNumではないときに使われる.

評価が終了すると,スタックを戻す必要がある:

a : []	s : d	h[a : NNum n]	f
s	d	h	f

古いスタックを戻すと,また符号反転演算子がスタックトップに見つかるが,今度は正規形になっている.

だけど注意しよう!
確かに符号反転の引数は正規形になったが,引数のルートノードが更新されているので,今やそれは間接参照ノードになっている.
即ち,Negの最初のルールはNNumノードを直接は見つけられないのだ((negate (id 3))を考えよ).

これを解決する最も簡単な方法は,適用ノードをunwindするルール(Rule 2.1)の直前に新たなルールを追加することだ.
適用される引数が間接参照ノードであるという特殊な場合に,このルールは,引数が間接参照ノードの参照先となっているような適用ノードに更新する.

a : s	d	h[a : NAp a1 a2, a2 : NInd a3]	f
a : s	d	h[a : NAp a1 a3]	f

このルールを利用するために,また,評価が終了した後にredexのルートから新たにunwindするために,Rule 2.6を変更する必要がある:
(訳に自信なし.In order to bring this rule into play, we need to modify Rule 2.6 so that it unwinds anew from the root of the redex after the evaluation is completed:)
意味的には,NPrim Negノードを取って,NApの適用を評価すれば,計算が続行する.だと思う.

a : a1 : []	d	h	f
b : []	(a1 : []) : d	h	f

これは少々面倒であり,続くチャプターで行う実装ではもっといい方法がある.
(じゃあ初めっからそれを紹介しろよ,と思いましたまる)

Exercise 2.15

加算のための遷移ルールを書き下せ.(他の二項算術演算子も実質的に同様である)

a : a1 : a2 : []	d	h	f
a1 : []	d	h'	f

h
a	NPrim Add
a1	NAp a b1
a2	NAp a1 b2
b1	NNum n
b2	NNum m

h'
a1	NNum (n + m)

となる.他の演算子も同様.

b1,b2がNNumじゃないときはdumpを使うのか?
その時,b1とb2を両方評価するのかな.よくわからんけど次あたりに書いてそう.

2.6.2 Implementing arithmetic

算術演算子を実装するために多少手を加えるところが出てくる.
最初にTiDumpを変更する.

名前がnで値がpであるようなNPrim n pノードを実装する.
値はdata Primitive = Neg | Add | Sub | Mul | Divのいずれか.
NSupercombの時と同様に,名前はデバッグ用にのみ用いる.

showNodeもこれを扱えるように変更する必要がある.

それでは,それぞれのsupercombinatorに対してNSupercombをヒープに確保したのと同様に,それぞれのprimitiveに対してNPrimノードをヒープに確保する.
新たな,それぞれのprimitiveからアドレスへの束縛を,supercombinatorのときと同様に,マシンの状態を構成するglobalsに追加する.
これは,buildInitialHeapの定義を変更することによって簡単に行える.

また,さらなるプリミティブを追加したい場合は,Primitiveタイプとprimitivesを変更すれば良い.

allocateScと非常に似ているallocatePrimを定義する.

次に,stepの中のdispatch関数が,NPrimノードを見つけたときにprimStepを呼ぶように変更する必要がある.
primStepは使われたプリミティブに対しcaseで分岐し,primNegやprimAddのような実際に演算をする補助関数を呼び出す.
さしあたりprimStepは符号反転だけを含むこととする.

primNegは以下のことを行う必要がある:

• getArgsを用いスタック上から引数のアドレスを展開し,hLookupを用いそのアドレスによって指し示されているノードを得る.
• 引数が評価済みかどうかを補助関数のisDataNodeを使い調べる.
• 未評価ならば,Rule 2.9によりその引数を評価するための新しいスタックを準備する. これは現在のスタックをdumpにプッシュし,negateの引数だけを要素に持つ新しいスタックを作ることを必要とする.
• 評価済みならば,hUpdateを使いredexのルートを結果が入っているNNumノードで上書きし,スタックを適切に操作した上で制御を返す.

次に,数値をunwindするために新しいルールを実装する必要がある.
ルール2.7を実装するためにnumStepの定義は変更されなければならない.
もしスタックがただ一つの要素だけで,そのアドレスがNNumノードであり,かつdumpが空でないならば,dumpの先頭の要素を新しいスタックにする.
これらの状況でなければ,エラーが起きる.
同様に,apStepの定義もルール2.7を実装するために変更されなければならない.
これは引数が間接参照ノードかどうか確認し,hUpdateを使うことによって実現できる.

最後に,TiFinalも変更する必要がある.
現在はスタックにNNumしか含まないときに実行を停止するが,この動作はdumpが空のときにのみ実行されなければならない.
そうでないと新しいルール2.7を実行する機会がないからね!

Exercise 2.16

これらの変更を実装し,main = negate (I 3)などとして正しく動くか試せ.
→やった.動いた.

この明らかな拡張は今や加減乗除を実装することである.
これらはほぼ同じなのでPrimArithという高階関数を使って対応する事により,モジュール性を高めることができる.

Exercise 2.17

PrimArithを実装して動かせ.

というかこの本わりと読者にぶん投げ過ぎじゃない?
二項演算のb1,b2の評価も自分で考えろってことですか.

• b1,b2のアドレスをgetargsで取得
• 指し示すノードが両方NNumかどうか確認
• 違ったら新しいスタックを作って評価
• 両方NNumなら算術演算を実行

でできるかな?

途中,LanguageのpOneOrMoreがバグってたので直した.
実際ここはチートして(ネットで実装を見つけて)書いた場所だったのでよく理解していなかった.
正しい関数に直せてよかった.

結果,main = (3 * negate (I 3) + (15 / 3) - 7 * 3) + (8 / 2) + 4 * 4みたいなのが実行できるようになった.
この言語の-や/は1-2-3みたいにできないので,いちいち括弧が必要.
時間があったら直そう.

2.6が終わり.算術演算ができるようになったが,僕の怠慢のつけを払うことになった.やっぱり理解しないでコードをコピるのは良くないね.

diffとったやーつ

Language.hs

diff --git a/Language.hs b/Language.hs
index 7f81355..eea8689 100644
--- a/Language.hs
+++ b/Language.hs
@@ -224,13 +224,13 @@ pEmpty :: a -> Parser a
 pEmpty s toks = [(s, toks)]

 pOneOrMore :: Parser a -> Parser [a]
-pOneOrMore p = (take 1) . (pThen (:) p (pZeroOrMore p))
+pOneOrMore p = (pThen (:) p (pZeroOrMore p))

 pApply :: Parser a -> (a -> b) -> Parser b
 pApply a f toks = [(f b, tokens) | (b, tokens) <- a toks]

 pOneOrMoreWithSep :: Parser a -> Parser b -> Parser [a]
-pOneOrMoreWithSep a b = (take 1) . (pThen (:) a ((pThen (\_ x -> x) b (pOneOrMoreWithSep a b)) `pAlt` (pEmpty [])))
+pOneOrMoreWithSep a b = (pThen (:) a ((pThen (\_ x -> x) b (pOneOrMoreWithSep a b)) `pAlt` (pEmpty [])))

 pSat :: (String -> Bool) -> Parser String
 pSat pd = pSatpred

Main.hs

diff --git a/Main.hs b/Main.hs
index 651f971..9ee601c 100644
--- a/Main.hs
+++ b/Main.hs
@@ -8,13 +8,16 @@ runProg = showResults . eval . compile . parse

 type TiState = (TiStack, TiDump, TiHeap, TiGlobals, TiStats)
 type TiStack = [Addr]
-data TiDump = DummyTiDump
-initialTiDump = DummyTiDump
+type TiDump = [TiStack]
+initialTiDump = []
 type TiHeap = Heap Node
 data Node = NAp Addr Addr -- Application
     | NSupercomb Name [Name] CoreExpr -- Supercombinator
     | NNum Int -- Number
     | NInd Addr -- Indirection
+    | NPrim Name Primitive -- Primitive
+
+data Primitive = Neg | Add | Sub | Mul | Div

 type TiGlobals = ASSOC Name Addr
 tiStatInitial :: TiStats
@@ -41,13 +44,24 @@ compile program = (initial_stack, initialTiDump, initial_heap, globals, tiStatIn
 extraPreludeDefs = []

 buildInitialHeap :: [CoreScDefn] -> (TiHeap, TiGlobals)
-buildInitialHeap sc_defs = mapAccuml allocateSc hInitial sc_defs
+buildInitialHeap sc_defs = (heap2, sc_addrs ++ prim_addrs)
+    where
+    (heap1, sc_addrs) = mapAccuml allocateSc hInitial sc_defs
+    (heap2, prim_addrs) = mapAccuml allocatePrim heap1 primitives
+
+primitives :: ASSOC Name Primitive
+primitives = [ ("negate", Neg), ("+", Add), ("-", Sub), ("*", Mul), ("/", Div) ]

 allocateSc :: TiHeap -> CoreScDefn -> (TiHeap, (Name, Addr))
 allocateSc heap (name, args, body) = (heap', (name, addr))
     where
     (heap', addr) = hAlloc heap (NSupercomb name args body)

+allocatePrim :: TiHeap -> (Name, Primitive) -> (TiHeap, (Name, Addr))
+allocatePrim heap (name, prim) = (heap', (name, addr))
+    where
+    (heap', addr) = hAlloc heap (NPrim name prim)
+
 eval :: TiState -> [TiState]
 eval state = state : rest_states
 --eval state | tiFinal state = [state]
@@ -61,7 +75,7 @@ doAdmin :: TiState -> TiState
 doAdmin state = applyToStats tiStatIncSteps state

 tiFinal :: TiState -> Bool
-tiFinal ([sole_addr], dump, heap, globals, stats) = isDataNode (hLookup heap sole_addr)
+tiFinal ([sole_addr], [], heap, globals, stats) = isDataNode (hLookup heap sole_addr)
 tiFinal ([], dump, heap, globals, stats) = error "Empty stack!"
 tiFinal state = False -- Stack contains more than one item

@@ -77,22 +91,30 @@ step state = dispatch (hLookup heap (hd stack))
     dispatch (NAp a1 a2) = apStep state a1 a2
     dispatch (NSupercomb sc args body) = scStep state sc args body
     dispatch (NInd addr) = indStep state addr
+    dispatch (NPrim n p) = primStep state n p

 numStep :: TiState -> Int -> TiState
-numStep state n = error "Number applied as a function!"
+numStep (stack, dump, heap, globals, stats) n
+    = if length stack > 1 || null dump
+        then error "Number applied as a function!"
+        else (head dump, tail dump, heap, globals, stats)

-apStep :: TiState -> Addr -> Addr -> TiState
-apStep (stack, dump, heap, globals, stats) a1 a2 = (a1 : stack, dump, heap, globals, (s, r, if d < length stack + 1 then d + 1 else d)) where (s, r, d) = stats

-indStep :: TiState -> Addr -> TiState
-indStep (stack, dump, heap, globals, stats) addr = (addr : (tail stack), dump, heap, globals, stats)
+apStep :: TiState -> Addr -> Addr -> TiState
+apStep (stack, dump, heap, globals, stats) a1 a2
+    = case hLookup heap a2 of
+        (NInd a3) -> (stack, dump, hUpdate heap (head stack) (NAp a1 a3), globals, stats)
+        _         -> (a1 : stack, dump, heap, globals, (s, r, new_d))
+    where
+    (s, r, d) = stats
+    new_d = if d < length stack + 1 then d + 1 else d

 scStep :: TiState -> Name -> [Name] -> CoreExpr -> TiState
 scStep (stack, dump, heap, globals, stats) sc_name arg_names body
     = (new_stack, dump, new_heap, globals, new_stats)
     where
     new_stack = if length arg_names + 1 <= length stack then result_addr : (drop (length arg_names + 1) stack) else error "too few arguments"
-    upd_addr = head (drop (length arg_names) stack) -- stack[n] == a_n for p65 (2.3)
+    upd_addr = stack !! (length arg_names) -- stack[n] == a_n for p65 (2.3)
     --(new_heap, result_addr) = instantiate body heap env
     new_heap = instantiateAndUpdate body upd_addr heap env
     result_addr = upd_addr
@@ -103,7 +125,43 @@ scStep (stack, dump, heap, globals, stats) sc_name arg_names body
 -- now getargs since getArgs conflicts with Gofer standard.prelude
 getargs :: TiHeap -> TiStack -> [Addr]
 getargs heap (sc:stack) = map get_arg stack
-    where get_arg addr = arg where (NAp fun arg) = hLookup heap addr
+    where get_arg addr = arg where (NAp _ arg) = hLookup heap addr
+
+indStep :: TiState -> Addr -> TiState
+indStep (stack, dump, heap, globals, stats) addr = (addr : (tail stack), dump, heap, globals, stats)
+
+primStep :: TiState -> Name -> Primitive -> TiState
+primStep state _ Neg = primNeg state
+primStep state _ Add = primArith state (+)
+primStep state _ Sub = primArith state (-)
+primStep state _ Mul = primArith state (*)
+primStep state _ Div = primArith state div
+
+primNeg :: TiState -> TiState
+primNeg (stack, dump, heap, globals, stats) = new_state
+    where
+    arg_addr = head (getargs heap stack)
+    node = hLookup heap arg_addr
+    (NNum n) = node
+    (s, (rsc, rp), d) = stats
+    new_state = if isDataNode node
+                    then (tail stack, dump, hUpdate heap (stack !! 1) (NNum (-n)), globals, (s, (rsc, rp + 1), d))
+                    else (arg_addr : [], (tail stack) : dump, heap, globals, stats)
+
+primArith :: TiState -> (Int -> Int -> Int) -> TiState
+primArith (stack, dump, heap, globals, stats) op = new_state
+    where
+    arg_addrs = take 2 (getargs heap stack)
+    lnode = hLookup heap (arg_addrs !! 0)
+    rnode = hLookup heap (arg_addrs !! 1)
+    (NNum n) = lnode
+    (NNum m) = rnode
+    (s, (rsc, rp), d) = stats
+    new_state = if isDataNode lnode
+                    then if isDataNode rnode
+                            then (drop 2 stack, dump, hUpdate heap (stack !! 2) (NNum (op n m)), globals, (s, (rsc, rp + 1), d))
+                            else (arg_addrs !! 1 : [], (drop 2 stack) : dump, heap, globals, stats)
+                    else (arg_addrs !! 0 : [], (drop 1 stack) : dump, heap, globals, stats)

 instantiate
     :: CoreExpr -- Body of supercombinator
@@ -180,8 +238,8 @@ showResults states = iDisplay ( iConcat [ showState (last states), showStats (la
 showState :: TiState -> Iseq
 showState (stack, dump, heap, globals, stats)
     = iConcat [
-        showStack heap stack, iNewline --,
- --       showHeap heap, iNewline
+        showStack heap stack, iNewline ,
+        showHeap heap, iNewline
     ]

 showHeap :: TiHeap -> Iseq
@@ -232,6 +290,7 @@ showNode (NAp a1 a2)
 showNode (NSupercomb name args body) = iStr ("NSupercomb " ++ name)
 showNode (NNum n) = (iStr "NNum ") `iAppend` (iNum n)
 showNode (NInd addr) = (iStr "NInd ") `iAppend` (showAddr addr)
+showNode (NPrim n p) = (iStr ("NPrim name:[" ++ n ++ "] ")) `iAppend` (showPrim p)

 showAddr :: Addr -> Iseq
 showAddr addr = iStr (show addr)
@@ -241,6 +300,13 @@ showFWAddr addr = iStr (space (4 - length str) ++ str)
     where
     str = show addr

+showPrim :: Primitive -> Iseq
+showPrim Neg = iStr "Neg"
+showPrim Add = iStr "Add"
+showPrim Sub = iStr "Sub"
+showPrim Mul = iStr "Mul"
+showPrim Div = iStr "Div"
+
 showStats :: TiState -> Iseq
 showStats (stack, dump, heap, globals, stats)
     = iConcat [
@@ -253,6 +319,8 @@ showStats (stack, dump, heap, globals, stats)
     ]

 main :: IO ()
-main = putStrLn $ runProg $ "main = W C (W C) (W C) (W C) I 3"
+--main = putStrLn $ runProg $ "main = negate (I 3)"
+main = putStrLn $ runProg $ "main = (3 * negate (I 3) + (15 / 3) - 7 * 3) + (8 / 2) + 4 * 4"
+--main = putStrLn $ runProg $ "main = W C (W C) (W C) (W C) I 3"
 --main = putStrLn $ runProg $ "main = letrec x = x f in x; x = 5; two = S C I; inc = S C; three = inc two; add = C S (C C); mul = C"
---main = putStrLn $ runProg $ "pair x y f =f x y ; fst p = p K ; snd p= p F; f x y = letrec a = pair x b ; b = pair y a in fst (snd (snd (snd a))) ; main = f 3 4"
+--main = putStrLn $ runProg $ "pair x y f = f x y ; fst p = p K ; snd p= p F; f x y = letrec a = pair x b ; b = pair y a in fst (snd (snd (snd a))) ; main = f 3 4"