guile/gc.scm

   1 ;;; -*-scheme-*-
   2
   3 ;;; Mes --- Maxwell Equations of Software
   4 ;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; mes.mes: This file is part of Mes.
   7 ;;;
   8 ;;; Mes is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; Mes is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; This is an early SICP stop-and-copy garbage collector playground,
  24 ;;; currently not used.
  25
  26 ;;; Code:
  27
  28 (define-module (guile gc))
  29
  30 (define (R) (reload-module (current-module)))
  31
  32 (define gc-size 10)
  33 (define the-cars (make-vector gc-size '(* . *)))
  34 (define the-cdrs (make-vector gc-size '(* . *)))
  35 (define gc-free 0)
  36 (define (gc-show)
  37   (display "\nfree:") (display gc-free) (newline)
  38   (display "       0       1       2       3       4       5       6       7       8       9\n")
  39   (display "cars:") (display the-cars) (newline)
  40   (display "cdrs:") (display the-cdrs) (newline))
  41
  42 (define (gc-show-new)
  43   (display "\nfree:") (display gc-free) (newline)
  44   (display "       0       1       2       3       4       5       6       7       8       9\n")
  45   (display "ncar:") (display new-cars) (newline)
  46   (display "ncdr:") (display new-cdrs) (newline))
  47 (gc-show)
  48
  49 (define (gc-car c)
  50   (vector-ref the-cars (cell-index c)))
  51
  52 (define (gc-cdr c)
  53   (vector-ref the-cdrs (cell-index c)))
  54
  55 (define (gc-set-car! c x)
  56   (if (gc-pair? c) (vector-set! the-cars (cell-index c) x)))
  57
  58 (define (gc-set-cdr! c x)
  59   (if (gc-pair? c) (vector-set! the-cdrs (cell-index c) x)))
  60
  61 (define (gc-null? x) (eq? (car x) 'e))
  62
  63 (define (gc-pair? c)
  64   (and (pair? c) (eq? (car c) 'p)))
  65
  66 (define (cell-index c)
  67   (if (eq? (car c) 'p)
  68       (cdr c)))
  69
  70 (define (cell-value c)
  71   (if (member (car c) '(n s))
  72    (cdr c)))
  73
  74 (define (make-cell type . x)
  75   (cons type (if (pair? x) (car x) '*)))
  76
  77 (define (gc-alloc)
  78   (if (= gc-free gc-size) (gc))
  79   ((lambda (index)
  80      (set! gc-free (+ gc-free 1))
  81      (make-cell 'p index))
  82    gc-free))
  83
  84 (define (make-number x)
  85   ((lambda (cell)
  86      (vector-set! the-cars (cell-index cell) (make-cell 'n x))
  87      (gc-car cell))
  88    (gc-alloc)))
  89
  90 (define (make-symbol x)
  91   ((lambda (cell)
  92      (vector-set! the-cars (cell-index cell) (make-cell 's x))
  93      (gc-car cell))
  94    (gc-alloc)))
  95
  96 (define (gc-cons x y)
  97   ((lambda (cell)
  98      (vector-set! the-cars (cell-index cell) x)
  99      (vector-set! the-cdrs (cell-index cell) y)
 100      cell)
 101    (gc-alloc)))
 102
 103 (define gc-nil (make-cell 'e 0))
 104 (define (gc-list . rest)
 105   (if (null? rest) gc-nil
 106       (gc-cons (car rest) (apply gc-list (cdr rest)))))
 107
 108 (define (gc-display x . cont?)
 109   (if (gc-pair? x) (begin (if (null? cont?) (display "("))
 110                           (gc-display (gc-car x))
 111                           (if (gc-pair? (gc-cdr x)) (display " "))
 112                           (if (not (gc-null? (gc-cdr x)))
 113                               (gc-display (gc-cdr x) #t))
 114                           (if (null? cont?) (display ")")))
 115       (if (gc-null? x) (if (not cont?) (display "()"))
 116           (display (cell-value x)))))
 117
 118 (define (gc-root)
 119   (filter gc-pair? (module-map (lambda (x y) (variable-ref y)) (current-module)))
 120   list1234)
 121
 122 (define new-cars (make-vector gc-size '(* . *)))
 123 (define new-cdrs (make-vector gc-size '(* . *)))
 124
 125 #!
 126      begin-garbage-collection
 127        (assign free (const 0))
 128        (assign scan (const 0))
 129        (assign old (reg root))
 130        (assign relocate-continue
 131                (label reassign-root))
 132        (goto (label relocate-old-result-in-new))
 133      reassign-root
 134        (assign root (reg new))
 135        (goto (label gc-loop))
 136
 137      gc-loop
 138        (test (op =) (reg scan) (reg free))
 139        (branch (label gc-flip))
 140        (assign old
 141                (op vector-ref)
 142                (reg new-cars)
 143                (reg scan))
 144        (assign relocate-continue
 145                (label update-car))
 146        (goto (label relocate-old-result-in-new))
 147
 148
 149      update-car
 150        (perform (op vector-set!)
 151                 (reg new-cars)
 152                 (reg scan)
 153                 (reg new))
 154        (assign  old
 155                 (op vector-ref)
 156                 (reg new-cdrs)
 157                 (reg scan))
 158        (assign  relocate-continue
 159                 (label update-cdr))
 160        (goto (label relocate-old-result-in-new))
 161      update-cdr
 162        (perform (op vector-set!)
 163                 (reg new-cdrs)
 164                 (reg scan)
 165                 (reg new))
 166        (assign  scan (op +) (reg scan) (const 1))
 167        (goto (label gc-loop))
 168
 169
 170      relocate-old-result-in-new
 171        (test (op pointer-to-pair?) (reg old))
 172        (branch (label pair))
 173        (assign new (reg old))
 174        (goto (reg relocate-continue))
 175      pair
 176        (assign  oldcr
 177                 (op vector-ref)
 178                 (reg the-cars)
 179                 (reg old))
 180        (test (op broken-heart?) (reg oldcr))
 181        (branch  (label already-moved))
 182        (assign  new (reg free)) ; new location for pair
 183        ;; Update ‘free’ pointer.
 184        (assign free (op +) (reg free) (const 1))
 185        ;; Copy the ‘car’ and ‘cdr’ to new memory.
 186        (perform (op vector-set!)
 187                 (reg new-cars)
 188                 (reg new)
 189                 (reg oldcr))
 190        (assign  oldcr
 191                 (op vector-ref)
 192                 (reg the-cdrs)
 193                 (reg old))
 194        (perform (op vector-set!)
 195                 (reg new-cdrs)
 196                 (reg new)
 197                 (reg oldcr))
 198        ;; Construct the broken heart.
 199        (perform (op vector-set!)
 200                 (reg the-cars)
 201                 (reg old)
 202                 (const broken-heart))
 203        (perform (op vector-set!)
 204                 (reg the-cdrs)
 205                 (reg old)
 206                 (reg new))
 207        (goto (reg relocate-continue))
 208      already-moved
 209        (assign  new
 210                 (op vector-ref)
 211                 (reg the-cdrs)
 212                 (reg old))
 213        (goto (reg relocate-continue))
 214
 215      gc-flip
 216        (assign temp (reg the-cdrs))
 217        (assign the-cdrs (reg new-cdrs))
 218        (assign new-cdrs (reg temp))
 219        (assign temp (reg the-cars))
 220        (assign the-cars (reg new-cars))
 221        (assign new-cars (reg temp))
 222
 223 !#
 224
 225 (define (gc)
 226   (let ((root (gc-root)))
 227     (display "gc root=") (display root) (newline)
 228     (set! gc-free 0)
 229     (gc-relocate root)
 230     (gc-loop 0)))
 231
 232 (define (gc-loop scan)
 233   (gc-show)
 234   (gc-show-new)
 235   (display "gc-loop scan=") (display scan) (newline)
 236   (display "gc-loop free=") (display gc-free) (newline)
 237
 238   (if (eq? scan gc-free) (gc-flip)
 239       (let ((old (vector-ref new-cars scan)))
 240         (let ((new (gc-relocate old)))
 241           (let ((old (gc-update-car scan new)))
 242             (let ((new (gc-relocate old)))
 243               (let ((scan (gc-update-cdr scan new)))
 244                 (gc-loop scan))))))))
 245
 246 (define (gc-update-car scan new) ; -> old
 247   (vector-set! new-cars scan new)
 248   (vector-ref new-cdrs scan))
 249
 250 (define (gc-update-cdr scan new)
 251   (vector-set! new-cdrs scan new)
 252   (+ 1 scan))
 253
 254 (define (broken-heart? c) (eq? (car c) '<))
 255 (define gc-broken-heart '(< . 3))
 256 (define (gc-relocate old) ; old -> new
 257   (display "gc-relocate old=") (display old) (newline)
 258   (display "gc-relocate old is pair?=") (display (gc-pair? old)) (newline)
 259
 260   (if (not (gc-pair? old)) old
 261       (let ((oldcr (vector-ref the-cars (cell-index old))))
 262         (display "gc-relocate oldcr=") (display oldcr) (newline)
 263         (if (broken-heart? oldcr) old
 264             (let ((new (cons 'p gc-free)))
 265               (set! gc-free (+ 1 gc-free))
 266               (vector-set! new-cars (cell-index new) oldcr)
 267               (let ((oldcr (vector-ref the-cdrs (cell-index old))))
 268                 (display "gc-relocate oldcr=") (display oldcr) (newline)
 269                 (vector-set! new-cdrs (cell-index new) oldcr)
 270                 (vector-set! the-cars (cell-index old) gc-broken-heart)
 271                 (vector-set! the-cdrs (cell-index old) new))
 272               new)))))
 273
 274 (define (gc-flip)
 275   (let ((cars the-cars)
 276         (cdrs the-cdrs))
 277     (set! the-cars new-cars)
 278     (set! the-cdrs new-cdrs)
 279     (set! new-cars cars)
 280     (set! new-cdrs cdrs))
 281   (gc-show))
 282
 283 (define first (make-symbol 'F)) (newline)
 284
 285 (define one (make-number 1))
 286 (display "\n one=") (display one) (newline)
 287 (define two (make-number 2))
 288 (define pair2-nil (gc-cons two gc-nil))
 289 (display "\npair2-nil=") (display pair2-nil) (newline)
 290 (gc-show)
 291
 292 (define list1-2 (gc-cons one pair2-nil))
 293 (display "\nlist1-2=") (display list1-2) (newline)
 294 (gc-show)
 295
 296 (define three (make-number 3))
 297 (define four (make-number 4))
 298 (define pair4-nil (gc-cons four gc-nil))
 299 (define list3-4 (gc-cons three pair4-nil))
 300 (define list1234 (gc-cons list1-2 list3-4))
 301 (gc-show)
 302
 303 (display "\nlist1-2=") (display list1-2) (newline)
 304 (display "\nlist3-4=") (display list3-4) (newline)
 305 (display "lst=") (display list1234) (newline)
 306 (gc-show)
 307
 308 (display "sicp-lst:") (gc-display list1234) (newline)
 309 (gc-show)
 310
 311 (display "\n**** trigger gc ****\n")
 312 (define next (gc-list (make-symbol 'N) (make-symbol 'X)))
 313 (set! list1234 '(p . 0))
 314 (display "sicp-lst:") (gc-display list1234) (newline)
 315 (gc-show)
 316 (display "next=") (display next) (newline)
 317 (display "gc-next=") (gc-display next) (newline)
 318 (gc-show)