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

17日目

Formatting the results

statesはめっちゃ情報量あるから表示すると超長くなるし,heapとstackは抽象データ構造だからそもそも表示できないので,showResults関数を作る.

全部のステップで全部のstatesを表示するとめっちゃ長いし,stack以外は変化がないのでstackだけ毎ステップ表示すればいいよね.

文章でわからない所や重要なところがあまりないのでサクサク進む.
Exerciseが進むに従って関数も変わっているので,出力のフォーマットが変わっていることに注意.

Exercise 2.4

main = putStrLn $ runProg $ "main = S K K 3" として実行.結果は

   1) Stk [
   1: NSupercomb main
 ]

   2) Stk [
  12: NAp   10   11 (NNum 3)
 ]

   3) Stk [
  10: NAp    9    3 (NSupercomb K)
  12: NAp   10   11 (NNum 3)
 ]

   4) Stk [
   9: NAp    5    3 (NSupercomb K)
  10: NAp    9    3 (NSupercomb K)
  12: NAp   10   11 (NNum 3)
 ]

   5) Stk [
   5: NSupercomb S
   9: NAp    5    3 (NSupercomb K)
  10: NAp    9    3 (NSupercomb K)
  12: NAp   10   11 (NNum 3)
 ]

   6) Stk [
  15: NAp   13   14 (NAp 3 11)
 ]

   7) Stk [
  13: NAp    3   11 (NNum 3)
  15: NAp   13   14 (NAp 3 11)
 ]

   8) Stk [
   3: NSupercomb K
  13: NAp    3   11 (NNum 3)
  15: NAp   13   14 (NAp 3 11)
 ]

   9) Stk [
  11: NNum 3
 ]



Total number of steps = 8

確かに最終結果が3になっている.

Exercise 2.5

僕はheapが伸長していく様子だけじゃなくてheapの中身も全部見たかったので,hAddressesを使わなかった.
使う場合はhead (hAddresses heap)などどすればアロケートした最大addrがわかる.

Exercise 2.7

heapのデータ構造をいじるのは変更点が多そうだったのでやらなかった.
statsにscの簡約とprimの簡約の数,スタックの最大の深さの情報を入れた.

Exercise 2.9

すべての状態がshowResultでフォーマットされると何が起こるか?

• やってないのでわからん.

tiFinal stateを評価するときに,例えば存在しないheapのnodeにアクセスしようとするなど,エラーが起きたらどうなるか?

• 普通に実行したら両方普通に終了した.
• 初期値を[]にしたら両方ともEmpty stack!のエラーが出て死んだ.
• 初期値を[999, addr_of_main]にしたら両方ともcan’t find node #999 in heapのエラーが出て死んだ.

結果を見るに

eval state | tiFinal state = [state]
           | otherwise = state : eval next_state

としても変わらない.なんでだろう?
文章を見るにshowResultでエラーが出てきたときにエラーを起こしたstateが表示されるかされないかの違いらしい.実際両方死んだのでよくわからん.

2.3.6まで読んだ

diffとったやーつ

Language.hs

diff --git a/Language.hs b/Language.hs
index 4b228ae..e9d4fbd 100644
--- a/Language.hs
+++ b/Language.hs
@@ -75,7 +75,7 @@ iNum n = iStr (shownum n)
 iIndent seq1 = IIndent seq1
 iNewline = INewline
 iStr str = if elem '\n' str then (IStr (takeWhile (/= '\n') str)) `iAppend` iNewline `iAppend` (IStr (tail (dropWhile (/= '\n') str))) else IStr str
-iDisplay seq1 = flatten 0 [(seq1, 0)]
+iDisplay seq = flatten 0 [(seq, 0)]
 iDisplay :: Iseq -> String -- Turn an iseq into a string
 iConcat :: [Iseq] -> Iseq
 iConcat (car:cdr) = car `iAppend` (iConcat cdr)
@@ -110,12 +110,12 @@ pprExpr (EAp e1 e2) = (pprExpr e1) `iAppend` (iStr " ") `iAppend` (pprAExpr e2)
 pprExpr (ELet isrec defns expr)
     = iConcat [ iStr keyword, iNewline,
                 iIndent (pprDefns defns), iNewline,
-                iStr "in ", pprExpr expr ]
+                iStr "in ", iIndent (pprExpr expr) ]
         where
         keyword = if isrec then "letrec" else "let"
 pprExpr (ECase expr alters)
     = iConcat [ iStr "case", iStr " ", pprExpr expr, iNewline,
-                iIndent (pprAlters alters), iNewline ]
+                iIndent (pprAlters alters)] --, iNewline ]
 pprExpr (ELam var expr)
     = iConcat [iConcat (map iStr var), iStr ". ", pprExpr expr]

