core: One big eval_apply.
[mes.git] / guile / gc.scm
1
2 (define-module (guile gc))
3
4 (define (R) (reload-module (current-module)))
5
6 (define gc-size 10)
7 (define the-cars (make-vector gc-size '(* . *)))
8 (define the-cdrs (make-vector gc-size '(* . *)))
9 (define gc-free 0)
10 (define (gc-show)
11   (display "\nfree:") (display gc-free) (newline)
12   (display "       0       1       2       3       4       5       6       7       8       9\n")
13   (display "cars:") (display the-cars) (newline)
14   (display "cdrs:") (display the-cdrs) (newline))
15
16 (define (gc-show-new)
17   (display "\nfree:") (display gc-free) (newline)
18   (display "       0       1       2       3       4       5       6       7       8       9\n")
19   (display "ncar:") (display new-cars) (newline)
20   (display "ncdr:") (display new-cdrs) (newline))
21 (gc-show)
22
23 (define (gc-car c)
24   (vector-ref the-cars (cell-index c)))
25
26 (define (gc-cdr c)
27   (vector-ref the-cdrs (cell-index c)))
28
29 (define (gc-set-car! c x)
30   (if (gc-pair? c) (vector-set! the-cars (cell-index c) x)))
31
32 (define (gc-set-cdr! c x)
33   (if (gc-pair? c) (vector-set! the-cdrs (cell-index c) x)))
34
35 (define (gc-null? x) (eq? (car x) 'e))
36
37 (define (gc-pair? c)
38   (and (pair? c) (eq? (car c) 'p)))
39
40 (define (cell-index c)
41   (if (eq? (car c) 'p)
42       (cdr c)))
43
44 (define (cell-value c)
45   (if (member (car c) '(n s))
46    (cdr c)))
47
48 (define (make-cell type . x)
49   (cons type (if (pair? x) (car x) '*)))
50
51 (define (gc-alloc)
52   (if (= gc-free gc-size) (gc))
53   ((lambda (index)
54      (set! gc-free (+ gc-free 1))
55      (make-cell 'p index))
56    gc-free))
57
58 (define (make-number x)
59   ((lambda (cell)
60      (vector-set! the-cars (cell-index cell) (make-cell 'n x))
61      (gc-car cell))
62    (gc-alloc)))
63
64 (define (make-symbol x)
65   ((lambda (cell)
66      (vector-set! the-cars (cell-index cell) (make-cell 's x))
67      (gc-car cell))
68    (gc-alloc)))
69
70 (define (gc-cons x y)
71   ((lambda (cell)
72      (vector-set! the-cars (cell-index cell) x)
73      (vector-set! the-cdrs (cell-index cell) y)
74      cell)
75    (gc-alloc)))
76
77 (define gc-nil (make-cell 'e 0))
78 (define (gc-list . rest)
79   (if (null? rest) gc-nil
80       (gc-cons (car rest) (apply gc-list (cdr rest)))))
81
82 (define (gc-display x . cont?)
83   (if (gc-pair? x) (begin (if (null? cont?) (display "("))
84                           (gc-display (gc-car x))
85                           (if (gc-pair? (gc-cdr x)) (display " "))
86                           (if (not (gc-null? (gc-cdr x)))
87                               (gc-display (gc-cdr x) #t))
88                           (if (null? cont?) (display ")")))
89       (if (gc-null? x) (if (not cont?) (display "()"))
90           (display (cell-value x)))))
91
92 (define (gc-root)
93   (filter gc-pair? (module-map (lambda (x y) (variable-ref y)) (current-module)))
94   list1234)
95
96 (define new-cars (make-vector gc-size '(* . *)))
97 (define new-cdrs (make-vector gc-size '(* . *)))
98
99 #!
100      begin-garbage-collection
101        (assign free (const 0))
102        (assign scan (const 0))
103        (assign old (reg root))
104        (assign relocate-continue
105                (label reassign-root))
106        (goto (label relocate-old-result-in-new))
107      reassign-root
108        (assign root (reg new))
109        (goto (label gc-loop))
110
111      gc-loop
112        (test (op =) (reg scan) (reg free))
113        (branch (label gc-flip))
114        (assign old
115                (op vector-ref)
116                (reg new-cars)
117                (reg scan))
118        (assign relocate-continue
119                (label update-car))
120        (goto (label relocate-old-result-in-new))
121
122
123      update-car
124        (perform (op vector-set!)
125                 (reg new-cars)
126                 (reg scan)
127                 (reg new))
128        (assign  old
129                 (op vector-ref)
130                 (reg new-cdrs)
131                 (reg scan))
132        (assign  relocate-continue
133                 (label update-cdr))
134        (goto (label relocate-old-result-in-new))
135      update-cdr
136        (perform (op vector-set!)
137                 (reg new-cdrs)
138                 (reg scan)
139                 (reg new))
140        (assign  scan (op +) (reg scan) (const 1))
141        (goto (label gc-loop))
142
143
144      relocate-old-result-in-new
145        (test (op pointer-to-pair?) (reg old))
146        (branch (label pair))
147        (assign new (reg old))
148        (goto (reg relocate-continue))
149      pair
150        (assign  oldcr
151                 (op vector-ref)
152                 (reg the-cars)
153                 (reg old))
154        (test (op broken-heart?) (reg oldcr))
155        (branch  (label already-moved))
156        (assign  new (reg free)) ; new location for pair
157        ;; Update ‘free’ pointer.
158        (assign free (op +) (reg free) (const 1))
159        ;; Copy the ‘car’ and ‘cdr’ to new memory.
160        (perform (op vector-set!)
161                 (reg new-cars)
162                 (reg new)
163                 (reg oldcr))
164        (assign  oldcr
165                 (op vector-ref)
166                 (reg the-cdrs)
167                 (reg old))
168        (perform (op vector-set!)
169                 (reg new-cdrs)
170                 (reg new)
171                 (reg oldcr))
172        ;; Construct the broken heart.
173        (perform (op vector-set!)
174                 (reg the-cars)
175                 (reg old)
176                 (const broken-heart))
177        (perform (op vector-set!)
178                 (reg the-cdrs)
179                 (reg old)
180                 (reg new))
181        (goto (reg relocate-continue))
182      already-moved
183        (assign  new
184                 (op vector-ref)
185                 (reg the-cdrs)
186                 (reg old))
187        (goto (reg relocate-continue))
188
189      gc-flip
190        (assign temp (reg the-cdrs))
191        (assign the-cdrs (reg new-cdrs))
192        (assign new-cdrs (reg temp))
193        (assign temp (reg the-cars))
194        (assign the-cars (reg new-cars))
195        (assign new-cars (reg temp))
196
197 !#
198
199 (define (gc)
200   (let ((root (gc-root)))
201     (display "gc root=") (display root) (newline)
202     (set! gc-free 0)
203     (gc-relocate root)
204     (gc-loop 0)))
205
206 (define (gc-loop scan)
207   (gc-show)
208   (gc-show-new)
209   (display "gc-loop scan=") (display scan) (newline)
210   (display "gc-loop free=") (display gc-free) (newline)
211
212   (if (eq? scan gc-free) (gc-flip)
213       (let ((old (vector-ref new-cars scan)))
214         (let ((new (gc-relocate old)))
215           (let ((old (gc-update-car scan new))) 
216             (let ((new (gc-relocate old)))
217               (let ((scan (gc-update-cdr scan new)))
218                 (gc-loop scan))))))))
219
220 (define (gc-update-car scan new) ; -> old
221   (vector-set! new-cars scan new)
222   (vector-ref new-cdrs scan))
223
224 (define (gc-update-cdr scan new)
225   (vector-set! new-cdrs scan new)
226   (+ 1 scan))
227
228 (define (broken-heart? c) (eq? (car c) '<))
229 (define gc-broken-heart '(< . 3))
230 (define (gc-relocate old) ; old -> new
231   (display "gc-relocate old=") (display old) (newline)
232   (display "gc-relocate old is pair?=") (display (gc-pair? old)) (newline)
233   
234   (if (not (gc-pair? old)) old
235       (let ((oldcr (vector-ref the-cars (cell-index old))))
236         (display "gc-relocate oldcr=") (display oldcr) (newline)
237         (if (broken-heart? oldcr) old
238             (let ((new (cons 'p gc-free)))
239               (set! gc-free (+ 1 gc-free))
240               (vector-set! new-cars (cell-index new) oldcr)
241               (let ((oldcr (vector-ref the-cdrs (cell-index old))))
242                 (display "gc-relocate oldcr=") (display oldcr) (newline)
243                 (vector-set! new-cdrs (cell-index new) oldcr)
244                 (vector-set! the-cars (cell-index old) gc-broken-heart)
245                 (vector-set! the-cdrs (cell-index old) new))
246               new)))))
247
248 (define (gc-flip)
249   (let ((cars the-cars)
250         (cdrs the-cdrs))
251     (set! the-cars new-cars)
252     (set! the-cdrs new-cdrs)
253     (set! new-cars cars)
254     (set! new-cdrs cdrs))
255   (gc-show))
256
257 (define first (make-symbol 'F)) (newline)
258
259 (define one (make-number 1))
260 (display "\n one=") (display one) (newline)
261 (define two (make-number 2))
262 (define pair2-nil (gc-cons two gc-nil))
263 (display "\npair2-nil=") (display pair2-nil) (newline)
264 (gc-show)
265
266 (define list1-2 (gc-cons one pair2-nil))
267 (display "\nlist1-2=") (display list1-2) (newline)
268 (gc-show)
269
270 (define three (make-number 3))
271 (define four (make-number 4))
272 (define pair4-nil (gc-cons four gc-nil))
273 (define list3-4 (gc-cons three pair4-nil))
274 (define list1234 (gc-cons list1-2 list3-4))
275 (gc-show)
276
277 (display "\nlist1-2=") (display list1-2) (newline)
278 (display "\nlist3-4=") (display list3-4) (newline)
279 (display "lst=") (display list1234) (newline)
280 (gc-show)
281
282 (display "sicp-lst:") (gc-display list1234) (newline)
283 (gc-show)
284
285 (display "\n**** trigger gc ****\n")
286 (define next (gc-list (make-symbol 'N) (make-symbol 'X)))
287 (set! list1234 '(p . 0))
288 (display "sicp-lst:") (gc-display list1234) (newline)
289 (gc-show)
290 (display "next=") (display next) (newline)
291 (display "gc-next=") (gc-display next) (newline)
292 (gc-show)