(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 (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)))
+
+(define (gc-cdr c)
+ (vector-ref the-cdrs (cell-index c)))
+
+(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)))
+
+(define (gc-null? x) (eq? (car x) 'e))
+
+(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 '* index))
+ (make-cell 'p index))
gc-free))
(define (make-number x)
((lambda (cell)
(vector-set! the-cars (cell-index cell) (make-cell 'n x))
- cell)
+ (gc-car cell))
(gc-alloc)))
(define (make-symbol x)
((lambda (cell)
(vector-set! the-cars (cell-index cell) (make-cell 's x))
- cell)
+ (gc-car 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-cars (cell-index cell) x)
(vector-set! the-cdrs (cell-index cell) y)
cell)
(gc-alloc)))
-(define (gc-car c)
- (vector-ref the-cars (cell-index c)))
-
-(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-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)
projects / mes.git / blobdiff