これら一連の記事は、numb-lambda インタープリタから始まる連載企画になっています。
今回は、C のライブラリ関数、malloc, free 同様の機能を実装してみました。ガーベジコレクションの機能はありません。ガーベジコレクションについては、後日、改めて検討します。
この領域には、文字列、シンボル、ベクタ（配列）等を格納する予定です。当面、整数等も、ここに保存する可能性もあります。その意味でフリーストア（自由格納域）と呼ぶことにします。メモリー管理をここで行うのは、（REPLの） Reader を LISP レベルで記述したいためです。*1
LISP で書いた Reader は、コンパイルしてバイトコード*2 に落とします。バイトコードを実行するのは仮想マシンであり、これは C で記述する予定です。
また、CONS セルについては、後日、全く別の管理方法を検討します。
まずは、ソースコード（malloc.scm）を見てください。
(define malloc
(lambda (core base break)
(let* ((header-size 16)
(base (* (quotient (+ base (- header-size 1)) header-size)
header-size))
(break (* (quotient break header-size) header-size)))
(define header
(lambda (top next size)
(lambda (op)
(cond
((eq? op 'set-top!) (lambda (x) (set! top x)))
((eq? op 'get-top) (lambda () top))
((eq? op 'set-next!) (lambda (x) (set! next x)))
((eq? op 'get-next) (lambda () next))
((eq? op 'set-size!) (lambda (x) (set! size x)))
((eq? op 'get-size) (lambda () size))
((eq? op 'clone) (lambda () (header top next size)))
((eq? op 'load!)
(lambda (offset)
(set! top (binary-buffer-load core offset 'tetra))
(set! next (binary-buffer-load core (+ offset 4) 'tetra))
(set! size (binary-buffer-load core (+ offset 8) 'tetra))))
((eq? op 'store!)
(lambda ()
(binary-buffer-store! core top top 'tetra)
(binary-buffer-store! core (+ top 4) next 'tetra)
(binary-buffer-store! core (+ top 8) size 'tetra)))
((eq? op 'eq?) (lambda (x) (= top ((x 'get-top)))))
((eq? op 'dump) (lambda ()
(display (list "top" "next" "size"))
(display " = ")
(display (list top next size))
(newline)))
(else '())))))
(let ((freep (header base (+ base header-size) 0)))
((freep 'store!))
(((header (+ base header-size)
base
(- break base header-size header-size)) 'store!))
(define dump
(lambda ()
(let loop ((p ((freep 'clone))))
((p 'dump))
((p 'load!) ((p 'get-next)))
(if ((p 'eq?) freep)
'DONE
(loop p)))))
(define alloc
(lambda (size)
(let ((n (* (+ (quotient
(+ size (- header-size 1)) header-size) 1)
header-size))
(prev ((freep 'clone)))
(p ((freep 'clone))))
((p 'load!) ((prev 'get-next)))
(let loop ((prev prev) (p p))
(if (>= ((p 'get-size)) n)
(begin
(if (= ((p 'get-size)) n)
(begin
((prev 'set-next!) ((p 'get-next)))
((prev 'store!)))
(begin
((p 'set-size!) (- ((p 'get-size)) n))
((p 'store!))
((p 'set-top!) (+ ((p 'get-top)) ((p 'get-size))))
((p 'set-size!) n)
((p 'store!))))
((prev 'load!) ((prev 'get-top)))
((freep 'load!) ((prev 'get-top)))
((freep 'store!))
(+ ((p 'get-top)) header-size))
(if ((p 'eq?) freep)
(begin
(display "insufficient memory.")
(newline)
'())
(begin
((prev 'load!) ((p 'get-top)))
((prev 'store!))
((p 'load!) ((p 'get-next)))
((p 'store!))
(loop prev p))))))))
(define free
(lambda (ap)
(let ((bp (header 0 0 0)))
((bp 'load!) (- ap header-size))
(let ((top ((bp 'get-top))))
(let ((p (let loop ((p ((freep 'clone))))
(if (and (> top ((p 'get-top)))
(< top ((p 'get-next))))
p
(if (and (>= ((p 'get-top)) ((p 'get-next)))
(or (> top ((p 'get-top)))
(< top ((p 'get-next)))))
p
(begin
((p 'load!) ((p 'get-next)))
(loop p)))))))
(if (= (+ top ((bp 'get-size))) ((p 'get-next)))
(let ((q ((p 'clone))))
((q 'load!) ((q 'get-next)))
((bp 'set-size!) (+ ((bp 'get-size)) ((q 'get-size))))
((bp 'set-next!) ((q 'get-next))))
((bp 'set-next!) ((p 'get-next))))
((bp 'store!))
(if (= (+ ((p 'get-top)) ((p 'get-size))) top)
(begin
((p 'set-size!) (+ ((p 'get-size)) ((bp 'get-size))))
((p 'set-next!) ((bp 'get-next))))
((p 'set-next!) top))
((p 'store!))
((freep 'load!) ((p 'get-top))))))))
(lambda (op)
(cond
((eq? op 'dump) dump)
((eq? op 'alloc) alloc)
((eq? op 'free) free)
((eq? op 'base) base)
((eq? op 'break) break)
(else '())))))))
;;;
;; 参考文献
;; プログラミング言語C 第2版
;; 訳者 石田晴久
;; 共立出版株式会社
;; ISBN4-320-02692-6
以上のコードは参考文献に掲載されているコードをほぼ移植したものです。numb-lambda では構造体が使えないこと、および、LISPでは通常、（構造体を指す）ポインタが使えないことにより、C で記述したものより、コードが長くなっています。ただし、lambda 式を用いて、名前空間を分離してあるため、フリーストアのインスタンスを複数作成できる等、長所はあります。
まずは、使い方から見てみましょう。
> (load "malloc.scm")
> (define core (binary-buffer-create 1048576))
> (define free-store (malloc core #x40000 #x100000))
> (define b ((free-store 'alloc) 256))
> b
1048304
> ;
(define string-store!
(lambda (core off str)
(let ((n (string-length str)))
(let loop ((i 0))
(if (>= i n)
(begin
(binary-buffer-store! core (+ i off) 0 'byte)
i)
(let ((c (char->integer (string-ref str i))))
(binary-buffer-store! core (+ i off) c 'byte)
(loop (+ i 1))))))))
> ;
(define string-load
(lambda (core off)
(let loop ((i 0)(ls '()))
(let ((c (binary-buffer-load core (+ i off) 'byte)))
(if (zero? c)
(let* ((n (length ls))(s (make-string n)))
(let loop ((ls (reverse ls))(i 0))
(if (>= i n)
s
(begin
(string-set! s i (integer->char (car ls)))
(loop (cdr ls)(+ i 1))))))
(loop (+ i 1) (cons c ls)))))))
> (string-store! core b "hello, world")
12
> (string-load core b)
"hello, world"
> ((free-store 'free) b)
>
ここでは、先ずフリーストアを作ります。malloc.scm をロードした後、バイナリバッファを作ります。ここでは、1MB 確保しています。このバイナリバッファのうち、256KB(#x40000) 以降、1MB(#x100000) 未満の領域をフリーストアとするために、以下の式を評価します。
(define free-store (malloc core #x40000 #x100000))
#x40000 を10進で 262144、#x100000 を1048576 と書いても構いません。この記述により、先頭の 256KB は、フリーストアとして利用されません。全てをフリーストアとして利用したければ、次のようにします。
(define free-store (malloc core 0 #x100000))
(define free-store (malloc core 0 #xc0000))
#xc0000 は、786432 と書いて構いません。
フリーストアが出来たら、そこから 256 バイトの領域を割り当てます。
(define b ((free-store 'alloc) 256))
b にバインドされる値は、バイナリバッファの先頭からの（0 から始まる）アドレスです。REPL で b を評価してみると整数が返されるのが確認できます。
その後に行っていることは、フリーストアから確保した領域に、文字列（"hello, world"）を書き込んだり、読み出したりしています。
フリーストアから確保した領域を開放するには、次の式を評価します。
((free-store 'free) b)
malloc, free ライブラリ関数と同様です。((free-store 'alloc) n ) が、失敗した場合には、'() が返ります。これは、フリーストアから n バイトの確保ができなかったことを意味します。この場合、n をより小さい値にすれば成功する可能性はあります。将来、実際の場面では、'() を返すより、そのタイミングでガーベージコレクションが動作することになります。
少し長くなってしまいましたので、フリーストアの実現方法についての詳細は、次回、メモリー管理 (2) フリーストアで説明することにします。少々、トリッキーな記述をしていますが、なかなか、読み応えがあるので、ぜひ、細部まで解読にチャレンジしてみてください。参考文献にある C のコードの方が理解し易いかも知れませんので、そちらも参照してください。
*1 おおよその機能が動作し始めたら、最適化（高速化）のため C で再実装する可能性は残します。
*2 ここで言うバイトコードは、これまで中間コードと呼んでいたものです。numb-lambda が Java で実装されているため、Java VM のバイトコードと混同することを怖れ、このように呼んできました。しかし、不自然な感があるため、これよりはバイトコードと呼ぶことにします。バイトコードは独自の仮想マシンで実行可能なコードとします。
参考文献
プログラミング言語C 第2版
訳者 石田晴久
共立出版株式会社
ISBN4-320-02692-6