@@ -138,7 +138,7 @@ pprAlters alters

 pprAlter :: (Int, [Name], Expr Name) -> Iseq
 pprAlter (tag, var, expr)
-    = iConcat [iStr "<", iNum tag, iStr ">", iStr (unwords var), iStr " -> ", iIndent (pprExpr expr) ]
+    = iConcat [ iStr "<", iNum tag, iStr ">", iStr (unwords var), iStr " -> ", iIndent (pprExpr expr) ]

 pprAExpr :: CoreExpr -> Iseq
 pprAExpr e | isAtomicExpr e = pprExpr e
@@ -156,10 +156,12 @@ pprScDefn (name, var, expr)

 flatten :: Int -> [(Iseq, Int)] -> String
 flatten _ [] = ""
-flatten _ ((INewline, indent) : seqs)
+flatten col ((INewline, indent) : seqs)
     = '\n' : (space indent) ++ (flatten indent seqs)
+--    = '\n' : (space indent) ++ (flatten indent seqs)
 flatten col ((IIndent seq1, indent) : seqs) -- TODO: indent properly
     = flatten col ((seq1, col) : seqs)
+--    = flatten col ((seq1, col) : seqs)
 flatten col ((IStr seq1, _) : seqs)
     = seq1 ++ (flatten col seqs)
 flatten col ((INil, _) : seqs)

Main.hs

import Language
import Utils

runProg :: String -> String
runProg = showResults . eval . compile . parse

type TiState = (TiStack, TiDump, TiHeap, TiGlobals, TiStats)
type TiStack = [Addr]
data TiDump = DummyTiDump
initialTiDump = DummyTiDump
type TiHeap = Heap Node
data Node = NAp Addr Addr -- Application
    | NSupercomb Name [Name] CoreExpr -- Supercombinator
    | NNum Int

type TiGlobals = ASSOC Name Addr
tiStatInitial :: TiStats
tiStatIncSteps :: TiStats -> TiStats
tiStatGetSteps :: TiStats -> Int
type TiStats = (Int, (Int, Int), Int)
tiStatInitial = (0, (0, 0), 1) --(step, (redution of sc, reduction of prim), max of stack depth(main addr))
tiStatIncSteps (s, r, d) = (s + 1, r, d)
tiStatGetSteps (s, _, _) = s
tiStatGetReducitonSc (_, (rsc, _), _) = rsc
tiStatGetReducitonPrim (_, (_, rp), _) = rp
tiStatGetMaxStackDepth (_, (_, _), d) = d

applyToStats :: (TiStats -> TiStats) -> TiState -> TiState
applyToStats stats_fun (stack, dump, heap, sc_defs, stats) = (stack, dump, heap, sc_defs, stats_fun stats)
compile :: CoreProgram -> TiState
compile program = (initial_stack, initialTiDump, initial_heap, globals, tiStatInitial)
    where
    sc_defs = program ++ preludeDefs ++ extraPreludeDefs
    (initial_heap, globals) = buildInitialHeap sc_defs
    initial_stack = [address_of_main]
    address_of_main = aLookup globals "main" (error "main is not defined")

extraPreludeDefs = []

buildInitialHeap :: [CoreScDefn] -> (TiHeap, TiGlobals)
buildInitialHeap sc_defs = mapAccuml allocateSc hInitial sc_defs

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

eval :: TiState -> [TiState]
eval state = state : rest_states
--eval state | tiFinal state = [state]
--           | otherwise = state : eval next_state
    where
    rest_states | tiFinal state = []
                | otherwise = eval next_state
    next_state = doAdmin (step state)

doAdmin :: TiState -> TiState
doAdmin state = applyToStats tiStatIncSteps state

