smalltalk-tng
view r1/image.scm @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | |
| children |
line source
1 (define (serialize-image!)
2 (define seen (make-hash-table eq?))
3 (define counter 0)
5 (define (lookup o)
6 (hash-table-ref seen o))
8 (define (store! o)
9 (let ((ref counter))
10 (set! counter (+ counter 1))
11 (hash-table-set! seen o ref)
12 ref))
14 (define (reference o walker)
15 (cond
16 ((lookup o))
17 (else (let ((ref (store! o)))
18 (vector ref (walker o))))))
20 (define (walk-primitive o)
21 o)
23 (define (walk o)
24 (cond
25 ((object? o) (reference o walk-object))
27 ((or (number? o)
28 (char? o)
29 (symbol? o)
30 (string? o)
31 (boolean? o)
32 (null? o))
33 (reference o walk-primitive))
35 ((pair? o) (reference o walk-pair))
36 ((vector? o) (reference o walk-vector))
38 (else
39 (if (not (procedure? o))
40 (debug 1 "Pinching off primitive reference: "o))
41 (reference '() walk-primitive))))
43 (define (walk-pair o)
44 (let* ((a (walk (car o)))
45 (d (walk (cdr o))))
46 (cons a d)))
48 (define (walk-vector o)
49 (list->vector (cons 'v (map-in-order walk (vector->list o)))))
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)))
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)))
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))))
78 (define (walk-role role)
79 (list (bitset->list (role-positions role))
80 (bitset->list (role-requirements role))
81 (walk (role-method role))))
83 (store-globals-to-image!)
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 )
100 ;---------------------------------------------------------------------------
102 (define (deserialize-image! image)
103 (define seen (make-hash-table eq?))
104 (define fixups '())
106 (define (lookup x)
107 (or (hash-table-ref seen x)
108 (error "Image format error: out-of-order reference" x)))
110 (define (store! n shell fixup)
111 (hash-table-set! seen n shell)
112 (fixup shell)
113 shell)
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))))))
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)))))))
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))))
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)))
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))))))))
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))))
188 (set! *image-root* (make-hash-table eq?))
189 (flush-literal-objects-table!)
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))
206 (run-hooks! fixups)
207 (debug 1 "Done.")
209 (load-globals-from-image!)
210 )