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