|
1 (define (serialize-image!) |
|
2 (define seen (make-hash-table eq?)) |
|
3 (define counter 0) |
|
4 |
|
5 (define (lookup o) |
|
6 (hash-table-ref seen o)) |
|
7 |
|
8 (define (store! o) |
|
9 (let ((ref counter)) |
|
10 (set! counter (+ counter 1)) |
|
11 (hash-table-set! seen o ref) |
|
12 ref)) |
|
13 |
|
14 (define (reference o walker) |
|
15 (cond |
|
16 ((lookup o)) |
|
17 (else (let ((ref (store! o))) |
|
18 (vector ref (walker o)))))) |
|
19 |
|
20 (define (walk-primitive o) |
|
21 o) |
|
22 |
|
23 (define (walk o) |
|
24 (cond |
|
25 ((object? o) (reference o walk-object)) |
|
26 |
|
27 ((or (number? o) |
|
28 (char? o) |
|
29 (symbol? o) |
|
30 (string? o) |
|
31 (boolean? o) |
|
32 (null? o)) |
|
33 (reference o walk-primitive)) |
|
34 |
|
35 ((pair? o) (reference o walk-pair)) |
|
36 ((vector? o) (reference o walk-vector)) |
|
37 |
|
38 (else |
|
39 (if (not (procedure? o)) |
|
40 (debug 1 "Pinching off primitive reference: "o)) |
|
41 (reference '() walk-primitive)))) |
|
42 |
|
43 (define (walk-pair o) |
|
44 (let* ((a (walk (car o))) |
|
45 (d (walk (cdr o)))) |
|
46 (cons a d))) |
|
47 |
|
48 (define (walk-vector o) |
|
49 (list->vector (cons 'v (map-in-order walk (vector->list o))))) |
|
50 |
|
51 (define (walk-object o) |
|
52 (let* ((layout (reference (object-layout o) walk-layout)) |
|
53 (slots (map-in-order walk (vector->list (object-slots o)))) |
|
54 (category (cond |
|
55 ((and (has-slot? o 'traits) |
|
56 (eq? (get-slot o 'traits) *traits-method*)) |
|
57 (cond |
|
58 ((not (eq? (get-slot o 'primitive) *nil*)) 'p) |
|
59 ((not (eq? (get-slot o 'accessor) *nil*)) 'a) |
|
60 (else 'o))) |
|
61 (else 'o)))) |
|
62 (vector category layout slots))) |
|
63 |
|
64 (define (walk-layout layout) |
|
65 (let ((answer '())) |
|
66 (layout-for-each layout |
|
67 (lambda (slot-name slot) |
|
68 (push! answer (reference slot walk-slot)))) |
|
69 (reverse answer))) |
|
70 |
|
71 (define (walk-slot slot) |
|
72 (list (slot-name slot) |
|
73 (slot-index slot) |
|
74 (slot-delegating? slot) |
|
75 (slot-kind slot) |
|
76 (map-in-order walk-role (slot-roles slot)))) |
|
77 |
|
78 (define (walk-role role) |
|
79 (list (bitset->list (role-positions role)) |
|
80 (bitset->list (role-requirements role)) |
|
81 (walk (role-method role)))) |
|
82 |
|
83 (store-globals-to-image!) |
|
84 |
|
85 (let ((literals '()) |
|
86 (roots (map-in-order (lambda (entry) |
|
87 (cons (car entry) |
|
88 (walk (cdr entry)))) |
|
89 (hash-table->list *image-root*)))) |
|
90 (for-each-literal-object (lambda (literal object) |
|
91 (when (or (lookup literal) |
|
92 (assq literal *root-literals*)) |
|
93 (let* ((l (walk literal)) |
|
94 (o (walk object))) |
|
95 (push! literals (cons l o)))))) |
|
96 (cons roots |
|
97 (reverse literals))) |
|
98 ) |
|
99 |
|
100 ;--------------------------------------------------------------------------- |
|
101 |
|
102 (define (deserialize-image! image) |
|
103 (define seen (make-hash-table eq?)) |
|
104 (define fixups '()) |
|
105 |
|
106 (define (lookup x) |
|
107 (or (hash-table-ref seen x) |
|
108 (error "Image format error: out-of-order reference" x))) |
|
109 |
|
110 (define (store! n shell fixup) |
|
111 (hash-table-set! seen n shell) |
|
112 (fixup shell) |
|
113 shell) |
|
114 |
|
115 (define (dereference x loader) |
|
116 (cond |
|
117 ((number? x) |
|
118 (lookup x)) |
|
119 ((not (vector? x)) (error "Image format error: bad definition" x)) |
|
120 (else (loader (vector-ref x 1) |
|
121 (lambda (shell fixup) |
|
122 (store! (vector-ref x 0) |
|
123 shell |
|
124 fixup)))))) |
|
125 |
|
126 (define (load x) |
|
127 (dereference x |
|
128 (lambda (y k) |
|
129 (cond |
|
130 ((vector? y) |
|
131 (case (vector-ref y 0) |
|
132 ((o p a) (k (make-object* #f #f) |
|
133 (make-object-fixup (vector-ref y 0) |
|
134 (vector-ref y 1) |
|
135 (vector-ref y 2)))) |
|
136 ((v) (k (make-vector (- (vector-length y) 1)) |
|
137 (lambda (shell) |
|
138 (do ((i 0 (+ i 1))) |
|
139 ((= i (vector-length shell))) |
|
140 (vector-set! shell i |
|
141 (load (vector-ref y (+ i 1)))))))) |
|
142 (else (error "Image format error: illegal compound" y)))) |
|
143 ((pair? y) (k (cons #f #f) |
|
144 (lambda (shell) |
|
145 (set-car! shell (load (car y))) |
|
146 (set-cdr! shell (load (cdr y)))))) |
|
147 (else (k y (lambda (shell) shell))))))) |
|
148 |
|
149 (define (make-object-fixup category layout slots) |
|
150 (lambda (shell) |
|
151 (set-object-layout! shell (dereference layout load-layout)) |
|
152 (set-object-slots! shell (list->vector (map-in-order load slots))) |
|
153 (case category |
|
154 ((p) (push! fixups |
|
155 (lambda () |
|
156 (set-slot! shell 'code (lookup-primitive (get-slot shell 'primitive)))))) |
|
157 ((a) (push! fixups |
|
158 (lambda () |
|
159 (set-slot! shell 'code |
|
160 (let ((name (get-slot shell 'accessor))) |
|
161 (if (eq? (get-slot shell 'selector) name) |
|
162 (build-getter-body name) |
|
163 (build-setter-body name))))))) |
|
164 (else 'pass)))) |
|
165 |
|
166 (define (load-layout x k) |
|
167 (k (make-layout*) |
|
168 (lambda (layout) |
|
169 (for-each (lambda (slot) |
|
170 (layout-set! layout (slot-name slot) slot)) |
|
171 (map-in-order load-slot x)) |
|
172 layout))) |
|
173 |
|
174 (define (load-slot x) |
|
175 (dereference x |
|
176 (lambda (y k) |
|
177 (let*-structure (((name index delegating? kind roles) y)) |
|
178 (k (make-slot* name index #f delegating? kind) |
|
179 (lambda (shell) |
|
180 (set-slot-roles! shell (map-in-order load-role roles)))))))) |
|
181 |
|
182 (define (load-role x) |
|
183 (let*-structure (((positions requirements method) x)) |
|
184 (make-role* (list->bitset positions) |
|
185 (list->bitset requirements) |
|
186 (load method)))) |
|
187 |
|
188 (set! *image-root* (make-hash-table eq?)) |
|
189 (flush-literal-objects-table!) |
|
190 |
|
191 (let ((roots (car image)) |
|
192 (literals (cdr image))) |
|
193 (for-each (lambda (entry) |
|
194 (debug 1 "--- ROOT "(car entry)) |
|
195 (hash-table-set! *image-root* |
|
196 (car entry) |
|
197 (load (cdr entry)))) |
|
198 roots) |
|
199 (for-each (lambda (entry) |
|
200 (debug 1 "--- LITERAL "entry) |
|
201 (let ((literal (load (car entry))) |
|
202 (object (load (cdr entry)))) |
|
203 (install-object-for-literal! literal object))) |
|
204 literals)) |
|
205 |
|
206 (run-hooks! fixups) |
|
207 (debug 1 "Done.") |
|
208 |
|
209 (load-globals-from-image!) |
|
210 ) |