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

# 19日目
久しぶりに書く.
虎本が_instantiation_を実体と訳していたので,_instantiate_をこれから実体化と書くことにする.

## 2.5 Mark 3: Adding updating
今までのマシンはグラフの更新をしていなかったので,同じ部分式の出現に対し2回計算をさせていた.
例えば,

```
W x y = x y y
main = W I (K I I) 0
```

など.
この時,mainは`W I (K I I) (K I I) 0`と展開されるわけだが,Wの引数の(K I I)は同じ場所を参照しているので,最初の(K I I)を実体化した時に結果がわかり,二回目の(K I I)の実体化はその結果を使用することができる.
これはこの言語が純粋だからできる.

これを解決するため,間接参照ノード,(NInd Addr)型を追加する.
最初の実体化のときに,rootの参照先を(NInd 実体先アドレス)で更新することにより,余計な計算を省く.
また,NInd型に対応するため,ステートマシンに新しいルールを追加する.

Exerciseで効果を測定しろと会ったので, `main = main = W C (W C) (W C) (W C) I 3`を計算させる.
単純計算で2^16回,即ち65536回Iを3に適用する.

```:結果と実行時間.NIndなし
Stack [ (top)
  17: NNum 3
]


Total number of steps = 805726
Total number of reductions = 258295
Total number of supercombinator reductions = 1
Total number of primitive reductions = 258294
Maximum of stack depth = 7

real    215m43.150s
user    215m1.582s
sys     0m1.637s
```

```:結果.NIndあり
Stack [ (top)
  17: NNum 3
]


Total number of steps = 485349
Total number of reductions = 131114
Total number of supercombinator reductions = 1
Total number of primitive reductions = 131113
Maximum of stack depth = 7

real    49m10.059s
user    48m59.786s
sys     0m0.423s
```

最後にまとめて表にしたものを出すが,NIndありの方はステップ数が60%,簡約の数が50%になっていて,時間は25%と高速になっている.
NIndの ちからって すげー!

### 2.5.1 Reducing the number of indirections
今回,新しくinstantiateされたときにNIndを使って更新したが,直接更新できる場合もある.
redexのrootの頂点は直接結果で置き換えることができる.
何故なら,rootの頂点を実体化した結果は新しく作り出されるものであり,この更新をすることによって失われるような共有物はないし(no sharing can be lost by doing this),また,さらなるノードを作り出すのを抑えることができる.

今まではグラフをupdate,更新していなかったが,更新することによって高速化できる.
hAllocしか使っていなかったので,実体化するたびに新しいnodeを確保していた.
しかもgcなんて無いので,確保したら確保しっぱなしで,どんどんのヒープが伸びる.
これは,heapの検索をするときに大幅にボトルネックになる.
(Lookup系の関数はリニアサーチ)

` instantiateAndUpdate`という関数を使ってupdateする.
exercise 2.14でこの定義を完成させよとかあるけど,まあ前のinstantiateをコピるだけ.
注意として,updateできるのはrootだけなので,再帰する方は昔のinstantiateを使わないといけない.
変数はNIndが必要である.何故か?
→ hUpdateは引数にNode型を取るが,aLookupで見つかる束縛はAddressのため,NIndでラップする必要があるから.
注意してlet(rec)を実装せよとか書いてあったけど,束縛を作るときはどうしても新しいノードが必要なので,bodyを実体化するときだけUpdateするようにした.
上手くいってるのでこれで良しとする.

2.5のベンチマークをこの変更後にもう一度やってみる

```:結果.Updateあり
Stack [ (top)
  17: NNum 3
]


Total number of steps = 485349
Total number of reductions = 131114
Total number of supercombinator reductions = 1
Total number of primitive reductions = 131113
Maximum of stack depth = 7

real    10m28.507s
user    10m27.380s
sys     0m0.133s
```

まあlet(rec)も使わないただの簡約だけなので,上の結果が同じなのはまあそうかという感じ.
時間が10分ちょいで終わる,heapの伸長を抑えられるとこんなに違うのか.

***2.5が終わり.こんな感じで小さい機能をちょっとづつ足していく感じぽい?***

diff取ったやーつ

