2f680b778834085cfdbff03bede31642c0956c3d
[mes.git] / 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)