|
1 #lang racket/gui |
|
2 ;; Loader for images (version 1 format) from Russell Allen's 2015 |
|
3 ;; variant of SmallWorld, a Tim Budd-authored Little Smalltalk |
|
4 ;; descendant. |
|
5 |
|
6 (require racket/bytes) |
|
7 (require (only-in sha bytes->hex-string)) |
|
8 (require "object-memory.rkt") |
|
9 (require "primitives.rkt") |
|
10 |
|
11 (define-logger vm) |
|
12 (define-logger vm/jit) |
|
13 (define-logger vm/jit/code) |
|
14 (define-logger vm/jit/recompile) |
|
15 (define-logger vm/jit/recompile/candidates) |
|
16 |
|
17 ;; Runtime support: We use `eval` with namespace `ns` to allow |
|
18 ;; generated code to access bindings in this module. |
|
19 (define-namespace-anchor ns-anchor) |
|
20 (define ns (namespace-anchor->namespace ns-anchor)) |
|
21 |
|
22 ;;=========================================================================== |
|
23 ;; Structures |
|
24 |
|
25 (struct jit-VM VM (cache image-filename) |
|
26 #:methods gen:vm-callback |
|
27 [(define (vm-block-callback vm action) |
|
28 ;; Runs action in a new thread |
|
29 (lambda args |
|
30 (thread (match action |
|
31 [(unffiv block-proc) |
|
32 (lambda () (apply block-proc vm (outermost-k vm) args))] |
|
33 [_ |
|
34 (block->thunk vm action args)]))))]) |
|
35 |
|
36 (struct pic-info (name-bytes variable context extension) #:transparent) |
|
37 (struct compilation-result (litmap [pic-list-rev #:mutable] old-picmap)) |
|
38 (struct compilation (outer outer-ip vm receiver-class method argnames labels state)) |
|
39 |
|
40 (struct compiled-method-info (bytecode-method pics stable?)) |
|
41 |
|
42 (struct cached-method (class name-bytes [bytecode-method #:mutable] [proc #:mutable])) |
|
43 |
|
44 ;;=========================================================================== |
|
45 ;; Polymorphic Inline Caches - PICs |
|
46 |
|
47 (define pic-reserved 0) |
|
48 (define pic-entry-count 3) |
|
49 |
|
50 (define (pic) ;; pic-entry-count ×3 - class, method, and count. |
|
51 (vector #f #f 0 |
|
52 #f #f 0 |
|
53 #f #f 0)) |
|
54 (define (extended-pic c0 m0 c1 m1 c2 m2) ;; normal pic plus previous knowledge |
|
55 (vector #f #f 0 #f #f 0 #f #f 0 |
|
56 c0 m0 0 c1 m1 0 c2 m2 0)) |
|
57 |
|
58 (define (pic-size pic) (quotient (- (vector-length pic) pic-reserved) pic-entry-count)) |
|
59 (define (pic@ pic index offset) (vector-ref pic (+ pic-reserved offset (* index 3)))) |
|
60 (define (pic@! pic index offset v) (vector-set! pic (+ pic-reserved offset (* index 3)) v)) |
|
61 |
|
62 (define (pic-bump! pic index) |
|
63 (define o (+ pic-reserved 2 (* index 3))) |
|
64 (vector-set! pic o (+ 1 (vector-ref pic o)))) |
|
65 |
|
66 (define empty-pic-extension (for/list [(i (in-range pic-entry-count))] '(#f #f))) |
|
67 |
|
68 ;;=========================================================================== |
|
69 ;; Dynamic Deoptimization |
|
70 |
|
71 (define (build-jit-context vm previous-context args method ip temporaries stack) |
|
72 ;; TODO: build block contexts instead of just pretending everything is a method... |
|
73 (define max-stack (slotAt method 3)) |
|
74 (mkobj (VM-Context vm) |
|
75 method |
|
76 (obj (VM-Array vm) args) |
|
77 (obj (VM-Array vm) temporaries) |
|
78 (obj (VM-Array vm) (vector-append stack (make-vector (- max-stack (vector-length stack)) |
|
79 (VM-nil vm)))) |
|
80 ip |
|
81 (vector-length stack) |
|
82 previous-context)) |
|
83 |
|
84 ;;=========================================================================== |
|
85 ;; Method cache; relationship between bytecoded and compiled methods |
|
86 |
|
87 (define (lookup-method/cache vm class name-bytes) |
|
88 (define class-cache (hash-ref! (jit-VM-cache vm) class make-weak-hash)) |
|
89 (hash-ref! class-cache |
|
90 name-bytes |
|
91 (lambda () (cached-method class name-bytes #f #f)))) |
|
92 |
|
93 (define (bytecode->cached-compiled vm class method) |
|
94 (lookup-method/cache vm class (bv-bytes (slotAt method 0)))) |
|
95 |
|
96 (define (compiled->bytecode cmethod) |
|
97 (compiled-method-info-bytecode-method (cmethod))) |
|
98 |
|
99 (define (unwrap-cached-method vm cm) |
|
100 (or (cached-method-proc cm) |
|
101 (match cm |
|
102 [(cached-method class name-bytes _bcm _proc) |
|
103 (define bcm (lookup-method vm class name-bytes)) |
|
104 (define proc (and bcm (compile-method-proc vm class bcm #f))) |
|
105 (set-cached-method-bytecode-method! cm bcm) |
|
106 (set-cached-method-proc! cm proc) |
|
107 proc]))) |
|
108 |
|
109 (define (invalidate-cached-method! cm) |
|
110 (set-cached-method-bytecode-method! cm #f) |
|
111 (set-cached-method-proc! cm #f)) |
|
112 |
|
113 ;;=========================================================================== |
|
114 ;; Runtime method lookup via PIC |
|
115 |
|
116 (define (lookup-message/jit vm pic class selector) |
|
117 (let search-pic ((slot-index 0)) |
|
118 (define this-class (pic@ pic slot-index 0)) |
|
119 (if (eq? this-class class) |
|
120 (begin (pic-bump! pic slot-index) |
|
121 (or (unwrap-cached-method vm (pic@ pic slot-index 1)) |
|
122 (send-dnu class selector))) |
|
123 (let* ((next-slot-index (+ slot-index 1)) |
|
124 (more-slots-to-check? (and this-class (< next-slot-index pic-entry-count)))) |
|
125 (if more-slots-to-check? |
|
126 (search-pic next-slot-index) |
|
127 (let* ((cm (lookup-method/cache vm class (bv-bytes selector)))) |
|
128 (when (not this-class) |
|
129 (pic@! pic slot-index 0 class) |
|
130 (pic@! pic slot-index 1 cm) |
|
131 (pic@! pic slot-index 2 1)) |
|
132 (or (unwrap-cached-method vm cm) |
|
133 (send-dnu class selector)))))))) |
|
134 |
|
135 (define ((send-dnu class selector) vm ctx . args) |
|
136 (define arguments (obj (VM-Array vm) (list->vector args))) |
|
137 (define dnu-name-bytes #"doesNotUnderstand:") |
|
138 (match (unwrap-cached-method vm (lookup-method/cache vm class dnu-name-bytes)) |
|
139 [#f (error 'send-message* "Unhandled selector ~a at class ~a" selector class)] |
|
140 [dnu-method |
|
141 (log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector) |
|
142 (dnu-method vm ctx (slotAt arguments 0) (mkobj (VM-Array vm) selector arguments))])) |
|
143 |
|
144 ;;=========================================================================== |
|
145 ;; Compilation State |
|
146 |
|
147 (define (top-compilation vm receiver-class method old-picmap) |
|
148 (compilation* vm #f #f receiver-class method (compilation-result (make-hasheq) '() old-picmap))) |
|
149 |
|
150 (define (inline-compilation c c-ip receiver-class method) |
|
151 (compilation* (compilation-vm c) c c-ip receiver-class method (compilation-state c))) |
|
152 |
|
153 (define (compilation* vm outer outer-ip receiver-class method state) |
|
154 (define arity (selector-string-arity (method-name method))) |
|
155 (define literals (slotAt method 2)) |
|
156 |
|
157 (define litmap (compilation-result-litmap state)) |
|
158 (for [(lit (obj-slots literals))] (gen-lit* litmap lit)) |
|
159 |
|
160 (define argnames (for/vector [(i arity)] (if (zero? i) 'self (mksym "arg~a" (- i 1))))) |
|
161 |
|
162 (define c (compilation outer outer-ip vm receiver-class method argnames (make-hash) state)) |
|
163 (log-vm/jit/code-info "Compiling ~a defined in ~v (depth ~a)" |
|
164 (compilation-method-name c) |
|
165 (slotAt method 5) |
|
166 (compilation-depth c)) |
|
167 (log-vm/jit/code-info " bytecode: ~a\n----\n~a\n----" |
|
168 (bytes->hex-string (bv-bytes (slotAt method 1))) |
|
169 (bv->string (slotAt method 6))) |
|
170 c) |
|
171 |
|
172 (define (mksym fmt . args) (string->symbol (apply format fmt args))) |
|
173 |
|
174 (define (selector-string-arity str) |
|
175 (define colon-count (for/sum [(c str)] (if (eqv? c #\:) 1 0))) |
|
176 (cond [(positive? colon-count) (+ colon-count 1)] |
|
177 [(char-alphabetic? (string-ref str 0)) 1] |
|
178 [else 2])) ;; assume binary operator |
|
179 |
|
180 (define (compilation-method-name c) |
|
181 (method-name (compilation-method c) (compilation-receiver-class c))) |
|
182 |
|
183 (define (compilation-depth c) |
|
184 (define o (compilation-outer c)) |
|
185 (if o (+ 1 (compilation-depth o)) 0)) |
|
186 |
|
187 (define (already-compiling? c class method) |
|
188 (let check ((c c)) |
|
189 (cond [(not c) #f] |
|
190 [(and (eq? (compilation-receiver-class c) class) (eq? (compilation-method c) method)) #t] |
|
191 [else (check (compilation-outer c))]))) |
|
192 |
|
193 (define (gen-lit* litmap lit) |
|
194 (hash-ref! litmap lit (lambda () |
|
195 (define n (hash-count litmap)) |
|
196 (if (bv? lit) |
|
197 (mksym "lit~a-~a" n (bv->string lit)) |
|
198 (mksym "lit~a" n))))) |
|
199 |
|
200 (define (compilation-litname c literal) |
|
201 (hash-ref (compilation-result-litmap (compilation-state c)) literal)) |
|
202 |
|
203 (define (compilation-context c ip) |
|
204 (if (not c) |
|
205 '() |
|
206 (cons (list (compilation-receiver-class c) (compilation-method c) ip) |
|
207 (compilation-context (compilation-outer c) (compilation-outer-ip c))))) |
|
208 |
|
209 (define (format-compilation-context x) |
|
210 (string-join (reverse |
|
211 (map (match-lambda [(list c m ip) (format "~a @~a" (method-name m c) ip)]) x)) |
|
212 "," |
|
213 #:before-first "[" |
|
214 #:after-last "]")) |
|
215 |
|
216 ;;=========================================================================== |
|
217 ;; Compilation and code generation |
|
218 |
|
219 (define (compile-method-proc compile-time-vm class method old-picmap) |
|
220 (define c (top-compilation compile-time-vm class method old-picmap)) |
|
221 (define body-code (gen-jump-to-label c 0 '())) ;; imperative! |
|
222 (define pic-infos (reverse (compilation-result-pic-list-rev (compilation-state c)))) |
|
223 (define pic-infos-exp (gen-lit* (compilation-result-litmap (compilation-state c)) pic-infos)) |
|
224 (define stable? (equal? (if old-picmap (list->set (hash-keys old-picmap)) 'unknown) |
|
225 (list->set (map pic-info-context pic-infos)))) |
|
226 (when stable? |
|
227 (log-vm/jit/recompile-info "Compilation of ~a is now stable." (method-name method class))) |
|
228 (define inner-code |
|
229 `(let ((call-counter 0) |
|
230 (cmi #f)) |
|
231 (case-lambda |
|
232 [() |
|
233 (when (not cmi) |
|
234 (set! cmi |
|
235 (compiled-method-info |
|
236 method |
|
237 (for/list [(pi (in-list ,pic-infos-exp)) |
|
238 (pic (in-list (list ,@(map pic-info-variable pic-infos))))] |
|
239 (cons pi pic)) |
|
240 ,stable?))) |
|
241 cmi] |
|
242 [(vm k ,@(vector->list (compilation-argnames c))) |
|
243 (set! call-counter (+ call-counter 1)) |
|
244 ;; TODO: aging of call-counter by right-shifting at most once every few seconds, or so |
|
245 (when (= call-counter 1000) |
|
246 (log-vm/jit/recompile-debug "Method ~a is hot" ,(method-name method class)) |
|
247 (recompile-something vm (k)) |
|
248 ;; (set! call-counter 0) |
|
249 ) |
|
250 (let ((outer-k k) |
|
251 (temporaries ,(gen-fresh-temps method))) |
|
252 ,(gen-label-definitions c body-code))]))) |
|
253 (finish-compilation c compile-time-vm inner-code)) |
|
254 |
|
255 (define (compile-block-proc compile-time-vm |
|
256 method |
|
257 outer-args |
|
258 actual-temporaries |
|
259 argument-location |
|
260 initial-ip) |
|
261 (define class (obj-class* compile-time-vm (car outer-args))) |
|
262 (define c (top-compilation compile-time-vm class method #f)) |
|
263 (define body-code (gen-block c argument-location initial-ip)) ;; imperative! |
|
264 (define inner-code |
|
265 `(lambda (temporaries ,@(vector->list (compilation-argnames c))) |
|
266 (let ((outer-k (outermost-k vm))) |
|
267 ,(gen-label-definitions c body-code)))) |
|
268 (apply (finish-compilation c compile-time-vm inner-code) |
|
269 actual-temporaries |
|
270 outer-args)) |
|
271 |
|
272 (define (block->thunk vm block args) ;; Expects a real bytecode block, not an ffiv one |
|
273 (lambda () |
|
274 (define method (slotAt block 0)) |
|
275 (define outer-args (vector->list (obj-slots (slotAt block 1)))) |
|
276 (define temporaries (obj-slots (slotAt block 2))) |
|
277 (define argument-location (slotAt block 7)) |
|
278 (define block-ip (slotAt block 9)) |
|
279 (define f (compile-block-proc vm method outer-args temporaries argument-location block-ip)) |
|
280 (apply f vm (outermost-k vm) args))) |
|
281 |
|
282 (define (gen-build-jit-context c ip stack) |
|
283 `(build-jit-context vm |
|
284 (k) |
|
285 (vector ,@(vector->list (compilation-argnames c))) |
|
286 method |
|
287 ,ip |
|
288 temporaries |
|
289 (vector ,@(reverse stack)))) |
|
290 |
|
291 (define (gen-send-k c ip stack) |
|
292 (define result (gensym 'result)) |
|
293 `(case-lambda [() ,(gen-build-jit-context c ip stack)] |
|
294 [(,result) ,(gen-code c ip (cons result stack))])) |
|
295 |
|
296 (define (gen-fresh-temps method) |
|
297 (match (slotAt method 4) |
|
298 [0 `'#()] |
|
299 [temp-count `(make-vector ,temp-count NIL)])) |
|
300 |
|
301 (define (bytecode-exceeding? method limit) |
|
302 (define bytecode (bv-bytes (slotAt method 1))) |
|
303 (> (bytes-length bytecode) limit)) |
|
304 |
|
305 (define (gen-pic c name-bytes send-ip extension) |
|
306 (define old-pics (compilation-result-pic-list-rev (compilation-state c))) |
|
307 (define pic-index (length old-pics)) |
|
308 (define m (mksym "pic~a" pic-index)) |
|
309 (define pi (pic-info name-bytes m (compilation-context c send-ip) extension)) |
|
310 (set-compilation-result-pic-list-rev! (compilation-state c) (cons pi old-pics)) |
|
311 (log-vm/jit/recompile-debug "Produced pic at ip ~a for send of ~a in method ~a" |
|
312 send-ip |
|
313 name-bytes |
|
314 (compilation-method-name c)) |
|
315 m) |
|
316 |
|
317 ;; TODO: record dependency links properly, so that if a method is |
|
318 ;; changed, inlined copies of the old version of the method are |
|
319 ;; discarded. |
|
320 |
|
321 (define (gen-inline-send c c-ip class method k-exp arg-exps) |
|
322 (log-vm/jit/code-info "Inlining send of ~a into method ~a" |
|
323 (method-name method class) |
|
324 (compilation-method-name c)) |
|
325 (define ic (inline-compilation c c-ip class method)) |
|
326 (define body-code (gen-jump-to-label ic 0 '())) |
|
327 (define defining-class (slotAt method 5)) |
|
328 (define litmap (compilation-result-litmap (compilation-state ic))) |
|
329 (define inner-code |
|
330 `(let ((k ,k-exp) |
|
331 (method ,(gen-lit* litmap method)) |
|
332 (super ,(gen-lit* litmap (slotAt defining-class 1)))) |
|
333 (let ,(for/list [(formal (vector->list (compilation-argnames ic))) |
|
334 (actual (in-list arg-exps))] |
|
335 `(,formal ,actual)) |
|
336 (let ((outer-k k) |
|
337 (temporaries ,(gen-fresh-temps method))) |
|
338 ,(gen-label-definitions ic body-code))))) |
|
339 ;; (log-vm/jit/code-debug "INLINED:\n~a" (pretty-format inner-code)) |
|
340 inner-code) |
|
341 |
|
342 (define (analyse-pic c pic) |
|
343 (define vm (compilation-vm c)) |
|
344 (define unsorted (for/list [(i (in-range (pic-size pic))) #:when (pic@ pic i 0)] |
|
345 (list (pic@ pic i 2) (pic@ pic i 0) (pic@ pic i 1)))) |
|
346 (define descending-by-call-count (map cdr (sort unsorted > #:key car))) |
|
347 (for [(entry descending-by-call-count)] |
|
348 (unwrap-cached-method vm (cadr entry))) ;; fills cache entry |
|
349 descending-by-call-count) |
|
350 |
|
351 (define (gen-send c send-ip class-exp name-bytes selector-exp k-exp arg-exps) |
|
352 (define receiver-class (compilation-receiver-class c)) |
|
353 (define method (lookup-method (compilation-vm c) receiver-class name-bytes)) |
|
354 (cond |
|
355 [(and (equal? class-exp `(obj-class* vm self)) ;; self send |
|
356 (< (compilation-depth c) 2) |
|
357 method |
|
358 (not (bytecode-exceeding? method 32))) |
|
359 (gen-inline-send c send-ip receiver-class method k-exp arg-exps)] |
|
360 [else |
|
361 (define old-picmap (compilation-result-old-picmap (compilation-state c))) |
|
362 (define old-entry |
|
363 (and old-picmap (hash-ref old-picmap (compilation-context c send-ip) #f))) |
|
364 (define previous-pic-entries (if old-entry (analyse-pic c (cdr old-entry)) '())) |
|
365 (define litmap (compilation-result-litmap (compilation-state c))) |
|
366 (define pic-m (gen-pic c name-bytes send-ip previous-pic-entries)) |
|
367 `(let ((actual-class ,class-exp) |
|
368 (k-send ,k-exp)) |
|
369 ,(let loop ((predictions previous-pic-entries) (counter pic-entry-count)) |
|
370 (match predictions |
|
371 ['() |
|
372 `((lookup-message/jit vm ,pic-m actual-class ,selector-exp) vm k-send ,@arg-exps)] |
|
373 [(cons (list predicted-class predicted-cm) more-predictions) |
|
374 (define predicted-bmethod (cached-method-bytecode-method predicted-cm)) |
|
375 `(if (eq? actual-class ,(gen-lit* litmap predicted-class)) |
|
376 (begin |
|
377 (pic-bump! ,pic-m ,counter) |
|
378 ,(if (or (already-compiling? c predicted-class predicted-bmethod) |
|
379 (bytecode-exceeding? predicted-bmethod 40)) |
|
380 `((unwrap-cached-method vm ,(gen-lit* litmap predicted-cm)) |
|
381 vm k-send ,@arg-exps) |
|
382 (gen-inline-send c send-ip predicted-class predicted-bmethod 'k-send arg-exps))) |
|
383 ,(loop more-predictions (+ counter 1)))])))])) |
|
384 |
|
385 (define (gen-block c argument-location ip) |
|
386 (define temp-count (slotAt (compilation-method c) 4)) |
|
387 `(lambda (vm k . block-arguments) |
|
388 ,(let loop ((i argument-location)) |
|
389 (if (>= i temp-count) |
|
390 `(void) |
|
391 `(when (pair? block-arguments) |
|
392 (vector-set! temporaries ,i (car block-arguments)) |
|
393 (let ((block-arguments (cdr block-arguments))) |
|
394 ,(loop (+ i 1)))))) |
|
395 ,(gen-code c ip '()))) |
|
396 |
|
397 (define-syntax let@ |
|
398 (syntax-rules () |
|
399 [(_ [n n-code-exp] body-code-exp) |
|
400 (let@ [n 'n n-code-exp] body-code-exp)] |
|
401 [(_ [n n-exp n-code-exp] body-code-exp) |
|
402 (let ((n (gensym n-exp))) |
|
403 `(let ((,n ,n-code-exp)) |
|
404 ,body-code-exp))])) |
|
405 |
|
406 (define (gen-code c ip stack) |
|
407 (define method (compilation-method c)) |
|
408 (define bytecode (bv-bytes (slotAt method 1))) |
|
409 (define literals (slotAt method 2)) |
|
410 (let translate ((ip ip) (stack stack)) |
|
411 (define (next-byte!) |
|
412 (begin0 (bytes-ref bytecode ip) |
|
413 (set! ip (+ ip 1)))) |
|
414 (define (decode!) |
|
415 (define byte (next-byte!)) |
|
416 (define low (bitwise-and byte #x0f)) |
|
417 (define high (bitwise-and (arithmetic-shift byte -4) #x0f)) |
|
418 (if (zero? high) |
|
419 (values low (next-byte!)) |
|
420 (values high low))) |
|
421 (define ip0 ip) |
|
422 (define-values (opcode arg) (decode!)) |
|
423 (log-vm/jit-debug " ~a: ~a ~a" ip0 opcode arg) |
|
424 (match opcode |
|
425 [1 (let@ [n (mksym "slot~a_" arg) `(slotAt self ,arg)] |
|
426 (translate ip (cons n stack)))] |
|
427 [2 (translate ip (cons (vector-ref (compilation-argnames c) arg) stack))] |
|
428 [3 (let@ [n (mksym "tmp~a_" arg) `(vector-ref temporaries ,arg)] |
|
429 (translate ip (cons n stack)))] |
|
430 [4 (let ((name (compilation-litname c (slotAt literals arg)))) |
|
431 (translate ip (cons name stack)))] |
|
432 [5 (match arg |
|
433 [(or 0 1 2 3 4 5 6 7 8 9) (translate ip (cons arg stack))] |
|
434 [10 (translate ip (cons `NIL stack))] |
|
435 [11 (translate ip (cons `TRUE stack))] |
|
436 [12 (translate ip (cons `FALSE stack))])] |
|
437 [6 `(begin (slotAtPut self ,arg ,(car stack)) ,(translate ip stack))] |
|
438 [7 `(begin (vector-set! temporaries ,arg ,(car stack)) ,(translate ip stack))] |
|
439 [8 (let* ((arg-count arg) |
|
440 (args (reverse (take stack arg-count))) |
|
441 (stack (drop stack arg-count))) |
|
442 (define-values (selector-literal-index class-exp) |
|
443 (match/values (decode!) |
|
444 [(9 selector-literal-index) |
|
445 (values selector-literal-index `(obj-class* vm ,(car args)))] |
|
446 [(15 11) |
|
447 (values (next-byte!) `super)])) |
|
448 (define k (gen-send-k c ip stack)) |
|
449 (define selector (slotAt literals selector-literal-index)) |
|
450 (define selector-exp (compilation-litname c selector)) |
|
451 (gen-send c ip0 class-exp (bv-bytes selector) selector-exp k args))] |
|
452 ;; 9 inlined in the processing of bytecode 8 |
|
453 [10 (match arg |
|
454 [0 (let@ [isNil `(boolean->obj vm (eq? NIL ,(car stack)))] |
|
455 (translate ip (cons isNil (cdr stack))))] |
|
456 [1 (let@ [notNil `(boolean->obj vm (not (eq? NIL ,(car stack))))] |
|
457 (translate ip (cons notNil (cdr stack))))])] |
|
458 [11 (match stack |
|
459 [(list* j i stack) |
|
460 ;; TODO: Remove special-casing of these sends. REQUIRES |
|
461 ;; IMAGE CHANGES, particularly in `addToSmallInt:`. |
|
462 (let@ [binop-k (gen-send-k c ip stack)] |
|
463 `(if (and (number? ,i) (number? ,j)) |
|
464 ,(match arg |
|
465 [0 `(,binop-k (boolean->obj vm (< ,i ,j)))] |
|
466 [1 `(,binop-k (boolean->obj vm (<= ,i ,j)))] |
|
467 [2 `(,binop-k (+ ,i ,j))]) |
|
468 ,(let ((name-bytes (match arg [0 #"<"] [1 #"<="] [2 #"+"]))) |
|
469 (gen-send c |
|
470 ip0 |
|
471 `(obj-class* vm ,i) |
|
472 name-bytes |
|
473 `(mkbv NIL ,name-bytes) |
|
474 binop-k |
|
475 (list i j)))))])] |
|
476 [12 (let ((target (next-byte!))) |
|
477 (let@ [block `(mkffiv BLOCK ,(gen-block c arg ip))] |
|
478 (translate target (cons block stack))))] |
|
479 [13 (define primitive-number (next-byte!)) |
|
480 (match primitive-number |
|
481 [8 (let ((v (gensym 'blockresult)) |
|
482 (block (car stack)) |
|
483 (argc (- arg 1)) |
|
484 (stack (cdr stack))) |
|
485 `(match ,block |
|
486 [(unffiv block-proc) |
|
487 (block-proc vm |
|
488 ;; TODO vvv : use case-lambda to translate the context chain |
|
489 k ;; not (lambda (,v) ,(translate ip (cons v (drop stack argc)))) |
|
490 ;; ^ reason being the image BUGGILY (?!?) relies on primitive 8 |
|
491 ;; immediately returning to the surrounding context!! |
|
492 ,@(reverse (take stack argc)))] |
|
493 [(obj (== BLOCK) _) |
|
494 (k ((block->thunk vm ,block (list ,@(reverse (take stack argc))))))]))] |
|
495 [34 'NIL] |
|
496 [35 (let@ [ctxref (gen-build-jit-context c ip stack)] |
|
497 (translate ip (cons ctxref stack)))] |
|
498 [36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))] |
|
499 (translate ip (cons arr (drop stack arg))))] |
|
500 [_ (let ((generator (hash-ref *primitive-code-snippets* |
|
501 primitive-number |
|
502 (lambda () (error 'gen-code |
|
503 "Unknown primitive: ~a" |
|
504 primitive-number))))) |
|
505 (let@ [primresult (generator 'vm (reverse (take stack arg)))] |
|
506 (translate ip (cons primresult (drop stack arg)))))])] |
|
507 [14 (let@ [clsvar `(slotAt (obj-class* vm self) ,(+ arg 5))] |
|
508 (translate ip (cons clsvar stack)))] |
|
509 [15 (match arg |
|
510 [1 `(k self)] |
|
511 [2 `(k ,(car stack))] |
|
512 [3 `(outer-k ,(car stack))] |
|
513 [5 (translate ip (cdr stack))] |
|
514 [6 (gen-jump-to-label c (next-byte!) stack)] |
|
515 [7 (let ((target (next-byte!))) |
|
516 (log-vm/jit-debug "if ~a true jump to ~a, else continue at ~a" (car stack) target ip) |
|
517 `(if (eq? ,(car stack) TRUE) |
|
518 ,(gen-jump-to-label c target (cdr stack)) |
|
519 ,(gen-jump-to-label c ip (cdr stack))))] |
|
520 [8 (let ((target (next-byte!))) |
|
521 (log-vm/jit-debug "if ~a false jump to ~a, else continue at ~a" (car stack) target ip) |
|
522 `(if (eq? ,(car stack) FALSE) |
|
523 ,(gen-jump-to-label c target (cdr stack)) |
|
524 ,(gen-jump-to-label c ip (cdr stack))))] |
|
525 ;; 11 inlined in the processing of bytecode 8 |
|
526 [_ (error 'gen-code "Unhandled do-special case ~v" arg)])] |
|
527 [_ (error 'gen-code "Method ~v - unhandled opcode ~v, arg ~v" |
|
528 (slotAt (compilation-method c) 0) ;; selector |
|
529 opcode |
|
530 arg)]))) |
|
531 |
|
532 (define (gen-jump-to-label c ip stack) |
|
533 (define labels (compilation-labels c)) |
|
534 (when (not (hash-has-key? labels ip)) |
|
535 (hash-set! labels ip 'placeholder) |
|
536 (define actual-label |
|
537 (let ((newstack (for/list [(i (length stack))] (mksym "stack~a" i)))) |
|
538 `(lambda (k ,@newstack) ,(gen-code c ip newstack)))) |
|
539 (hash-set! labels ip actual-label)) |
|
540 `(,(mksym "label~a" ip) k ,@stack)) |
|
541 |
|
542 (define (gen-label-definitions c body-exp) |
|
543 `(letrec (,@(for/list [((ip label) (in-hash (compilation-labels c)))] |
|
544 `(,(mksym "label~a" ip) ,label))) |
|
545 ,body-exp)) |
|
546 |
|
547 (define (finish-compilation c compile-time-vm inner-code) |
|
548 (define litmap (compilation-result-litmap (compilation-state c))) |
|
549 (define pic-definitions |
|
550 (for/list [(pi (reverse (compilation-result-pic-list-rev (compilation-state c))))] |
|
551 (define extension (pic-info-extension pi)) |
|
552 `(define ,(pic-info-variable pi) |
|
553 ,(if (null? extension) |
|
554 `(pic) |
|
555 `(extended-pic |
|
556 ,@(append-map (lambda (entry) |
|
557 (list (and (car entry) (gen-lit* litmap (car entry))) |
|
558 (and (cadr entry) (gen-lit* litmap (cadr entry))))) |
|
559 (take (append extension empty-pic-extension) pic-entry-count))))))) |
|
560 (define litmap-list (hash->list litmap)) |
|
561 (define code |
|
562 `(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(map cdr litmap-list)) |
|
563 ,@pic-definitions |
|
564 ,inner-code)) |
|
565 |
|
566 (log-vm/jit/code-debug "Resulting code for ~a:\n~a" |
|
567 (compilation-method-name c) |
|
568 (pretty-format code)) |
|
569 (define literals (slotAt (compilation-method c) 2)) |
|
570 (define defining-class (slotAt (compilation-method c) 5)) |
|
571 (apply (eval code ns) |
|
572 (compilation-method c) |
|
573 (slotAt defining-class 1) ;; defining class's superclass |
|
574 (VM-nil compile-time-vm) ;; assuming this VM is the one that will be used at call time! |
|
575 (VM-true compile-time-vm) |
|
576 (VM-false compile-time-vm) |
|
577 (VM-Array compile-time-vm) |
|
578 (VM-Block compile-time-vm) |
|
579 (map car litmap-list))) |
|
580 |
|
581 (define (outermost-k vm) |
|
582 (case-lambda [() (VM-nil vm)] |
|
583 [(result) result])) |
|
584 |
|
585 ;;=========================================================================== |
|
586 ;; Recompilation |
|
587 |
|
588 (define (recompilation-candidate vm ctx) |
|
589 (let search ((ctx ctx) (candidate #f) (candidate-class #f) (candidate-hotness 0)) |
|
590 (cond |
|
591 [(eq? (VM-nil vm) ctx) (values candidate candidate-class)] |
|
592 [else (define method (slotAt ctx 0)) |
|
593 (define receiver (slotAt (slotAt ctx 1) 0)) |
|
594 (define receiver-class (obj-class* vm receiver)) |
|
595 (define next-ctx (slotAt ctx 6)) |
|
596 (log-vm/jit/recompile/candidates-debug " ~a" (method-name method receiver-class)) |
|
597 (define cached-method (bytecode->cached-compiled vm receiver-class method)) |
|
598 (define compiled-method (unwrap-cached-method vm cached-method)) |
|
599 (cond |
|
600 [(not compiled-method) (search next-ctx candidate candidate-class candidate-hotness)] |
|
601 [else |
|
602 (match-define (compiled-method-info (== method eq?) pics stable?) (compiled-method)) |
|
603 (log-vm/jit/recompile/candidates-debug " has ~a bytes of bytecode; ~a" |
|
604 (bytes-length (bv-bytes (slotAt method 1))) |
|
605 (if stable? "stable" "not yet stable")) |
|
606 (define hotness |
|
607 (for/sum [(entry pics)] |
|
608 (match-define (cons pi pic) entry) |
|
609 (for/sum [(i (in-range (pic-size pic)))] |
|
610 (match (pic@ pic i 0) |
|
611 [#f 0] |
|
612 [slot-class |
|
613 (define slot-cm (pic@ pic i 1)) |
|
614 (unwrap-cached-method vm slot-cm) ;; fills cache entry |
|
615 (define slot-bmethod (cached-method-bytecode-method slot-cm)) |
|
616 (define slot-count (pic@ pic i 2)) |
|
617 (define bytecode-count (bytes-length (bv-bytes (slotAt slot-bmethod 1)))) |
|
618 (define weight (/ 40.0 bytecode-count)) |
|
619 (log-vm/jit/recompile/candidates-debug |
|
620 " ~a context ~a class ~a count ~a length ~a weight ~a" |
|
621 (pic-info-name-bytes pi) |
|
622 (pic-info-context pi) |
|
623 (bv->string (slotAt slot-class 0)) |
|
624 slot-count |
|
625 bytecode-count |
|
626 weight) |
|
627 (if (< weight 1) |
|
628 0 |
|
629 (* slot-count weight))])))) |
|
630 (log-vm/jit/recompile/candidates-debug " hotness: ~a" hotness) |
|
631 (if (and (> hotness candidate-hotness) (not stable?)) |
|
632 (search next-ctx method receiver-class hotness) |
|
633 (search next-ctx candidate candidate-class candidate-hotness))])]))) |
|
634 |
|
635 (define (recompile-method! vm class method) |
|
636 (log-vm/jit/recompile-info "Recompiling ~a" (method-name method class)) |
|
637 (define cached-method (bytecode->cached-compiled vm class method)) |
|
638 (define old-proc (cached-method-proc cached-method)) |
|
639 (define old-picmap |
|
640 (for/hash [(entry (in-list (if old-proc (compiled-method-info-pics (old-proc)) '())))] |
|
641 (define pi (car entry)) |
|
642 (values (pic-info-context pi) entry))) |
|
643 (when (not (hash-empty? old-picmap)) |
|
644 (log-vm/jit/recompile-info "Retrieved old pics for method ~a" (method-name method class)) |
|
645 (for [((i p) (in-hash old-picmap))] |
|
646 (log-vm/jit/recompile-info " ~a --> ~v" (format-compilation-context i) p))) |
|
647 (define recompiled-proc (compile-method-proc vm class method old-picmap)) |
|
648 (log-vm/jit/recompile-info "Updating cached compiled method for ~a" (method-name method class)) |
|
649 (set-cached-method-proc! cached-method recompiled-proc)) |
|
650 |
|
651 (define (recompile-something vm ctx) |
|
652 (define-values (candidate candidate-class) (recompilation-candidate vm ctx)) |
|
653 (if candidate |
|
654 (recompile-method! vm candidate-class candidate) |
|
655 (log-vm/jit/recompile-debug "No recompilation candidate available?"))) |
|
656 |
|
657 ;;=========================================================================== |
|
658 ;; VM-specific primitives (aside from the core primitives found in `gen-code`) |
|
659 |
|
660 (define-primitive vm [6 inner-ctx] ;; "new context execute" |
|
661 (when (not (zero? (slotAt inner-ctx 5))) (error 'execute "Cannot execute from nonempty stack")) |
|
662 (when (not (zero? (slotAt inner-ctx 4))) (error 'execute "Cannot execute from nonzero IP")) |
|
663 (define args (slotAt inner-ctx 1)) |
|
664 (define f (compile-method-proc vm (obj-class* vm (slotAt args 0)) (slotAt inner-ctx 0) #f)) |
|
665 (apply f vm (outermost-k vm) (vector->list (obj-slots args)))) |
|
666 |
|
667 (define-primitive vm [116] |
|
668 (let ((image-bytes (serialize-image vm))) |
|
669 (display-to-file image-bytes (jit-VM-image-filename vm) #:exists 'replace))) |
|
670 |
|
671 ;;=========================================================================== |
|
672 ;; Entry point |
|
673 |
|
674 (pretty-print-columns 230) |
|
675 (let* ((image-filename "SmallWorld/src/image") |
|
676 (vm (call-with-input-file image-filename |
|
677 (lambda (fh) |
|
678 (read-image fh jit-VM (list (make-weak-hasheq) image-filename)))))) |
|
679 (boot-image vm |
|
680 (lambda (vm source) |
|
681 (define compiled-method |
|
682 (unwrap-cached-method vm (lookup-method/cache vm (obj-class source) #"doIt"))) |
|
683 (compiled-method vm (outermost-k vm) source)) |
|
684 (current-command-line-arguments))) |