tiFinal :: TiState -> Bool
tiFinal ([sole_addr], dump, 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

isDataNode :: Node -> Bool
isDataNode (NNum n) = True
isDataNode node = False

step :: TiState -> TiState
step state = dispatch (hLookup heap (hd stack))
    where
    (stack, dump, heap, globals, stats) = state
    dispatch (NNum n) = numStep state n
    dispatch (NAp a1 a2) = apStep state a1 a2
    dispatch (NSupercomb sc args body) = scStep state sc args body

numStep :: TiState -> Int -> TiState
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

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 = zip2 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
    -> TiHeap -- Heap before instantiation
    -> ASSOC Name Addr -- Association of names to addresses
    -> (TiHeap, Addr) -- Heap after instantiation, and
-- address of root of instance

instantiate (ENum n) heap env = hAlloc heap (NNum n)
instantiate (EAp e1 e2) heap env = hAlloc heap2 (NAp a1 a2)
    where
    (heap1, a1) = instantiate e1 heap env
    (heap2, a2) = instantiate e2 heap1 env
instantiate (EVar v) heap env = (heap, aLookup env v (error ("Undefined name " ++ show v)))
instantiate (EConstr tag arity) heap env = instantiateConstr tag arity heap env
instantiate (ELet isrec defs body) heap env = instantiateLet isrec defs body heap env
instantiate (ECase e alts) heap env = error "Can’t instantiate case exprs"

instantiateConstr tag arity heap env = error "Can’t instantiate constructors yet"
instantiateLet isrec defs body heap env = error "Can’t instantiate let(rec)s yet"

showResults :: [TiState] -> String
showResults states = iDisplay (iConcat [ iLayn (map showState states), showStats (last states) ])

showState :: TiState -> Iseq
showState (stack, dump, heap, globals, stats)
    = iConcat [
        showStack heap stack, iNewline,
        showHeap heap, iNewline
    ]

showHeap :: TiHeap -> Iseq
showHeap heap
    = iConcat [
        iStr "Heap [", iNewline,
        iIndent (show_heap_items heap), iNewline,
        iStr "]"
    ]
    where
    show_heap_items (_, _, cts)
        = iInterleave iNewline (map show_heap_cts cts)
    show_heap_cts (addr, n)
        = iConcat [
            showFWAddr addr, iStr ": ",
            showStkNode heap n
        ]

showStack :: TiHeap -> TiStack -> Iseq
showStack heap stack
    = iConcat [
        iStr "Stack [ (top)", iNewline,
        iIndent (iInterleave iNewline (map show_stack_item stack)), iNewline,
        iStr "]"
    ]
    where
    show_stack_item addr
        = iConcat [
            showFWAddr addr, iStr ": ",
            showStkNode heap (hLookup heap addr)
        ]

showStkNode :: TiHeap -> Node -> Iseq
showStkNode heap (NAp fun_addr arg_addr)
    = iConcat [
        iStr "NAp ", showFWAddr fun_addr,
        iStr " ", showFWAddr arg_addr, iStr " (",
        showNode (hLookup heap arg_addr), iStr ")"
    ]
showStkNode heap node = showNode node

showNode :: Node -> Iseq
showNode (NAp a1 a2)
    = iConcat [
        iStr "NAp ", showAddr a1,
        iStr " ", showAddr a2
    ]
showNode (NSupercomb name args body) = iStr ("NSupercomb " ++ name)
showNode (NNum n) = (iStr "NNum ") `iAppend` (iNum n)

showAddr :: Addr -> Iseq
showAddr addr = iStr (show addr)

showFWAddr :: Addr -> Iseq -- Show address in field of width 4
showFWAddr addr = iStr (space (4 - length str) ++ str)
    where
    str = show addr

showStats :: TiState -> Iseq
showStats (stack, dump, heap, globals, stats)
    = iConcat [
        iNewline, iNewline, iStr "Total number of steps = ", iNum (tiStatGetSteps stats), iNewline,
        iStr "Total number of reductions = ", iNum (tiStatGetReducitonSc stats + tiStatGetReducitonPrim stats), iNewline,
        iStr "Total number of supercombinator reductions = ", iNum (tiStatGetReducitonSc stats), iNewline,
        iStr "Total number of primitive reductions = ", iNum (tiStatGetReducitonPrim stats), iNewline,
        iStr "Maximum of stack depth = ", iNum (tiStatGetMaxStackDepth stats), iNewline

    ]

main :: IO ()
main = putStrLn $ runProg $ "main = K I I I I 3"