Guile gc experiment: add garbage collection.
This commit is contained in:
Jan Nieuwenhuizen
parent
e1d5135af6
commit
8fbe7f1b32
312
guile/gc.scm
312
guile/gc.scm
|
|
@ -7,43 +7,18 @@
|
|||
(define the-cars (make-vector gc-size '(* . *)))
|
||||
(define the-cdrs (make-vector gc-size '(* . *)))
|
||||
(define gc-free 0)
|
||||
(define (show-gc)
|
||||
(define (gc-show)
|
||||
(display "\nfree:") (display gc-free) (newline)
|
||||
(display " 0 1 2 3 4 5 6 7 8 9\n")
|
||||
(display "cars:") (display the-cars) (newline)
|
||||
(display "cdrs:") (display the-cdrs) (newline))
|
||||
(show-gc)
|
||||
|
||||
(define (cell-type c) (car (gc-cell c)))
|
||||
(define cell-index cdr)
|
||||
(define (cell-value c) (cdr (gc-cell c)))
|
||||
|
||||
(define (make-cell type . x)
|
||||
(cons type (if (pair? x) (car x) '*)))
|
||||
|
||||
(define (gc-alloc)
|
||||
((lambda (index)
|
||||
(set! gc-free (+ gc-free 1))
|
||||
(make-cell '* index))
|
||||
gc-free))
|
||||
|
||||
(define (make-number x)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cars (cell-index cell) (make-cell 'n x))
|
||||
cell)
|
||||
(gc-alloc)))
|
||||
|
||||
(define (make-symbol x)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cars (cell-index cell) (make-cell 's x))
|
||||
cell)
|
||||
(gc-alloc)))
|
||||
|
||||
(define (gc-cons x y)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cars (cell-index cell) (make-cell 'p (cell-index x)))
|
||||
(vector-set! the-cdrs (cell-index cell) y)
|
||||
cell)
|
||||
(gc-alloc)))
|
||||
(define (gc-show-new)
|
||||
(display "\nfree:") (display gc-free) (newline)
|
||||
(display " 0 1 2 3 4 5 6 7 8 9\n")
|
||||
(display "ncar:") (display new-cars) (newline)
|
||||
(display "ncdr:") (display new-cdrs) (newline))
|
||||
(gc-show)
|
||||
|
||||
(define (gc-car c)
|
||||
(vector-ref the-cars (cell-index c)))
|
||||
|
|
@ -51,48 +26,269 @@
|
|||
(define (gc-cdr c)
|
||||
(vector-ref the-cdrs (cell-index c)))
|
||||
|
||||
(define gc-cell gc-car)
|
||||
(define (gc-pair? c)
|
||||
(eq? (cell-type c) 'p))
|
||||
|
||||
(define (gc-set-car! c x)
|
||||
(if (gc-pair? c) (vector-set! the-cars (cell-index c) x)))
|
||||
|
||||
(define (gc-set-cdr! c x)
|
||||
(if (gc-pair? c) (vector-set! the-cdrs (cell-index c) x)))
|
||||
|
||||
(display "number 7=") (display (make-number 7)) (newline)
|
||||
(define first (make-number 8)) (newline)
|
||||
(show-gc)
|
||||
(define second (make-number 9)) (newline)
|
||||
(show-gc)
|
||||
(define pair (gc-cons first second))
|
||||
(show-gc)
|
||||
(display "pair:") (display pair) (newline)
|
||||
|
||||
(display "car:") (display (gc-car pair)) (newline)
|
||||
(display "cdr:") (display (gc-cdr pair)) (newline)
|
||||
|
||||
(define (gc-null? x) (eq? (car x) 'e))
|
||||
|
||||
(define gc-nil (make-cell 'e 0))
|
||||
(display "nil: ") (display gc-nil) (newline)
|
||||
(define (gc-pair? c)
|
||||
(and (pair? c) (eq? (car c) 'p)))
|
||||
|
||||
(define (cell-index c)
|
||||
(if (eq? (car c) 'p)
|
||||
(cdr c)))
|
||||
|
||||
(define (cell-value c)
|
||||
(if (member (car c) '(n s))
|
||||
(cdr c)))
|
||||
|
||||
(define (make-cell type . x)
|
||||
(cons type (if (pair? x) (car x) '*)))
|
||||
|
||||
(define (gc-alloc)
|
||||
(if (= gc-free gc-size) (gc))
|
||||
((lambda (index)
|
||||
(set! gc-free (+ gc-free 1))
|
||||
(make-cell 'p index))
|
||||
gc-free))
|
||||
|
||||
(define (make-number x)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cars (cell-index cell) (make-cell 'n x))
|
||||
(gc-car cell))
|
||||
(gc-alloc)))
|
||||
|
||||
(define (make-symbol x)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cars (cell-index cell) (make-cell 's x))
|
||||
(gc-car cell))
|
||||
(gc-alloc)))
|
||||
|
||||
(define (gc-cons x y)
|
||||
((lambda (cell)
|
||||
(vector-set! the-cars (cell-index cell) x)
|
||||
(vector-set! the-cdrs (cell-index cell) y)
|
||||
cell)
|
||||
(gc-alloc)))
|
||||
|
||||
(define gc-nil (make-cell 'e 0))
|
||||
(define (gc-list . rest)
|
||||
(if (null? rest) gc-nil
|
||||
(gc-cons (car rest) (apply gc-list (cdr rest)))))
|
||||
|
||||
(define lst (gc-list (make-symbol 'a) (make-symbol 'b) (make-symbol 'c)))
|
||||
(display "lst:") (display lst) (newline)
|
||||
(show-gc)
|
||||
|
||||
(define (gc-display x . cont?)
|
||||
(if (gc-pair? x) (begin (if (null? cont?) (display "("))
|
||||
(gc-display (gc-car x))
|
||||
(if (gc-pair? (gc-cdr x)) (display " "))
|
||||
(gc-display (gc-cdr x) #t)
|
||||
(if (not (gc-null? (gc-cdr x)))
|
||||
(gc-display (gc-cdr x) #t))
|
||||
(if (null? cont?) (display ")")))
|
||||
(if (gc-null? x) (if (not cont?) (display "()"))
|
||||
(display (cell-value x)))))
|
||||
(display "gc-display lst=") (gc-display lst) (newline)
|
||||
(show-gc)
|
||||
|
||||
(define (gc-root)
|
||||
(filter gc-pair? (module-map (lambda (x y) (variable-ref y)) (current-module)))
|
||||
list1234)
|
||||
|
||||
(define new-cars (make-vector (+ gc-size root-size) '(* . *)))
|
||||
(define new-cdrs (make-vector (+ gc-size root-size) '(* . *)))
|
||||
|
||||
#!
|
||||
begin-garbage-collection
|
||||
(assign free (const 0))
|
||||
(assign scan (const 0))
|
||||
(assign old (reg root))
|
||||
(assign relocate-continue
|
||||
(label reassign-root))
|
||||
(goto (label relocate-old-result-in-new))
|
||||
reassign-root
|
||||
(assign root (reg new))
|
||||
(goto (label gc-loop))
|
||||
|
||||
gc-loop
|
||||
(test (op =) (reg scan) (reg free))
|
||||
(branch (label gc-flip))
|
||||
(assign old
|
||||
(op vector-ref)
|
||||
(reg new-cars)
|
||||
(reg scan))
|
||||
(assign relocate-continue
|
||||
(label update-car))
|
||||
(goto (label relocate-old-result-in-new))
|
||||
|
||||
|
||||
update-car
|
||||
(perform (op vector-set!)
|
||||
(reg new-cars)
|
||||
(reg scan)
|
||||
(reg new))
|
||||
(assign old
|
||||
(op vector-ref)
|
||||
(reg new-cdrs)
|
||||
(reg scan))
|
||||
(assign relocate-continue
|
||||
(label update-cdr))
|
||||
(goto (label relocate-old-result-in-new))
|
||||
update-cdr
|
||||
(perform (op vector-set!)
|
||||
(reg new-cdrs)
|
||||
(reg scan)
|
||||
(reg new))
|
||||
(assign scan (op +) (reg scan) (const 1))
|
||||
(goto (label gc-loop))
|
||||
|
||||
|
||||
relocate-old-result-in-new
|
||||
(test (op pointer-to-pair?) (reg old))
|
||||
(branch (label pair))
|
||||
(assign new (reg old))
|
||||
(goto (reg relocate-continue))
|
||||
pair
|
||||
(assign oldcr
|
||||
(op vector-ref)
|
||||
(reg the-cars)
|
||||
(reg old))
|
||||
(test (op broken-heart?) (reg oldcr))
|
||||
(branch (label already-moved))
|
||||
(assign new (reg free)) ; new location for pair
|
||||
;; Update ‘free’ pointer.
|
||||
(assign free (op +) (reg free) (const 1))
|
||||
;; Copy the ‘car’ and ‘cdr’ to new memory.
|
||||
(perform (op vector-set!)
|
||||
(reg new-cars)
|
||||
(reg new)
|
||||
(reg oldcr))
|
||||
(assign oldcr
|
||||
(op vector-ref)
|
||||
(reg the-cdrs)
|
||||
(reg old))
|
||||
(perform (op vector-set!)
|
||||
(reg new-cdrs)
|
||||
(reg new)
|
||||
(reg oldcr))
|
||||
;; Construct the broken heart.
|
||||
(perform (op vector-set!)
|
||||
(reg the-cars)
|
||||
(reg old)
|
||||
(const broken-heart))
|
||||
(perform (op vector-set!)
|
||||
(reg the-cdrs)
|
||||
(reg old)
|
||||
(reg new))
|
||||
(goto (reg relocate-continue))
|
||||
already-moved
|
||||
(assign new
|
||||
(op vector-ref)
|
||||
(reg the-cdrs)
|
||||
(reg old))
|
||||
(goto (reg relocate-continue))
|
||||
|
||||
gc-flip
|
||||
(assign temp (reg the-cdrs))
|
||||
(assign the-cdrs (reg new-cdrs))
|
||||
(assign new-cdrs (reg temp))
|
||||
(assign temp (reg the-cars))
|
||||
(assign the-cars (reg new-cars))
|
||||
(assign new-cars (reg temp))
|
||||
|
||||
!#
|
||||
|
||||
(define scan 0)
|
||||
|
||||
(define (gc)
|
||||
(let ((root (gc-root)))
|
||||
(display "gc root=") (display root) (newline)
|
||||
(set! gc-free 0)
|
||||
(set! scan 0)
|
||||
(gc-loop (gc-relocate root))))
|
||||
|
||||
(define (gc-loop new)
|
||||
(gc-show)
|
||||
(gc-show-new)
|
||||
(display "gc-loop new=") (display new) (newline)
|
||||
(display "gc-loop scan=") (display scan) (newline)
|
||||
(display "gc-loop free=") (display gc-free) (newline)
|
||||
|
||||
(if (eq? scan gc-free) (gc-flip)
|
||||
(let ((old (vector-ref new-cars scan)))
|
||||
(let ((new (gc-relocate old)))
|
||||
(let ((old (gc-update-car new)))
|
||||
(let ((new (gc-relocate old)))
|
||||
(gc-update-cdr new)
|
||||
(gc-loop new)))))))
|
||||
|
||||
(define (gc-update-car new) ; -> old
|
||||
(vector-set! new-cars scan new)
|
||||
(vector-ref new-cdrs scan))
|
||||
|
||||
(define (gc-update-cdr new)
|
||||
(vector-set! new-cdrs scan new)
|
||||
(set! scan (+ 1 scan)))
|
||||
|
||||
(define (broken-heart? c) (eq? (car c) '<))
|
||||
(define gc-broken-heart '(< . 3))
|
||||
(define (gc-relocate old) ; old -> new
|
||||
(display "gc-relocate old=") (display old) (newline)
|
||||
(display "gc-relocate old is pair?=") (display (gc-pair? old)) (newline)
|
||||
|
||||
(if (not (gc-pair? old)) old
|
||||
(let ((oldcr (vector-ref the-cars (cell-index old))))
|
||||
(display "gc-relocate oldcr=") (display oldcr) (newline)
|
||||
(if (broken-heart? oldcr) old
|
||||
(let ((new (cons 'p gc-free)))
|
||||
(set! gc-free (+ 1 gc-free))
|
||||
(vector-set! new-cars (cell-index new) oldcr)
|
||||
(let ((oldcr (vector-ref the-cdrs (cell-index old))))
|
||||
(display "gc-relocate oldcr=") (display oldcr) (newline)
|
||||
(vector-set! new-cdrs (cell-index new) oldcr)
|
||||
(vector-set! the-cars (cell-index old) gc-broken-heart)
|
||||
(vector-set! the-cdrs (cell-index old) new))
|
||||
new)))))
|
||||
|
||||
(define (gc-flip)
|
||||
(let ((cars the-cars)
|
||||
(cdrs the-cdrs))
|
||||
(set! the-cars new-cars)
|
||||
(set! the-cdrs new-cdrs)
|
||||
(set! new-cars cars)
|
||||
(set! new-cdrs cdrs))
|
||||
(gc-show))
|
||||
|
||||
(define first (make-symbol 'F)) (newline)
|
||||
|
||||
(define one (make-number 1))
|
||||
(display "\n one=") (display one) (newline)
|
||||
(define two (make-number 2))
|
||||
(define pair2-nil (gc-cons two gc-nil))
|
||||
(display "\npair2-nil=") (display pair2-nil) (newline)
|
||||
(gc-show)
|
||||
|
||||
(define list1-2 (gc-cons one pair2-nil))
|
||||
(display "\nlist1-2=") (display list1-2) (newline)
|
||||
(gc-show)
|
||||
|
||||
(define three (make-number 3))
|
||||
(define four (make-number 4))
|
||||
(define pair4-nil (gc-cons four gc-nil))
|
||||
(define list3-4 (gc-cons three pair4-nil))
|
||||
(define list1234 (gc-cons list1-2 list3-4))
|
||||
(gc-show)
|
||||
|
||||
(display "\nlist1-2=") (display list1-2) (newline)
|
||||
(display "\nlist3-4=") (display list3-4) (newline)
|
||||
(display "lst=") (display list1234) (newline)
|
||||
(gc-show)
|
||||
|
||||
(display "sicp-lst:") (gc-display list1234) (newline)
|
||||
(gc-show)
|
||||
|
||||
(define next (gc-list (make-symbol 'N) (make-symbol 'X)))
|
||||
(set! list1234 '(p . 0))
|
||||
(display "sicp-lst:") (gc-display list1234) (newline)
|
||||
(gc-show)
|
||||
(display "next=") (display next) (newline)
|
||||
(display "gc-next=") (gc-display next) (newline)
|
||||
(gc-show)
|
||||
|
|
|
|||
Loading…
Reference in a new issue