guile/gc.scm

   1
   2 (define-module (guile gc))
   3
   4 (define (R) (reload-module (current-module)))
   5
   6 (define gc-size 10)
   7 (define the-cars (make-vector gc-size '(* . *)))
   8 (define the-cdrs (make-vector gc-size '(* . *)))
   9 (define gc-free 0)
  10 (define (gc-show)
  11   (display "\nfree:") (display gc-free) (newline)
  12   (display "       0       1       2       3       4       5       6       7       8       9\n")
  13   (display "cars:") (display the-cars) (newline)
  14   (display "cdrs:") (display the-cdrs) (newline))
  15
  16 (define (gc-show-new)
  17   (display "\nfree:") (display gc-free) (newline)
  18   (display "       0       1       2       3       4       5       6       7       8       9\n")
  19   (display "ncar:") (display new-cars) (newline)
  20   (display "ncdr:") (display new-cdrs) (newline))
  21 (gc-show)
  22
  23 (define (gc-car c)
  24   (vector-ref the-cars (cell-index c)))
  25
  26 (define (gc-cdr c)
  27   (vector-ref the-cdrs (cell-index c)))
  28
  29 (define (gc-set-car! c x)
  30   (if (gc-pair? c) (vector-set! the-cars (cell-index c) x)))
  31
  32 (define (gc-set-cdr! c x)
  33   (if (gc-pair? c) (vector-set! the-cdrs (cell-index c) x)))
  34
  35 (define (gc-null? x) (eq? (car x) 'e))
  36
  37 (define (gc-pair? c)
  38   (and (pair? c) (eq? (car c) 'p)))
  39
  40 (define (cell-index c)
  41   (if (eq? (car c) 'p)
  42       (cdr c)))
  43
  44 (define (cell-value c)
  45   (if (member (car c) '(n s))
  46    (cdr c)))
  47
  48 (define (make-cell type . x)
  49   (cons type (if (pair? x) (car x) '*)))
  50
  51 (define (gc-alloc)
  52   (if (= gc-free gc-size) (gc))
  53   ((lambda (index)
  54      (set! gc-free (+ gc-free 1))
  55      (make-cell 'p index))
  56    gc-free))
  57
  58 (define (make-number x)
  59   ((lambda (cell)
  60      (vector-set! the-cars (cell-index cell) (make-cell 'n x))
  61      (gc-car cell))
  62    (gc-alloc)))
  63
  64 (define (make-symbol x)
  65   ((lambda (cell)
  66      (vector-set! the-cars (cell-index cell) (make-cell 's x))
  67      (gc-car cell))
  68    (gc-alloc)))
  69
  70 (define (gc-cons x y)
  71   ((lambda (cell)
  72      (vector-set! the-cars (cell-index cell) x)
  73      (vector-set! the-cdrs (cell-index cell) y)
  74      cell)
  75    (gc-alloc)))
  76
  77 (define gc-nil (make-cell 'e 0))
  78 (define (gc-list . rest)
  79   (if (null? rest) gc-nil
  80       (gc-cons (car rest) (apply gc-list (cdr rest)))))
  81
  82 (define (gc-display x . cont?)
  83   (if (gc-pair? x) (begin (if (null? cont?) (display "("))
  84                           (gc-display (gc-car x))
  85                           (if (gc-pair? (gc-cdr x)) (display " "))
  86                           (if (not (gc-null? (gc-cdr x)))
  87                               (gc-display (gc-cdr x) #t))
  88                           (if (null? cont?) (display ")")))
  89       (if (gc-null? x) (if (not cont?) (display "()"))
  90           (display (cell-value x)))))
  91
  92 (define (gc-root)
  93   (filter gc-pair? (module-map (lambda (x y) (variable-ref y)) (current-module)))
  94   list1234)
  95
  96 (define new-cars (make-vector (+ gc-size root-size) '(* . *)))
  97 (define new-cdrs (make-vector (+ gc-size root-size) '(* . *)))
  98
  99 #!
 100      begin-garbage-collection
 101        (assign free (const 0))
 102        (assign scan (const 0))
 103        (assign old (reg root))
 104        (assign relocate-continue
 105                (label reassign-root))
 106        (goto (label relocate-old-result-in-new))
 107      reassign-root
 108        (assign root (reg new))
 109        (goto (label gc-loop))
 110
 111      gc-loop
 112        (test (op =) (reg scan) (reg free))
 113        (branch (label gc-flip))
 114        (assign old
 115                (op vector-ref)
 116                (reg new-cars)
 117                (reg scan))
 118        (assign relocate-continue
 119                (label update-car))
 120        (goto (label relocate-old-result-in-new))
 121
 122
 123      update-car
 124        (perform (op vector-set!)
 125                 (reg new-cars)
 126                 (reg scan)
 127                 (reg new))
 128        (assign  old
 129                 (op vector-ref)
 130                 (reg new-cdrs)
 131                 (reg scan))
 132        (assign  relocate-continue
 133                 (label update-cdr))
 134        (goto (label relocate-old-result-in-new))
 135      update-cdr
 136        (perform (op vector-set!)
 137                 (reg new-cdrs)
 138                 (reg scan)
 139                 (reg new))
 140        (assign  scan (op +) (reg scan) (const 1))
 141        (goto (label gc-loop))
 142
 143
 144      relocate-old-result-in-new
 145        (test (op pointer-to-pair?) (reg old))
 146        (branch (label pair))
 147        (assign new (reg old))
 148        (goto (reg relocate-continue))
 149      pair
 150        (assign  oldcr
 151                 (op vector-ref)
 152                 (reg the-cars)
 153                 (reg old))
 154        (test (op broken-heart?) (reg oldcr))
 155        (branch  (label already-moved))
 156        (assign  new (reg free)) ; new location for pair
 157        ;; Update ‘free’ pointer.
 158        (assign free (op +) (reg free) (const 1))
 159        ;; Copy the ‘car’ and ‘cdr’ to new memory.
 160        (perform (op vector-set!)
 161                 (reg new-cars)
 162                 (reg new)
 163                 (reg oldcr))
 164        (assign  oldcr
 165                 (op vector-ref)
 166                 (reg the-cdrs)
 167                 (reg old))
 168        (perform (op vector-set!)
 169                 (reg new-cdrs)
 170                 (reg new)
 171                 (reg oldcr))
 172        ;; Construct the broken heart.
 173        (perform (op vector-set!)
 174                 (reg the-cars)
 175                 (reg old)
 176                 (const broken-heart))
 177        (perform (op vector-set!)
 178                 (reg the-cdrs)
 179                 (reg old)
 180                 (reg new))
 181        (goto (reg relocate-continue))
 182      already-moved
 183        (assign  new
 184                 (op vector-ref)
 185                 (reg the-cdrs)
 186                 (reg old))
 187        (goto (reg relocate-continue))
 188
 189      gc-flip
 190        (assign temp (reg the-cdrs))
 191        (assign the-cdrs (reg new-cdrs))
 192        (assign new-cdrs (reg temp))
 193        (assign temp (reg the-cars))
 194        (assign the-cars (reg new-cars))
 195        (assign new-cars (reg temp))
 196
 197 !#
 198
 199 (define scan 0)
 200
 201 (define (gc)
 202   (let ((root (gc-root)))
 203     (display "gc root=") (display root) (newline)
 204     (set! gc-free 0)
 205     (set! scan 0)
 206     (gc-loop (gc-relocate root))))
 207
 208 (define (gc-loop new)
 209   (gc-show)
 210   (gc-show-new)
 211   (display "gc-loop new=") (display new) (newline)
 212   (display "gc-loop scan=") (display scan) (newline)
 213   (display "gc-loop free=") (display gc-free) (newline)
 214
 215   (if (eq? scan gc-free) (gc-flip)
 216       (let ((old (vector-ref new-cars scan)))
 217         (let ((new (gc-relocate old)))
 218           (let ((old (gc-update-car new)))
 219             (let ((new (gc-relocate old)))
 220               (gc-update-cdr new)
 221               (gc-loop new)))))))
 222
 223 (define (gc-update-car new) ; -> old
 224   (vector-set! new-cars scan new)
 225   (vector-ref new-cdrs scan))
 226
 227 (define (gc-update-cdr new)
 228   (vector-set! new-cdrs scan new)
 229   (set! scan (+ 1 scan)))
 230
 231 (define (broken-heart? c) (eq? (car c) '<))
 232 (define gc-broken-heart '(< . 3))
 233 (define (gc-relocate old) ; old -> new
 234   (display "gc-relocate old=") (display old) (newline)
 235   (display "gc-relocate old is pair?=") (display (gc-pair? old)) (newline)
 236
 237   (if (not (gc-pair? old)) old
 238       (let ((oldcr (vector-ref the-cars (cell-index old))))
 239         (display "gc-relocate oldcr=") (display oldcr) (newline)
 240         (if (broken-heart? oldcr) old
 241             (let ((new (cons 'p gc-free)))
 242               (set! gc-free (+ 1 gc-free))
 243               (vector-set! new-cars (cell-index new) oldcr)
 244               (let ((oldcr (vector-ref the-cdrs (cell-index old))))
 245                 (display "gc-relocate oldcr=") (display oldcr) (newline)
 246                 (vector-set! new-cdrs (cell-index new) oldcr)
 247                 (vector-set! the-cars (cell-index old) gc-broken-heart)
 248                 (vector-set! the-cdrs (cell-index old) new))
 249               new)))))
 250
 251 (define (gc-flip)
 252   (let ((cars the-cars)
 253         (cdrs the-cdrs))
 254     (set! the-cars new-cars)
 255     (set! the-cdrs new-cdrs)
 256     (set! new-cars cars)
 257     (set! new-cdrs cdrs))
 258   (gc-show))
 259
 260 (define first (make-symbol 'F)) (newline)
 261
 262 (define one (make-number 1))
 263 (display "\n one=") (display one) (newline)
 264 (define two (make-number 2))
 265 (define pair2-nil (gc-cons two gc-nil))
 266 (display "\npair2-nil=") (display pair2-nil) (newline)
 267 (gc-show)
 268
 269 (define list1-2 (gc-cons one pair2-nil))
 270 (display "\nlist1-2=") (display list1-2) (newline)
 271 (gc-show)
 272
 273 (define three (make-number 3))
 274 (define four (make-number 4))
 275 (define pair4-nil (gc-cons four gc-nil))
 276 (define list3-4 (gc-cons three pair4-nil))
 277 (define list1234 (gc-cons list1-2 list3-4))
 278 (gc-show)
 279
 280 (display "\nlist1-2=") (display list1-2) (newline)
 281 (display "\nlist3-4=") (display list3-4) (newline)
 282 (display "lst=") (display list1234) (newline)
 283 (gc-show)
 284
 285 (display "sicp-lst:") (gc-display list1234) (newline)
 286 (gc-show)
 287
 288 (define next (gc-list (make-symbol 'N) (make-symbol 'X)))
 289 (set! list1234 '(p . 0))
 290 (display "sicp-lst:") (gc-display list1234) (newline)
 291 (gc-show)
 292 (display "next=") (display next) (newline)
 293 (display "gc-next=") (gc-display next) (newline)
 294 (gc-show)