今回は、フリーストアの動作をまとめておきます。
前回と同じですが、ソースコードを以下に示します。今回は参照のため行頭に行番号を付加してあります。
1(define malloc
2 (lambda (core base break)
3 (let* ((header-size 16)
4 (base (* (quotient (+ base (- header-size 1)) header-size)
5 header-size))
6 (break (* (quotient break header-size) header-size)))
7
8 (define header
9 (lambda (top next size)
10 (lambda (op)
11 (cond
12 ((eq? op 'set-top!) (lambda (x) (set! top x)))
13 ((eq? op 'get-top) (lambda () top))
14 ((eq? op 'set-next!) (lambda (x) (set! next x)))
15 ((eq? op 'get-next) (lambda () next))
16 ((eq? op 'set-size!) (lambda (x) (set! size x)))
17 ((eq? op 'get-size) (lambda () size))
18 ((eq? op 'clone) (lambda () (header top next size)))
19 ((eq? op 'load!)
20 (lambda (offset)
21 (set! top (binary-buffer-load core offset 'tetra))
22 (set! next (binary-buffer-load core (+ offset 4) 'tetra))
23 (set! size (binary-buffer-load core (+ offset 8) 'tetra))))
24 ((eq? op 'store!)
25 (lambda ()
26 (binary-buffer-store! core top top 'tetra)
27 (binary-buffer-store! core (+ top 4) next 'tetra)
28 (binary-buffer-store! core (+ top 8) size 'tetra)))
29 ((eq? op 'eq?) (lambda (x) (= top ((x 'get-top)))))
30 ((eq? op 'dump) (lambda ()
31 (display (list "top" "next" "size"))
32 (display " = ")
33 (display (list top next size))
34 (newline)))
35 (else '())))))
36
37 (let ((freep (header base (+ base header-size) 0)))
38 ((freep 'store!))
39 (((header (+ base header-size)
40 base
41 (- break base header-size header-size)) 'store!))
42
43 (define dump
44 (lambda ()
45 (let loop ((p ((freep 'clone))))
46 ((p 'dump))
47 ((p 'load!) ((p 'get-next)))
48 (if ((p 'eq?) freep)
49 'DONE
50 (loop p)))))
51
52 (define alloc
53 (lambda (size)
54 (let ((n (* (+ (quotient
55 (+ size (- header-size 1)) header-size) 1)
56 header-size))
57 (prev ((freep 'clone)))
58 (p ((freep 'clone))))
59
60 ((p 'load!) ((prev 'get-next)))
61
62 (let loop ((prev prev) (p p))
63 (if (>= ((p 'get-size)) n)
64 (begin
65 (if (= ((p 'get-size)) n)
66 (begin
67 ((prev 'set-next!) ((p 'get-next)))
68 ((prev 'store!)))
69 (begin
70 ((p 'set-size!) (- ((p 'get-size)) n))
71 ((p 'store!))
72 ((p 'set-top!) (+ ((p 'get-top)) ((p 'get-size))))
73 ((p 'set-size!) n)
74 ((p 'store!))))
75 ((prev 'load!) ((prev 'get-top)))
76 ((freep 'load!) ((prev 'get-top)))
77 ((freep 'store!))
78 (+ ((p 'get-top)) header-size))
79 (if ((p 'eq?) freep)
80 (begin
81 (display "insufficient memory.")
82 (newline)
83 '())
84 (begin
85 ((prev 'load!) ((p 'get-top)))
86 ((prev 'store!))
87 ((p 'load!) ((p 'get-next)))
88 ((p 'store!))
89 (loop prev p))))))))
90
91 (define free
92 (lambda (ap)
93 (let ((bp (header 0 0 0)))
94 ((bp 'load!) (- ap header-size))
95 (let ((top ((bp 'get-top))))
96 (let ((p (let loop ((p ((freep 'clone))))
97 (if (and (> top ((p 'get-top)))
98 (< top ((p 'get-next))))
99 p
100 (if (and (>= ((p 'get-top)) ((p 'get-next)))
101 (or (> top ((p 'get-top)))
102 (< top ((p 'get-next)))))
103 p
104 (begin
105 ((p 'load!) ((p 'get-next)))
106 (loop p)))))))
107 (if (= (+ top ((bp 'get-size))) ((p 'get-next)))
108 (let ((q ((p 'clone))))
109 ((q 'load!) ((q 'get-next)))
110 ((bp 'set-size!) (+ ((bp 'get-size)) ((q 'get-size))))
111 ((bp 'set-next!) ((q 'get-next))))
112 ((bp 'set-next!) ((p 'get-next))))
113 ((bp 'store!))
114 (if (= (+ ((p 'get-top)) ((p 'get-size))) top)
115 (begin
116 ((p 'set-size!) (+ ((p 'get-size)) ((bp 'get-size))))
117 ((p 'set-next!) ((bp 'get-next))))
118 ((p 'set-next!) top))
119 ((p 'store!))
120 ((freep 'load!) ((p 'get-top))))))))
121
122 (lambda (op)
123 (cond
124 ((eq? op 'dump) dump)
125 ((eq? op 'alloc) alloc)
126 ((eq? op 'free) free)
127 ((eq? op 'base) base)
128 ((eq? op 'break) break)
129 (else '())))))))
130
131;;;
132;; 参考文献
133;; プログラミング言語C 第2版
134;; 訳者 石田晴久
135;; 共立出版株式会社
136;; ISBN4-320-02692-6
初期状態をつくる
フリーストアは、バイナリ・バッファの全体、または限定された領域につくります。したがって、まずバイナリ・バッファをつくる必要があります。このバイナリ・バッファ中に初期状態を作成するには malloc.scm をロードし、malloc 関数を呼び出します。malloc 関数はλ式を返します。
上図の初期状態をつくる手順を以下に示します。行頭に、プロンプト "> " が、あるもののみ入力します。以下、同様とします。
1> (load "malloc.scm")
2> (define core (binary-buffer-create #x10000))
3> (define fountain (malloc core #x8000 #xc000))
4> (fountain 'base)
532768
6> (fountain 'break)
749152
8> ((fountain 'dump))
9(top next size) = (32768 32784 0)
10(top next size) = (32784 32768 16352)
11DONE
12>
base から始まる領域の先頭には、ヘッダが置かれます。（37 ～ 38行目）このヘッダは特別なヘッダです。ヘッダには、size を格納する領域があります。特別なヘッダでは、この値が 0 になっています。これが、このコードをトリッキーにしている重要な点です。後述しますが、この size が 0 になっていることにより、このヘッダだけは、他の空きブロックと結合されることがなく、常に存在し続けます。通常、ヘッダの後にはボディが続き、それは空き領域、または、使用領域、それぞれの本体となります。しかし、この、特別なヘッダはボディを持ちません。
続く 39 ～ 41 行目で空き領域のヘッダであり、初期フリーストアの全領域を表現しています。このヘッダにはボディが続き、この領域から必要な記憶域が割り当てられます。このヘッダはブロックのサイズを格納していますが、この値はヘッダとボディの合計です。使用、未使用に関らず、この値は有効な値を保持する必要があります。ただし、前述のとおり、特別なヘッダでは、常に 0 となっています。
どのヘッダも、top の値を保持しており、そのヘッダを含むブロックが、 top が示すバイナリ・バッファのアドレスから開始することを表しています。この値も、使用、未使用に関らず、有効な値を保持する必要があります。
また、ヘッダは、next の値を保持する領域を持ちます。この領域は、空き（未使用）ブロックのみが有効な値を格納します。この領域は、自身より高位の空きブロックのうち、最も近いアドレスを保持します。ただし、最高位にある空き領域は、この値に、特別なブロックのアドレスを設定します（初期値は 40 行目で設定）。これにより、空きブロックは環状に繋がれた状態となっています。
上述の手順のうち、8 行目の式を評価した結果、副作用として 9 ～ 11 行目が表示されています。これらは、空きブロックの環状リストの様子を表現したものです。
malloc にバインドされたλ式が引数に適用されると、122 行目から始まるλ式を返します。これは、引数をひとつ取ります。この値はシンボルを（クォートして）与えます。（取り得る値は、123 行目からの cond 式を見てください）
初期状態から1ブロックを確保する
上図の状態をつくる手順を以下に示します。ここでは、前述の手順により、既に初期状態がつくられているものとします。
1> (define ls '())
2> (set! ls (cons ((fountain 'alloc) 2500) ls))
3> ls
4(46624)
5> ((fountain 'dump))
6(top next size) = (32768 32784 0)
7(top next size) = (32784 32768 13824)
8DONE
9>
((fountain 'alloc) 2500)
(fountain 'alloc) がソースコードの 125 行目より、シンボル alloc にバインドされている 53 行目から始まるλ式を返します。このλ式は引数をひとつ（ size ）取り、78 行目で整数（アドレス）を返します。ただし、十分な領域が残っていないときは空リストを返します。（83 行目）62 行目から始まり、89 行目で終わる loop というラベルのついた
let 式により、ヘッダを辿ることで空きブロックを探索します。
63 行目の次の式が #t のとき、十分な空きのあるブロックが発見されたことを示します。
(>= ((p 'get-size)) n)
57 ～ 62 行目に注目すると、p と prev の関係が分ります。prev は、p の、ひとつ前の空きブロックを指しています。65 行目の次の式が
#t のとき、prev の next を付け換える必要があります。
(= ((p 'get-size)) n)
上式が
#f のときは、空きブロックの最後から、要求された領域を切り出す必要があります。このとき、切り出す領域は、空きブロックの末尾から取られます。この処理は、69 ～ 74行目 で行っています。上図の状況は、ちょうど、このケースと一致します。要求されたブロックが確保出来た場合は、75 ～ 77 行目で freep の値を更新します。ポインタが利用できないため、
store!というシンボルが度々、出現することに注意してください。
freep の値は、次に alloc が適用されたとき、空きブロックの探索開始位置に使われることを確認してください。（57 ～ 62 行目）
最終的に確保できた領域のアドレスはヘッダ部を跳ばしたアドレスを返しています。(78 行目)
ブロックを解放する
以下は、ブロックを解放する手順を 4 つの状況に分けて説明します。
解放する領域の両端のブロックが使用中の場合
上図の状態をつくる手順を以下に例示します。
1> (load "malloc.scm")
2> (define core (binary-buffer-create #x10000))
3> (define fountain (malloc core #x8000 #xc000))
4> (fountain 'base)
532768
6> (fountain 'break)
749152
8> (define ls '())
9> (set! ls (cons ((fountain 'alloc) 2500) ls))
10> (set! ls (cons ((fountain 'alloc) 2500) ls))
11> (set! ls (cons ((fountain 'alloc) 2500) ls))
12> (set! ls (cons ((fountain 'alloc) 2500) ls))
13> (set! ls (cons ((fountain 'alloc) 2500) ls))
14> (set! ls (cons ((fountain 'alloc) 2500) ls))
15> (set! ls (cons ((fountain 'alloc) 2500) ls))
16insufficient memory.
17> ls
18(() 33984 36512 39040 41568 44096 46624)
19> (set! ls (cdr ls))
20> ls
21(33984 36512 39040 41568 44096 46624)
22> ((fountain 'dump))
23(top next size) = (32768 32784 0)
24(top next size) = (32784 32768 1184)
25DONE
26> (set! ls (cons ((fountain 'alloc) 1168) ls))
27> ((fountain 'dump))
28(top next size) = (32768 32768 0)
29DONE
30> ls
31(32800 33984 36512 39040 41568 44096 46624)
32> ((fountain 'free) 32800)
33> ((fountain 'free) 44096)
34> ((fountain 'dump))
35(top next size) = (32784 44080 1184)
36(top next size) = (44080 32768 2528)
37(top next size) = (32768 32784 0)
38DONE
余談ですが、ここでは副作用を多用しています。REPL を使って、コンピュータと対話しながら目的を達成する好例となっています。とくに、式
ls を評価したり、式 ((fountain 'dump)) を何度も、評価して何を知りたいのか強く意識してみてください。LISP のような高級言語が、まだ若年だった頃を想像してみてください。このように、コンピュータと対話しながら作業を進めることが出来る環境が、どれほど画期的だったでしょう。現代に於いても、マウスなどのポインティングデバイスを用いてちゃっちゃと同様のことができるでしょうか。たとえ、可能だったとして、コンピュータとの通信の行き返りに数十秒以上要する場合は、どうなるでしょうか。無人宇宙船のコンピュータに REPL が実装されていたら、随分と役に立つと思われませんか。筆者は実際にそんな宇宙船があるという話をどこかで聞いたことがあります。
随分と永く脱線してしまいました。話の続きに戻りましょう。
この状態から、不要になったブロックを解放することが目的です。解放するブロックは、bp が指しているブロックです。正確には、bp の top 属性です。
39> ((fountain 'free) 39040)
40> ((fountain 'dump))
41(top next size) = (32784 39024 1184)
42(top next size) = (39024 44080 2528)
43(top next size) = (44080 32768 2528)
44(top next size) = (32768 32784 0)
45DONE
46>
((fountain 'free) 39040)
(fountain 'free) を評価しますソースコードの 126 行目を参照すると、91 行目でシンボル freeにバインドしたλ式が返ることが確認できます。このλ式は引数 ap をひとつ取ります。ap には、bp の top から、ヘッダサイズをスキップしたアドレスを与えます。94 行目で、ap から、header-size を減じて、bp を得ていることが分ります。（実際の矢印は、bp の top 要素が持っています）96 ～ 106 行目にある
let 式の頭部、つまり、シンボルに値をバインドする部分を参照すると、その内側に、さらにラベル付きのlet式が存在します。この内側のコンテキストで pを freep から始めて、空きブロックを辿り、bpが指すブロックをどこに返却するかを探索しています。97 ～ 98 行目の以下の式、
(and (> top ((p 'get-top))) (< top ((p 'get-next))))
100 ～ 102 行目の以下の式を見てください。
(and (>= ((p 'get-top)) ((p 'get-next)))
(or (> top ((p 'get-top)))
(< top ((p 'get-next)))))
(and (>= ((p 'get-top)) ((p 'get-next)))
(> top ((p 'get-top))))
or 式が、不要となっていたことに気付きませんでした。（気になる方は、参考文献をあたってください）この式は、p が指す、空きブロックの連鎖が、高位から下位に、循環していることかどうか判定し、もし、循環していたとき、さらにbp が p より高位にあれば、pより高位アドレスに返却することが決定します。（103行目）
そうでなければ、104 行目からの
begin 式が評価され、p の連鎖を辿る処理を継続して、返却すべきアドレスを探索します。bp が指すブロックの両端は、used と書かれた矢印で示してありますが、それぞれ、ひとつ、乃至、いくつかのブロックが連なったものを略記しています。つまり、解放しようとするブロックの両端は使用中のブロックが隣接していることを示しています。
この状態はソースコード 107 行目の以下の式が
#f であること、
(= (+ top ((bp 'get-size))) ((p 'get-next)))
#f であることを以って判定しています。
(= (+ ((p 'get-top)) ((p 'get-size))) top)
以上の手順を実行した結果は下図のようになります。上述のの手順 40 以降は、空きブロックの連鎖を確認して下図の状態と見比べるために実行しています。間違いがなければ、同様の状態になっている筈です。
解放する領域の低位のブロックが使用中で高位のブロックが空きの場合
上図の状態をつくる手順を以下に例示します。
1> (load "malloc.scm")
2> (define core (binary-buffer-create #x10000))
3> (define fountain (malloc core #x8000 #xc000))
4> (fountain 'base)
532768
6> (fountain 'break)
749152
8> (define ls '())
9> (set! ls (cons ((fountain 'alloc) 2500) ls))
10> (set! ls (cons ((fountain 'alloc) 2500) ls))
11> (set! ls (cons ((fountain 'alloc) 2500) ls))
12> (set! ls (cons ((fountain 'alloc) 2500) ls))
13> (set! ls (cons ((fountain 'alloc) 2500) ls))
14> (set! ls (cons ((fountain 'alloc) 2500) ls))
15> (set! ls (cons ((fountain 'alloc) 2500) ls))
16insufficient memory.
17> ls
18(() 33984 36512 39040 41568 44096 46624)
19> ((fountain 'dump))
20(top next size) = (32768 32784 0)
21(top next size) = (32784 32768 1184)
22DONE
23> (set! ls (cons ((fountain 'alloc) 1168) (cdr ls)))
24> ls
25(32800 33984 36512 39040 41568 44096 46624)
26> ((fountain 'dump))
27(top next size) = (32768 32768 0)
28DONE
29> ((fountain 'free) 32800)
30> ((fountain 'free) 44096)
31> ((fountain 'dump))
32(top next size) = (32784 44080 1184)
33(top next size) = (44080 32768 2528)
34(top next size) = (32768 32784 0)
35DONE
この状態から、bp が指しているブロックを解放します。
36> ((fountain 'free) 41568)
37> ((fountain 'dump))
38(top next size) = (32784 41552 1184)
39(top next size) = (41552 32768 5056)
40(top next size) = (32768 32784 0)
41DONE
42>
((fountain 'free) 41568)
(= (+ top ((bp 'get-size))) ((p 'get-next)))
#t となるため、108 ～ 111 行目の let 式により、高位のブロックがbp が指すブロックと統合されて消滅します。また、114 行目の以下の式は
#f となり、低位のブロックとの統合は生じません。
(= (+ ((p 'get-top)) ((p 'get-size))) top)
以上の手順を実行した結果は下図のようになります。
解放する領域の低位のブロックが空きで高位のブロックが使用中の場合
上図の状態をつくる手順を以下に例示します。
1> (load "malloc.scm")
2> (define core (binary-buffer-create #x10000))
3> (define fountain (malloc core #x8000 #xc000))
4> (fountain 'base)
532768
6> (fountain 'break)
749152
8> (define ls '())
9> (set! ls (cons ((fountain 'alloc) 2500) ls))
10> (set! ls (cons ((fountain 'alloc) 2500) ls))
11> (set! ls (cons ((fountain 'alloc) 2500) ls))
12> (set! ls (cons ((fountain 'alloc) 2500) ls))
13> (set! ls (cons ((fountain 'alloc) 2500) ls))
14> (set! ls (cons ((fountain 'alloc) 2500) ls))
15> (set! ls (cons ((fountain 'alloc) 2500) ls))
16insufficient memory.
17> ls
18(() 33984 36512 39040 41568 44096 46624)
19> ((fountain 'dump))
20(top next size) = (32768 32784 0)
21(top next size) = (32784 32768 1184)
22DONE
23> (set! ls (cons ((fountain 'alloc) 1168) (cdr ls)))
24> ls
25(32800 33984 36512 39040 41568 44096 46624)
26> ((fountain 'dump))
27(top next size) = (32768 32768 0)
28DONE
29> ((fountain 'free) 32800)
30> ((fountain 'free) 44096)
31> ((fountain 'dump))
32(top next size) = (32784 44080 1184)
33(top next size) = (44080 32768 2528)
34(top next size) = (32768 32784 0)
35DONE
この状態から、bp が指しているブロックを解放します。
36> ((fountain 'free) 33984)
37> ((fountain 'dump))
38(top next size) = (32784 44080 3712)
39(top next size) = (44080 32768 2528)
40(top next size) = (32768 32784 0)
41DONE
42>
((fountain 'free) 33984)
(= (+ ((p 'get-top)) ((p 'get-size))) top)
#t となるため、115 ～ 117 行目の begin式により、bp が指すブロックが低位のブロックと統合されて消滅します。ただし、フリーストア先頭にある特別なヘッダは、空きブロックとはなりません。これは、このヘッダの size 属性が常に 0 となっているため、上式が #f となるからです。つまり、解放するブロックの低位が特別なヘッダと接していても、絶対に、それと統合は生じません。また、107 行目の以下の式は
#f となり、高位のブロックとの統合は生じません。
(= (+ top ((bp 'get-size))) ((p 'get-next)))
解放する領域の低位・高位のブロックともに空きの場合
上図の状態をつくる手順を以下に例示します。
1> (load "malloc.scm")
2> (define core (binary-buffer-create #x10000))
3> (define fountain (malloc core #x8000 #xc000))
4> (fountain 'base)
532768
6> (fountain 'break)
749152
8> (define ls '())
9> (set! ls (cons ((fountain 'alloc) 2500) ls))
10> ((fountain 'dump))
11(top next size) = (32768 32784 0)
12(top next size) = (32784 32768 13824)
13DONE
14> (set! ls (cons ((fountain 'alloc) 12624) ls))
15> (set! ls (cons ((fountain 'alloc) 1168) ls))
16> ls
17(32800 33984 46624)
18> ((fountain 'dump))
19(top next size) = (32768 32768 0)
20DONE
この状態から、bp が指しているブロックを解放します。
21> ((fountain 'free) 33984)
22> ((fountain 'dump))
23(top next size) = (32768 33968 0)
24(top next size) = (33968 32768 12640)
25DONE
26>
- 解放するブロックの高位側の端が空きブロックに接しています。
- 解放するブロックの低位側の端も空きブロックに接しています。
((fountain 'free) 33984)
- bp が指すブロックと、高位側の空きブロックが統合されます。
- 上で統合された空きブロックが低位側のブロックに統合されます。
以上の手順を実行した結果は下図のようになります。
今回は以上です。次回は、atom をフリーストアに書き込み、暫定的なバイトコードを使って、それらを操作してみようかなどと考えています。
あとがき
ようやく、書き終わりました。今回は、図版を作成したり、ソースコードのテキストファイルから、行番号付きの HTML ファイルを作成したりするプログラムを numb-lambdaで書きました。このプログラムは、いくつかの文字を実体参照へ置換する処理も行います。また、各行毎にHTMLタグを追加したりもしています。これを用いてソースコードや REPL を処理したテキストを用意しました。ここまでやると流石に消耗します。次回からは、少しテキストの量を減らすことを検討してみたいと思います。読者層を想定できていない点が問題なのかも知れません。