Guile gc experiment: add garbage collection.

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 (gc-show-new)
-(define cell-index cdr)
+  (display "\nfree:") (display gc-free) (newline)
-(define (cell-value c) (cdr (gc-cell c)))
+  (display "       0       1       2       3       4       5       6       7       8       9\n")
-
+  (display "ncar:") (display new-cars) (newline)
-(define (make-cell type . x)
+  (display "ncdr:") (display new-cdrs) (newline))
-  (cons type (if (pair? x) (car x) '*)))
+(gc-show)
-
-(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-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))
+(define (gc-pair? c)
-(display "nil: ") (display gc-nil) (newline)
+  (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)