Class 24 - Section 5.3
;; storage.ss
;; goal: a small computing system which supports
;; list storage and garbage collection
;; this file implements the storage system
;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; the type system
;;
;;;;;;;;;;;;;;;;;;;;;;;;;
; we use typed data
; (p 5) ; pointer
; (n 5) ; number
; (s a) ; symbol
; (e 0) ; empty list
(define make-typed-data
(lambda (val)
(cond ((number? val) (list 'n val))
((symbol? val) (list 's val))
((null? val) (list 'e 0))
((pair? val) (store-list val))
(else "make-typed-data: oops! weird val" val))))
(define typed-data->tag car)
(define typed-data->data cadr)
(define pointer?
(lambda (typed-data)
(eq? 'p (typed-data->tag typed-data))))
(define make-pointer
(lambda (loc)
(list 'p loc)))
(define the-empty-list
(list 'e 0))
;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; symbol table (as a stack of frames)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;
;; =root= is a register which points to a symbol table
;; represented as an association list of var-val pairs.
;; entries in this list are called frames
(define =root= '())
(define make-frame list)
(define frame->var car)
(define frame->typed-data cadr)
(define atomic-data?
(lambda (frame)
(let ((tag (typed-data->tag (frame->typed-data frame))))
(if (member tag '(e n s)) #t #f))))
(define list-data?
(lambda (frame)
(let ((tag (typed-data->tag (frame->typed-data frame))))
(if (member tag '(p)) #t #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; define-sym
;;
;;;;;;;;;;;;;;;;;;;;;;;;;
;; define-sym inserts new var-val pairs into the symbol table
(define define-sym
(lambda (var val)
(if (sufficient-space-for? val)
(let ((typed-val (make-typed-data val)))
(set! =root= (cons (make-frame var typed-val) =root=))
=root=)
(writeln "define-sym: insufficient space for " val))))
(define sufficient-space-for?
(lambda (val)
(let ((needed (size val)))
(or (<= needed (storage-space-available))
(and (gc) (<= needed (storage-space-available)))))))
;; size
;; calculate storage requirements for val
(define size
(lambda (val)
(if (pair? val)
(length* val)
0)))
(define length*
(lambda (ls)
(cond ((null? ls) 0)
((pair? (car ls))
(+ 1 (length* (car ls)) (length* (cdr ls))))
(else (add1 (length* (cdr ls)))))))
;; store-list stores a list in memory
;; it returns a pointer to a loc
(define store-list
(lambda (ls)
;(writeln "store-list:" ls)
(let ((loc =free=))
(begin
(set! =free= (add1 =free=))
(if (pair? (car ls))
(set-kar! loc (store-list (car ls)))
(set-kar! loc (make-typed-data (car ls))))
(if (pair? (cdr ls))
(set-kdr! loc (store-list (cdr ls)))
(set-kdr! loc the-empty-list))
(make-pointer loc)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; primary storage
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; =the-kars= is a register which points to a vector
;; of size mem-size which holds the kars of kons cells
;; =the-kdrs= is a register which points to a vector
;; of size mem-size which holds the kdrs of kons cells
;; =free= is a register which holds an index into the
;; next available unused kons cell
(define mem-size 7)
(define =the-kars='*)
(define =the-kdrs='*)
(define =free= 0)
(define initialize-mem
(lambda ()
(set! =root= '())
(set! =the-kars= (make-vector mem-size '*))
(set! =the-kdrs= (make-vector mem-size '*))
(set! =free= 0)
(display-mem)))
(define storage-space-available
(lambda ()
(- mem-size =free=)))
(define kar
(lambda (index)
(vector-ref =the-kars= index)))
(define kdr
(lambda (index)
(vector-ref =the-kdrs= index)))
(define set-kar!
(lambda (reg1 reg2)
(vector-set! =the-kars= reg1 reg2)))
(define set-kdr!
(lambda (reg1 reg2)
(vector-set! =the-kdrs= reg1 reg2)))
(define display-mem
(lambda ()
(writeln "=root=:" =root=)
(writeln "=the-kars=:" =the-kars=)
(writeln "=the-kdrs=:" =the-kdrs=)
(writeln "=free=" =free=)))
;; new storage for garbage collection
(define =new-free= 0)
(define =new-kars= '*)
(define =new-kdrs= '*)
(define new-kar
(lambda (index)
(vector-ref =new-kars= index)))
(define new-kdr
(lambda (index)
(vector-ref =new-kdrs= index)))
(define set-new-kar!
(lambda (reg1 reg2)
(vector-set! =new-kars= reg1 reg2)))
(define set-new-kdr!
(lambda (reg1 reg2)
(vector-set! =new-kdrs= reg1 reg2)))
(define initialize-new-mem
(lambda ()
(set! =new-kars= (make-vector mem-size '*))
(set! =new-kdrs= (make-vector mem-size '*))
(set! =new-free= 0)
(display-new-mem)))
(define display-new-mem
(lambda ()
(writeln "=root=:" =root=)
(writeln "=new-kars=:" =new-kars=)
(writeln "=new-kdrs=:" =new-kdrs=)
(writeln "=new-free=" =new-free=)))
A Recursive Stop-and-Copy Compacting GC Algorithm
;; gc-recursive.ss
;; goal: a small computing system which supports
;; list storage and garbage collection
;; we will implement a recursive stop-and-copy compacting gc algorithm
; (load "storage.ss")
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; garbage collection
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; process
;; move all lists which are accessible through root
(define process
(lambda (stack)
(cond ((null? stack) '())
((atomic-data? (car stack))
(cons (car stack)
(process (cdr stack))))
((list-data? (car stack))
(cons (new-frame (car stack))
(process (cdr stack))))
(else (error "process: bad data" stack)))))
;; new-frame
;; produce a new stack frame
;; (to be inserted into the symbol table)
;; containing the original var and a new val
;; indicating the new location of that var's
;; associated value in storage
(define new-frame
(lambda (old-frame)
(make-frame (frame->var old-frame)
(move (frame->typed-data old-frame)))))
;; move-list
;; move-list relocates a list in memory
;; it returns a pointer to a loc
;; for the recursive gc algorithm, move = move-list
(define move-list
(lambda (ptr)
(let ((loc =new-free=)
(old-loc (cadr ptr)))
(begin
(set! =new-free= (add1 =new-free=))
(if (pointer? (kar old-loc))
(set-new-kar! loc (move-list (kar old-loc)))
(set-new-kar! loc (kar old-loc)))
(if (pointer? (kdr old-loc))
(set-new-kdr! loc (move-list (kdr old-loc)))
(set-new-kdr! loc the-empty-list))
(make-pointer loc)))))
;; flip interchanges old and new memory
;; and resets the old =free= pointer
;; this is the last stage in garbage collection
(define flip
(lambda ()
(let ((a =the-kars=)
(b =the-kdrs=)
(c =new-kars=)
(d =new-kdrs=)
(f =new-free=))
(set! =the-kars= c)
(set! =the-kdrs= d)
(set! =new-kars= a)
(set! =new-kdrs= b)
(set! =free= f)
(set! =new-free= 0))))
;; gc
(define gc-recursive
(lambda ()
(set! =root= (process =root=))
(flip)
#t))
(define move move-list)
(define gc gc-recursive)
gc-recursive Transcript
;; gc-recursive.script
;; goal: a small computing system which supports
;; list ops and garbage collection
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; load gc
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load "storage.ss")
(load "gc-recursive.ss")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing the model
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; initialize the model
=root=
(define mem-size 10)
(initialize-mem)
(initialize-new-mem)
;; make some definitions
(define-sym 'a 1)
(define-sym 'b 'b)
(define-sym 'c '())
(define-sym 'x '(15))
(define-sym 'y '(10 11 12))
(define-sym 'z '((a b) 14))
;; use typed pointers
; (p 5) ; pointer
; (n 5) ; number
; (s a) ; symbol
; (e 0) ; empty list
;; sample output
(display-mem)
; =the-kars= #((n 15) (n 10) (n 11) (n 12) (p 5) (s a) (s b) (n 14) * *)
; =the-kdrs= #((e 0) (p 2) (p 3) (e 0) (p 7) (p 6) (e 0) (e 0) * *)
; =free= 8
(display-new-mem)
;; create some garbage
;; snip off a bit of y's list
(set-kdr! 1 '(e 0))
;; pretend that x was a local variable which has now vanished
(set! =root=
'((z (p 4)) (y (p 1)) (c (e 0)) (b (s b)) (a (n 1))))
;; now where is the garbage in this heap?
;; Ans: Five cells are still "live" -- 0,2,3,8,9 are garbage
(display-mem)
; root: ((z (p 4)) (y (p 1)) (c (e 0)) (b (s b)) (a (n 1)))
; the-kars: #((n 15) (n 10) (n 11) (n 12) (p 5) (s a) (s b) (n 14) * *)
; the-kdrs: #((e 0) (e 0) (p 3) (e 0) (p 7) (p 6) (e 0) (e 0) * *)
; free 8
;; garbage collect
(gc)
;; display memory
;; and verify that the garbage has been left behind
;; and the data structures are relocated and still intact
(display-mem)
=root=: ((z (p 0)) (y (p 4)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=: #((p 1) (s a) (s b) (n 14) (n 10) * * * * *)
=the-kdrs=: #((p 3) (p 2) (e 0) (e 0) (e 0) * * * * *)
=free= 5
#f
;; the old memory is now available for the next gc cycle
;; (under the name new-mem; notice that new-free = 0)
(display-new-mem)
; =root=: ((z (p 4)) (y (p 1)) (c (e 0)) (b (s b)) (a (n 1)))
; =new-kars=: #((n 15) (n 10) (n 11) (n 12) (p 5) (s a) (s b) (n 14) * *)
; =new-kdrs=: #((e 0) (e 0) (p 3) (e 0) (p 7) (p 6) (e 0) (e 0) * *)
; =new-free= 0
;; test automatic garbage collection
;; insert a few lists
(define-sym 'ls1 '(me too please))
(define-sym 'ls2 '(yo tambien))
;; storage is full at this point
(display-mem)
=root=: ((ls2 (p 8)) (ls1 (p 5)) (z (p 0)) (y (p 4)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=: #((p 1) (s a) (s b) (n 14) (n 10) (s me) (s too) (s please) (s yo) (s tambien))
=the-kdrs=: #((p 3) (p 2) (e 0) (e 0) (e 0) (p 6) (p 7) (e 0) (p 9) (e 0))
=free= 10
(storage-space-available)
;; so there is not enough room for this next item
(define-sym 'ls3 '(try hard!))
;; even though the garbage collector ran in an attempt to liberate some space
(display-mem)
=root=: ((ls2 (p 0)) (ls1 (p 2)) (z (p 5)) (y (p 9)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=: #((s yo) (s tambien) (s me) (s too) (s please) (p 6) (s a) (s b) (n 14) (n 10))
=the-kdrs=: #((p 1) (e 0) (p 3) (p 4) (e 0) (p 8) (p 7) (e 0) (e 0) (e 0))
=free= 10
;; but dropping z out of the symbol table will liberate four cells
(set! =root= '((ls2 (p 0)) (ls1 (p 2)) (y (p 9)) (c (e 0)) (b (s b)) (a (n 1))))
;; now try again
(define-sym 'ls3 '(try really hard!))
;; it fit! -- because gc ran and liberated four cells
(display-mem)
=root=: ((ls3 (p 6)) (ls2 (p 0)) (ls1 (p 2)) (y (p 5)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=:
#((s yo) (s tambien) (s me) (s too) (s please) (n 10) (s try) (s really) (s hard!) (s tambien))
=the-kdrs=:
#((p 1) (e 0) (p 3) (p 4) (e 0) (e 0) (p 7) (p 8) (e 0) (e 0))
=free= 9
#f
;; wedge in one more
(define-sym 'ls4 '(oof!))
;; but now it's REALLY full -- since gc cannot liberate any more space
(define-sym 'ls5 '(quedo afuera))
(display-mem)
=root=:
((ls4 (p 0)) (ls3 (p 1)) (ls2 (p 4)) (ls1 (p 6)) (y (p 9)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=:
#((s oof!) (s try) (s really) (s hard!) (s yo) (s tambien) (s me) (s too) (s please) (n 10))
=the-kdrs=:
#((e 0) (p 2) (p 3) (e 0) (p 5) (e 0) (p 7) (p 8) (e 0) (e 0))
=free= 10
;; a good test -- garbage collect cyclic or shared data
;; have to leave behind a broken heart in the kar
;; and a forwarding address in the kdr
Cheney's Stop-and-Copy Compacting GC Algorithm
;; gc-cheney.ss
;; goal: a small computing system which supports
;; list storage and garbage collection
;; this file implements Cheney's stop-and-copy compacting gc algorithm
(load "storage.ss")
;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; the type system
;;
;;;;;;;;;;;;;;;;;;;;;;;;;
;; broken heart
;; a datatype used by the garbage collector only
;; if the contents of a cons cell get moved,
;; we place a broken heart in its kar and a
;; forwarding address in its kdr
; (bh 0)
(define make-broken-heart
(lambda ()
(list 'bh 0)))
(define broken-heart?
(lambda (typed-data)
(eq? 'bh (typed-data->tag typed-data))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; garbage collection
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; process
;; move all cons-cells which are
;; only one jump away from the root
;; process starts the job of relocating lists
(define process
(lambda (stack)
(cond ((null? stack) '())
((atomic-data? (car stack))
(cons (car stack)
(process (cdr stack))))
((list-data? (car stack))
(cons (new-frame (car stack))
(process (cdr stack))))
(else (error "process: bad data" stack)))))
;; new-frame
;; produce a new stack frame
;; (to be inserted into the symbol table)
;; containing the original var and a new val
;; indicating the new location of that var's
;; associated value in storage
(define new-frame
(lambda (old-frame)
(make-frame (frame->var old-frame)
(move (frame->typed-data old-frame)))))
;; move-cell
;; move the first cons-cell of a list
;; for Cheney's algorithm, move = move-cell
(define move-cell
(lambda (ptr)
(if (forwarded? ptr)
(forwarding-address ptr)
(let ((loc =new-free=)
(old-loc (typed-data->data ptr)))
(begin
(set! =new-free= (add1 =new-free=))
(set-new-kar! loc (kar old-loc))
(set-new-kdr! loc (kdr old-loc))
;; put a "broken heart" in the old kar
(set-kar! old-loc (make-broken-heart))
;; put a forwarding address in the old kdr
(let ((new-addr (make-pointer loc)))
(set-kdr! old-loc new-addr)
new-addr))))))
(define forwarded?
(lambda (ptr)
(and (pointer? ptr)
(broken-heart? (kar (typed-data->data ptr))))))
(define forwarding-address
(lambda (ptr)
(kdr (typed-data->data ptr))))
;; scan
;; scan completes the job of relocating lists
;; it is started in cell 0 and it finishes
;; when it catches up with =new-free=
(define scan
(lambda (addr)
(if (< addr =new-free=)
(let ((nkar (new-kar addr))
(nkdr (new-kdr addr)))
(if (pointer? nkar)
(set-new-kar! addr (move-cell nkar)))
(if (pointer? nkdr)
(set-new-kdr! addr (move-cell nkdr)))
(scan (add1 addr))))))
;; flip interchanges old and new memory and
;; properly resets =free= and =new-free=
;; this is the last stage in garbage collection
(define flip
(lambda ()
(let ((a =the-kars=)
(b =the-kdrs=)
(c =new-kars=)
(d =new-kdrs=)
(f =new-free=))
(set! =the-kars= c)
(set! =the-kdrs= d)
(set! =new-kars= a)
(set! =new-kdrs= b)
(set! =free= f)
(set! =new-free= 0))))
;; gc
(define gc-cheney
(lambda ()
(set! =root= (process =root=))
(scan 0)
(flip)
#t))
(define move move-cell)
(define gc gc-cheney)
gc-cheney Transcript
;; gc-cheney.script
;; goal: a small computing system which supports
;; list ops and garbage collection
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; load gc
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load "storage.ss")
(load "gc-cheney.ss")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing the model
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; initialize the model
=root=
(define mem-size 10)
(initialize-mem)
(initialize-new-mem)
(define gc gc-cheney) ; or (define gc gc-recursive)
;; make some definitions
(define-sym 'a 1)
(define-sym 'b 'b)
(define-sym 'c '())
(define-sym 'x '(15))
(define-sym 'y '(10 11 12))
(define-sym 'z '((a b) 14))
;; use typed pointers
; (p 5) ; pointer
; (n 5) ; number
; (s a) ; symbol
; (e 0) ; empty list
;; sample output
(display-mem)
=root=: ((z (p 4)) (y (p 1)) (x (p 0)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=: #((n 15) (n 10) (n 11) (n 12) (p 5) (s a) (s b) (n 14) * *)
=the-kdrs=: #((e 0) (p 2) (p 3) (e 0) (p 7) (p 6) (e 0) (e 0) * *)
=free= 8
(display-new-mem)
;; create some garbage
;; snip off a bit of y's list
(set-kdr! 1 '(e 0))
;; pretend that x was a local variable which has now vanished
(set! =root=
'((z (p 4)) (y (p 1)) (c (e 0)) (b (s b)) (a (n 1))))
;; now where is the garbage in this heap?
;; Ans: Five cells are still "live" -- 0,2,3,8,9 are garbage
(display-mem)
=root=: ((z (p 4)) (y (p 1)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=: #((n 15) (n 10) (n 11) (n 12) (p 5) (s a) (s b) (n 14) * *)
=the-kdrs=: #((e 0) (e 0) (p 3) (e 0) (p 7) (p 6) (e 0) (e 0) * *)
=free= 8
;; garbage collect
(gc)
;; display memory
;; and verify that the garbage has been left behind
;; and the data structures are relocated and still intact
(display-mem)
=root=: ((z (p 0)) (y (p 1)) (c (e 0)) (b (s b)) (a (n 1)))
=the-kars=: #((p 2) (n 10) (s a) (n 14) (s b) * * * * *)
=the-kdrs=: #((p 3) (e 0) (p 4) (e 0) (e 0) * * * * *)
=free= 5
;; the old memory is now available for the next gc cycle
;; (under the name new-mem; notice that new-free = 0)
(display-new-mem)
=root=: ((z (p 0)) (y (p 1)) (c (e 0)) (b (s b)) (a (n 1)))
=new-kars=: #((n 15) (bh 0) (n 11) (n 12) (bh 0) (bh 0) (bh 0) (bh 0) * *)
=new-kdrs=: #((e 0) (p 1) (p 3) (e 0) (p 0) (p 2) (p 4) (p 3) * *)
=new-free= 0
;; test automatic garbage collection
;; insert a few lists
(define-sym 'ls1 '(me too please))
(define-sym 'ls2 '(yo tambien))
;; storage is full at this point
(display-mem)
=the-kars=: #((p 2) (n 10) (s a) (n 14) (s b) (s me) (s too) (s please) (s yo)
(s tambien))
=the-kdrs=: #((p 3) (e 0) (p 4) (e 0) (e 0) (p 6) (p 7) (e 0) (p 9)
(e 0))
=free= 10
(storage-space-available)
;; so there is not enough room for this next item
(define-sym 'ls3 '(try hard!))
;; even though the garbage collector ran in an attempt to liberate some space
(display-mem)
=root=: ((ls2 (p 0)) (ls1 (p 1)) (z (p 2)) (y (p 3)) (c (e 0)) (b (s b))
(a (n 1)))
=the-kars=: #((s yo) (s me) (p 6) (n 10) (s tambien) (s too) (s a) (n 14)
(s please) (s b))
=the-kdrs=: #((p 4) (p 5) (p 7) (e 0) (e 0) (p 8) (p 9) (e 0)
(e 0) (e 0))
=free= 10
;; but dropping z out of the symbol table will liberate four cells
(set! =root= '((ls2 (p 0)) (ls1 (p 2)) (y (p 9)) (c (e 0)) (b (s b)) (a (n 1))))
;; now try again
(define-sym 'ls3 '(try really hard!))
;; it fit! -- because gc ran and liberated four cells
(display-mem)
=root=: ((ls3 (p 6)) (ls2 (p 0)) (ls1 (p 1)) (y (p 2)) (c (e 0)) (b (s b))
(a (n 1)))
=the-kars=: #((s yo) (p 4) (s b) (s tambien) (s a) (n 14) (s try) (s really)
(s hard!) (bh 0))
=the-kdrs=: #((p 3) (p 5) (e 0) (e 0) (p 2) (e 0) (p 7) (p 8)
(e 0) (p 4))
=free= 9
;; wedge in one more
(define-sym 'ls4 '(oof!))
;; but now it's REALLY full -- since gc cannot liberate any more space
(define-sym 'ls5 '(quedo afuera))
(display-mem)
=root=: ((ls4 (p 0)) (ls3 (p 1)) (ls2 (p 2)) (ls1 (p 3)) (y (p 4)) (c (e 0))
(b (s b)) (a (n 1)))
=the-kars=: #((s oof!) (s try) (s yo) (p 7) (s b) (s really) (s tambien) (s a)
(n 14) (s hard!))
=the-kdrs=: #((e 0) (p 5) (p 6) (p 8) (e 0) (p 9) (e 0) (p 4)
(e 0) (e 0))
=free= 10
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing the collection of cyclic and shared data
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a good test -- garbage collect cyclic or shared data
;; have to leave behind a broken heart in the kar
;; and a forwarding address in the kdr
(initialize-mem)
(initialize-new-mem)
;; make some definitions
(define-sym 'circular '(a b c d))
(define-sym 'shared 'hukairs)
(display-mem)
(set! =root= '((circular (p 0)) (shared (p 0))))
(set-kdr! 3 (make-pointer 0))
(display-mem)
(gc)
(display-mem)
(display-new-mem)
SICP Source Code