310 lines
9.2 KiB
Scheme
310 lines
9.2 KiB
Scheme
;;; GNU Mes --- Maxwell Equations of Software
|
||
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
||
;;;
|
||
;;; This file is part of GNU Mes.
|
||
;;;
|
||
;;; GNU 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.
|
||
;;;
|
||
;;; GNU 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 GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(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)
|