```hs:Main.hs
diff --git a/Main.hs b/Main.hs
index 8509f0d..651f971 100644
--- a/Main.hs
+++ b/Main.hs
@@ -84,25 +84,29 @@ numStep state n = error "Number applied as a function!"
 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 :: TiState -> Addr -> TiState
 indStep (stack, dump, heap, globals, stats) addr = (addr : (tail stack), dump, heap, globals, stats)
 
 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"
-        (new_heap, result_addr) = instantiate body heap env
-        env = arg_bindings ++ globals
-        arg_bindings = zip arg_names (getargs heap stack)
-        new_stats = (s, if elem sc_name [prim | (prim, _, _) <- preludeDefs] then (rsc, rp + 1) else (rsc + 1, rp), d) where (s, (rsc, rp), d) = stats
+    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)
+    --(new_heap, result_addr) = instantiate body heap env
+    new_heap = instantiateAndUpdate body upd_addr heap env
+    result_addr = upd_addr
+    env = arg_bindings ++ globals
+    arg_bindings = zip arg_names (getargs heap stack)
+    new_stats = (s, if elem sc_name [prim | (prim, _, _) <- preludeDefs] then (rsc, rp + 1) else (rsc + 1, rp), d) where (s, (rsc, rp), d) = stats
 
 -- 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
 
-instantiate :: CoreExpr -- Body of supercombinator
+instantiate
+    :: CoreExpr -- Body of supercombinator
     -> TiHeap -- Heap before instantiation
     -> ASSOC Name Addr -- Association of names to addresses
     -> (TiHeap, Addr) -- Heap after instantiation, and
@@ -127,7 +131,7 @@ instantiateLet isrec defs body heap env = instantiate body new_heap new_env -- c
         where
         (heap1, a1) = instantiate expr heap (if isrec then new_env else env)
 -- 正格評価だとmapの中でのinstantiateの中のEVarの出現をマークしてbindの中にその識別子があるかどうかを調べ,有ったらaddr=-indexなどどしておき,全てのrhssのinstantiateが終わったらaddrが負になっている所を実際のaddrに直す,?
--- instantiateの型が変わるよみたいな.isrecとbindを引廻なさないといけない
+-- instantiateの型が変わるよみたいな.isrecとbindを引廻さないといけない
 {-
 instantiateLet isrec defs body heap env = instantiate body new_heap new_env --error "Can't instantiate let(rec)s yet"
     where
@@ -143,7 +147,8 @@ getrhss isrec rhss heap env = (new_heap, result_addr)
         where (new_heap, result_addr) = instantiate expr heap env
 -}
 
-instantiateAndUpdate :: CoreExpr -- Body of supercombinator
+instantiateAndUpdate
+    :: CoreExpr -- Body of supercombinator
     -> Addr
     -> TiHeap
     -> ASSOC Name Addr
@@ -154,24 +159,29 @@ instantiateAndUpdate (EAp e1 e2) upd_addr heap env = hUpdate heap2 upd_addr (NAp
     where
     (heap1, a1) = instantiate e1 heap env
     (heap2, a2) = instantiate e2 heap1 env
---instantiateAndUpdate (EVar v) upd_addr heap env = (heap, aLookup env v (error ("Undefined name " ++ show v)))
-instantiateAndUpdate (EVar v) upd_addr heap env = hUpdate heap (aLookup env v (error ("Undefined name " ++ show v)))
+instantiateAndUpdate (EVar v) upd_addr heap env = hUpdate heap upd_addr (NInd (aLookup env v (error ("Undefined name " ++ show v))))
 instantiateAndUpdate (EConstr tag arity) upd_addr heap env = instantiateAndUpdateConstr tag arity upd_addr heap env
-instantiateAndUpdate (ELet isrec defs body) upd_addr heap env = instantiateAndUpdateLet isrec defs body heap env
+instantiateAndUpdate (ELet isrec defs body) upd_addr heap env = instantiateAndUpdateLet isrec defs body upd_addr heap env
 instantiateAndUpdate (ECase e alts) upd_addr heap env = error "Can't instantiate case exprs"
 
 instantiateAndUpdateConstr tag arity upd_addr heap env = error "Can't instantiate constructors yet"
 
-instantiateAndUpdateLet isrec defs body upd_addr heap env = error "Can't instantiate let(rec)s yet"
+instantiateAndUpdateLet isrec defs body upd_addr heap env = instantiateAndUpdate body upd_addr new_heap new_env
+    where
+    ((new_heap, new_env), result_addr) = mapAccumR f (heap, env) defs
+    f (heap, env) (name, expr) = ((heap1, (name, a1) : env), a1)
+        where
+        (heap1, a1) = instantiate expr heap (if isrec then new_env else env)
 
 showResults :: [TiState] -> String
-showResults states = iDisplay (iConcat [ iLayn (map showState states), showStats (last states) ])
+--showResults states = iDisplay ( iConcat [ iLayn (map showState states), showStats (last states) ])
+showResults states = iDisplay ( iConcat [ showState (last states), showStats (last states) ])
 
 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
@@ -243,10 +253,6 @@ showStats (stack, dump, heap, globals, stats)
     ]
 
 main :: IO ()
-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 $ "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 $ iDisplay $ pprExpr (ELet nonRecursive [("att", ENum 2)] (EAp (EAp (EVar "+") (EVar "att")) (EVar "1")))
---main = putStrLn( pprint $ parse  "f=3;\ng x y = let z = x in z ;\nh x = case (let y = x in y) of\n<1> -> 2 ;\n<2> -> 5;\n i = g (1 + 2 * 3) (5 - 1 / 2)")
---main = putStrLn $ show $ pOneOrMoreWithSep (pLit "x") (pLit ";") [(1,"x"),(1,";"),(1,"x") ,(1,";"),(2,"x"),(2,";"),(2,"x"),(2,";"),(2,"x") ]
---main = putStrLn $ show $ pExpr [(2,"let"),(2,"z"),(2,"="),(2,"x"),(2,"in"),(2,"z")]
---main = putStrLn $ pprint $ syntax [(1,"f"),(1,"="),(1,"3") ,(1,";"),(2,"g"),(2,"x"),(2,"y"),(2,"="), (2,"let"),(2,"z"),(2,"="),(2,"x"),(2,"in"),(2,"z"),(2,";"),(3,"h"),(3,"x"),(3,"="),(3,"case"),(3,"("),(3,"let"),(3,"y"),(3,"="),(3,"x"),(3,"in"),(3,"y"),(3,")"),(3,"of"),(4,"<"),(4,"1"),(4,">"),(4,"->"),(4,"2"),(4,";"),(5,"<"),(5,"2"),(5,">"),(5,"->"),(5,"5")]
```