mes/guile/gc.scm

319 lines
9.4 KiB
Scheme
Raw Normal View History

;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; mes.mes: This file is part of Mes.
;;;
;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Mes is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; This is an early SICP stop-and-copy garbage collector playground,
;;; currently not used.
;;; Code:
(define-module (guile gc))
(define (R) (reload-module (current-module)))
(define gc-size 10)
(define the-cars (make-vector gc-size '(* . *)))
(define the-cdrs (make-vector gc-size '(* . *)))
(define gc-free 0)
(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))
(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 '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 (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 " "))
(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)))))
(define (gc-root)
(filter gc-pair? (module-map (lambda (x y) (variable-ref y)) (current-module)))
list1234)
(define new-cars (make-vector gc-size '(* . *)))
(define new-cdrs (make-vector gc-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 (gc)
(let ((root (gc-root)))
(display "gc root=") (display root) (newline)
(set! gc-free 0)
(gc-relocate root)
(gc-loop 0)))
(define (gc-loop scan)
(gc-show)
(gc-show-new)
(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 scan new)))
(let ((new (gc-relocate old)))
(let ((scan (gc-update-cdr scan new)))
(gc-loop scan))))))))
(define (gc-update-car scan new) ; -> old
(vector-set! new-cars scan new)
(vector-ref new-cdrs scan))
(define (gc-update-cdr scan new)
(vector-set! new-cdrs scan new)
(+ 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)
(display "\n**** trigger gc ****\n")
(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)