author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Sun, 22 Jul 2018 15:00:05 +0100 | |
changeset 411 | ba74f97d2ba9 |
parent 410 | 7e5d9e957c2f |
child 413 | 99a706eaf2cf |
permissions | -rw-r--r-- |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1 |
#lang racket/gui |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
2 |
;; Loader for images (version 1 format) from Russell Allen's 2015 |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
3 |
;; variant of SmallWorld, a Tim Budd-authored Little Smalltalk |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
4 |
;; descendant. |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
5 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
6 |
(require racket/bytes) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
7 |
(require (only-in sha bytes->hex-string)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
8 |
(require "object-memory.rkt") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
9 |
(require "primitives.rkt") |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
10 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
11 |
(define-logger vm) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
12 |
(define-logger vm/jit) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
13 |
(define-logger vm/jit/code) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
14 |
(define-logger vm/jit/recompile) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
15 |
|
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
16 |
(define pic-entry-count 3) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
17 |
(define (pic name-bytes send-ip) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
18 |
;; pic-entry-count times three - one each for class, method, and |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
19 |
;; count - plus two, name-bytes and send-ip. |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
20 |
(vector name-bytes send-ip |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
21 |
#f #f 0 |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
22 |
#f #f 0 |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
23 |
#f #f 0)) |
395
3979401d44c1
Introduce struct mic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
394
diff
changeset
|
24 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
25 |
(struct jit-VM VM (cache image-filename) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
26 |
#:methods gen:vm-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
27 |
[(define (vm-block-callback vm action) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
28 |
;; Runs action in a new thread |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
29 |
(lambda args |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
30 |
(thread (match action |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
31 |
[(unffiv block-proc) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
32 |
(lambda () (apply block-proc vm (outermost-k vm) args))] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
33 |
[_ |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
34 |
(block->thunk vm action args)]))))]) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
35 |
|
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
36 |
(struct pic-info (name-bytes variable ip)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
37 |
(struct compilation-result (litmap [pic-list-rev #:mutable])) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
38 |
(struct compilation (depth vm receiver-class method argnames labels state)) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
39 |
|
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
40 |
(struct compiled-method-info (bytecode-method pics)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
41 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
42 |
(define (build-jit-context vm previous-context args method ip stack-top temporaries stack) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
43 |
(define max-stack (slotAt method 3)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
44 |
(mkobj (VM-Context vm) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
45 |
method |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
46 |
(obj (VM-Array vm) args) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
47 |
(obj (VM-Array vm) temporaries) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
48 |
(obj (VM-Array vm) (vector-append stack (make-vector (- max-stack (vector-length stack)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
49 |
(VM-nil vm)))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
50 |
ip |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
51 |
stack-top |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
52 |
previous-context)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
53 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
54 |
(define (selector-string-arity str) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
55 |
(define colon-count (for/sum [(c str)] (if (eqv? c #\:) 1 0))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
56 |
(cond [(positive? colon-count) (+ colon-count 1)] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
57 |
[(char-alphabetic? (string-ref str 0)) 1] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
58 |
[else 2])) ;; assume binary operator |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
59 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
60 |
(define-namespace-anchor ns-anchor) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
61 |
(define ns (namespace-anchor->namespace ns-anchor)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
62 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
63 |
(define (mksym fmt . args) (string->symbol (apply format fmt args))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
64 |
|
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
65 |
(define-syntax let@ |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
66 |
(syntax-rules () |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
67 |
[(_ [n n-code-exp] body-code-exp) |
406
3a84d16cac19
Remove gratuitous layer of gensym
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
405
diff
changeset
|
68 |
(let@ [n 'n n-code-exp] body-code-exp)] |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
69 |
[(_ [n n-exp n-code-exp] body-code-exp) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
70 |
(let ((n (gensym n-exp))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
71 |
`(let ((,n ,n-code-exp)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
72 |
,body-code-exp))])) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
73 |
|
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
74 |
(define (compilation* depth compile-time-vm receiver-class method state) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
75 |
(define selector (slotAt method 0)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
76 |
(define arity (selector-string-arity (bv->string selector))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
77 |
(define literals (slotAt method 2)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
78 |
|
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
79 |
(log-vm/jit/code-info |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
80 |
"Compiling ~v defined in ~v, to be run in ~v (depth ~a), arity ~a, literals ~a, bytecode ~a, text:\n----\n~a\n----" |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
81 |
(bv->string selector) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
82 |
(slotAt method 5) |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
83 |
receiver-class |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
84 |
depth |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
85 |
arity |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
86 |
literals |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
87 |
(bytes->hex-string (bv-bytes (slotAt method 1))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
88 |
(bv->string (slotAt method 6))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
89 |
|
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
90 |
(define litmap (compilation-result-litmap state)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
91 |
(for [(lit (obj-slots literals))] (gen-lit* litmap lit)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
92 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
93 |
(define argnames (for/vector [(i arity)] (if (zero? i) 'self (mksym "arg~a" (- i 1))))) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
94 |
(compilation depth |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
95 |
compile-time-vm |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
96 |
receiver-class |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
97 |
method |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
98 |
argnames |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
99 |
(make-hash) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
100 |
state)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
101 |
|
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
102 |
(define (top-compilation vm receiver-class method) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
103 |
(compilation* 0 vm receiver-class method (compilation-result (make-hasheq) '()))) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
104 |
|
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
105 |
(define (inline-compilation c method) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
106 |
(match-define (compilation depth vm receiver-class _method _argnames _labels state) c) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
107 |
(compilation* (+ depth 1) vm receiver-class method state)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
108 |
|
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
109 |
(define (gen-lit* litmap lit) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
110 |
(hash-ref! litmap lit (lambda () |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
111 |
(define n (hash-count litmap)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
112 |
(if (bv? lit) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
113 |
(mksym "lit~a-~a" n (bv->string lit)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
114 |
(mksym "lit~a" n))))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
115 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
116 |
(define (gen-jump-to-label c ip stack) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
117 |
(define labels (compilation-labels c)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
118 |
(when (not (hash-has-key? labels ip)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
119 |
(hash-set! labels ip 'placeholder) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
120 |
(define actual-label |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
121 |
(let ((newstack (for/list [(i (length stack))] (mksym "stack~a" i)))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
122 |
`(lambda (k ,@newstack) ,(gen-code c ip newstack)))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
123 |
(hash-set! labels ip actual-label)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
124 |
`(,(mksym "label~a" ip) k ,@stack)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
125 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
126 |
(define (gen-build-jit-context c ip stack) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
127 |
`(build-jit-context vm |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
128 |
(k) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
129 |
(vector ,@(vector->list (compilation-argnames c))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
130 |
method |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
131 |
,ip |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
132 |
,(length stack) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
133 |
temporaries |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
134 |
(vector ,@(reverse stack)))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
135 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
136 |
(define (gen-send-k c ip stack) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
137 |
(define result (gensym 'result)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
138 |
`(case-lambda [() ,(gen-build-jit-context c ip stack)] |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
139 |
[(,result) ,(gen-jump-to-label c ip (cons result stack))])) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
140 |
|
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
141 |
(define (gen-fresh-temps method) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
142 |
(match (slotAt method 4) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
143 |
[0 `'#()] |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
144 |
[temp-count `(make-vector ,temp-count NIL)])) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
145 |
|
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
146 |
(define (gen-send c send-ip class-exp name-bytes selector-exp k-exp arg-exps) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
147 |
(define old-pics (compilation-result-pic-list-rev (compilation-state c))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
148 |
(define pic-index (length old-pics)) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
149 |
(define m (mksym "pic~a" pic-index)) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
150 |
(define pi (pic-info name-bytes m send-ip)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
151 |
(set-compilation-result-pic-list-rev! (compilation-state c) (cons pi old-pics)) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
152 |
(match class-exp |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
153 |
[`(obj-class* vm self) #:when (< (compilation-depth c) 2) ;; self send |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
154 |
(define receiver-class (compilation-receiver-class c)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
155 |
(define method (lookup-method (compilation-vm c) receiver-class name-bytes)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
156 |
(define defining-class (slotAt method 5)) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
157 |
(log-vm/jit/code-debug "Self-send of ~a to class ~a" name-bytes receiver-class) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
158 |
(define ic (inline-compilation c method)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
159 |
(define body-code (gen-jump-to-label ic 0 '())) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
160 |
(define litmap (compilation-result-litmap (compilation-state ic))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
161 |
(define inner-code |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
162 |
`(let ((k ,k-exp) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
163 |
(method ,(gen-lit* litmap method)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
164 |
(super ,(gen-lit* litmap (slotAt defining-class 1)))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
165 |
(let ,(for/list [(formal (vector->list (compilation-argnames ic))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
166 |
(actual (in-list arg-exps))] |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
167 |
`(,formal ,actual)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
168 |
(let ((outer-k k) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
169 |
(temporaries ,(gen-fresh-temps method))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
170 |
,(gen-label-definitions ic body-code))))) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
171 |
(log-vm/jit/code-debug "INLINED:\n~a" (pretty-format inner-code)) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
172 |
inner-code] |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
173 |
[_ |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
174 |
`((lookup-message/jit vm ,m ,class-exp ,selector-exp) vm ,k-exp ,@arg-exps)])) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
175 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
176 |
(define (gen-block c argument-location ip) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
177 |
(define temp-count (slotAt (compilation-method c) 4)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
178 |
`(lambda (vm k . block-arguments) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
179 |
,(let loop ((i argument-location)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
180 |
(if (>= i temp-count) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
181 |
`(void) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
182 |
`(when (pair? block-arguments) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
183 |
(vector-set! temporaries ,i (car block-arguments)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
184 |
(let ((block-arguments (cdr block-arguments))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
185 |
,(loop (+ i 1)))))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
186 |
,(gen-code c ip '()))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
187 |
|
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
188 |
(define (compilation-litname c literal) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
189 |
(hash-ref (compilation-result-litmap (compilation-state c)) literal)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
190 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
191 |
(define (gen-code c ip stack) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
192 |
(define method (compilation-method c)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
193 |
(define bytecode (bv-bytes (slotAt method 1))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
194 |
(define literals (slotAt method 2)) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
195 |
(let translate ((ip ip) (stack stack)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
196 |
(define (next-byte!) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
197 |
(begin0 (bytes-ref bytecode ip) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
198 |
(set! ip (+ ip 1)))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
199 |
(define (decode!) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
200 |
(define byte (next-byte!)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
201 |
(define low (bitwise-and byte #x0f)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
202 |
(define high (bitwise-and (arithmetic-shift byte -4) #x0f)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
203 |
(if (zero? high) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
204 |
(values low (next-byte!)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
205 |
(values high low))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
206 |
(define ip0 ip) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
207 |
(define-values (opcode arg) (decode!)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
208 |
(log-vm/jit-debug " ~a: ~a ~a" ip0 opcode arg) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
209 |
(match opcode |
386
552736e4616c
Preserve abstraction (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
385
diff
changeset
|
210 |
[1 (let@ [n (mksym "slot~a_" arg) `(slotAt self ,arg)] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
211 |
(translate ip (cons n stack)))] |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
212 |
[2 (translate ip (cons (vector-ref (compilation-argnames c) arg) stack))] |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
213 |
[3 (let@ [n (mksym "tmp~a_" arg) `(vector-ref temporaries ,arg)] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
214 |
(translate ip (cons n stack)))] |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
215 |
[4 (let ((name (compilation-litname c (slotAt literals arg)))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
216 |
(translate ip (cons name stack)))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
217 |
[5 (match arg |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
218 |
[(or 0 1 2 3 4 5 6 7 8 9) (translate ip (cons arg stack))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
219 |
[10 (translate ip (cons `NIL stack))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
220 |
[11 (translate ip (cons `TRUE stack))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
221 |
[12 (translate ip (cons `FALSE stack))])] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
222 |
[6 `(begin (slotAtPut self ,arg ,(car stack)) ,(translate ip stack))] |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
223 |
[7 `(begin (vector-set! temporaries ,arg ,(car stack)) ,(translate ip stack))] |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
224 |
[8 (let* ((arg-count arg) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
225 |
(args (reverse (take stack arg-count))) |
387
9af7f893128d
Factor out gen-send
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
386
diff
changeset
|
226 |
(stack (drop stack arg-count))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
227 |
(define-values (selector-literal-index class-exp) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
228 |
(match/values (decode!) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
229 |
[(9 selector-literal-index) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
230 |
(values selector-literal-index `(obj-class* vm ,(car args)))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
231 |
[(15 11) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
232 |
(values (next-byte!) `super)])) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
233 |
(define k (gen-send-k c ip stack)) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
234 |
(define selector (slotAt literals selector-literal-index)) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
235 |
(define selector-exp (compilation-litname c selector)) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
236 |
(gen-send c ip0 class-exp (bv-bytes selector) selector-exp k args))] |
389
befaa2a55f7b
Clean out comments & obsoleted code
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
388
diff
changeset
|
237 |
;; 9 inlined in the processing of bytecode 8 |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
238 |
[10 (match arg |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
239 |
[0 (let@ [isNil `(boolean->obj vm (eq? NIL ,(car stack)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
240 |
(translate ip (cons isNil (cdr stack))))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
241 |
[1 (let@ [notNil `(boolean->obj vm (not (eq? NIL ,(car stack))))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
242 |
(translate ip (cons notNil (cdr stack))))])] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
243 |
[11 (match stack |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
244 |
[(list* j i stack) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
245 |
(let@ [binop-k (gen-send-k c ip stack)] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
246 |
`(if (and (number? ,i) (number? ,j)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
247 |
,(match arg |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
248 |
[0 `(,binop-k (boolean->obj vm (< ,i ,j)))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
249 |
[1 `(,binop-k (boolean->obj vm (<= ,i ,j)))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
250 |
[2 `(,binop-k (+ ,i ,j))]) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
251 |
,(let ((name-bytes (match arg [0 #"<"] [1 #"<="] [2 #"+"]))) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
252 |
(gen-send c |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
253 |
ip0 |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
254 |
`(obj-class* vm ,i) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
255 |
name-bytes |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
256 |
`(mkbv NIL ,name-bytes) |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
257 |
binop-k |
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
258 |
(list i j)))))])] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
259 |
[12 (let ((target (next-byte!))) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
260 |
(let@ [block `(mkffiv BLOCK ,(gen-block c arg ip))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
261 |
(translate target (cons block stack))))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
262 |
[13 (define primitive-number (next-byte!)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
263 |
(match primitive-number |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
264 |
[8 (let ((v (gensym 'blockresult)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
265 |
(block (car stack)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
266 |
(argc (- arg 1)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
267 |
(stack (cdr stack))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
268 |
`(match ,block |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
269 |
[(unffiv block-proc) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
270 |
(block-proc vm |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
271 |
;; TODO vvv : use case-lambda to translate the context chain |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
272 |
k ;; not (lambda (,v) ,(translate ip (cons v (drop stack argc)))) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
273 |
;; ^ reason being the image BUGGILY (?!?) relies on primitive 8 |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
274 |
;; immediately returning to the surrounding context!! |
377
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
275 |
,@(reverse (take stack argc)))] |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
276 |
[(obj (== BLOCK) _) |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
277 |
(k ((block->thunk vm ,block (list ,@(reverse (take stack argc))))))]))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
278 |
[34 'NIL] |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
279 |
[35 (let@ [ctxref (gen-build-jit-context c ip stack)] |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
280 |
(translate ip (cons ctxref stack)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
281 |
[36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
282 |
(translate ip (cons arr (drop stack arg))))] |
388 | 283 |
[_ (let ((generator (hash-ref *primitive-code-snippets* |
284 |
primitive-number |
|
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
285 |
(lambda () (error 'gen-code |
388 | 286 |
"Unknown primitive: ~a" |
287 |
primitive-number))))) |
|
288 |
(let@ [primresult (generator 'vm (reverse (take stack arg)))] |
|
289 |
(translate ip (cons primresult (drop stack arg)))))])] |
|
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
290 |
[14 (let@ [clsvar `(slotAt (obj-class* vm self) ,(+ arg 5))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
291 |
(translate ip (cons clsvar stack)))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
292 |
[15 (match arg |
378
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
293 |
[1 `(k self)] |
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
294 |
[2 `(k ,(car stack))] |
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
295 |
[3 `(outer-k ,(car stack))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
296 |
[5 (translate ip (cdr stack))] |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
297 |
[6 (gen-jump-to-label c (next-byte!) stack)] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
298 |
[7 (let ((target (next-byte!))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
299 |
(log-vm/jit-debug "if ~a true jump to ~a, else continue at ~a" (car stack) target ip) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
300 |
`(if (eq? ,(car stack) TRUE) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
301 |
,(gen-jump-to-label c target (cdr stack)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
302 |
,(gen-jump-to-label c ip (cdr stack))))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
303 |
[8 (let ((target (next-byte!))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
304 |
(log-vm/jit-debug "if ~a false jump to ~a, else continue at ~a" (car stack) target ip) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
305 |
`(if (eq? ,(car stack) FALSE) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
306 |
,(gen-jump-to-label c target (cdr stack)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
307 |
,(gen-jump-to-label c ip (cdr stack))))] |
389
befaa2a55f7b
Clean out comments & obsoleted code
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
388
diff
changeset
|
308 |
;; 11 inlined in the processing of bytecode 8 |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
309 |
[_ (error 'gen-code "Unhandled do-special case ~v" arg)])] |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
310 |
[_ (error 'gen-code "Method ~v - unhandled opcode ~v, arg ~v" |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
311 |
(slotAt (compilation-method c) 0) ;; selector |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
312 |
opcode |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
313 |
arg)]))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
314 |
|
404
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
315 |
(define (gen-label-definitions c body-exp) |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
316 |
`(letrec (,@(for/list [((ip label) (in-hash (compilation-labels c)))] |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
317 |
`(,(mksym "label~a" ip) ,label))) |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
318 |
,body-exp)) |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
319 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
320 |
(define (finish-compilation c compile-time-vm inner-code) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
321 |
(define litmap-list (hash->list (compilation-result-litmap (compilation-state c)))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
322 |
(define code |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
323 |
`(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(map cdr litmap-list)) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
324 |
,@(for/list [(pi (reverse (compilation-result-pic-list-rev (compilation-state c))))] |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
325 |
`(define ,(pic-info-variable pi) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
326 |
(pic ,(pic-info-name-bytes pi) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
327 |
,(pic-info-ip pi)))) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
328 |
,inner-code)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
329 |
|
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
330 |
(log-vm/jit/code-debug "Resulting code:\n~a" (pretty-format code)) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
331 |
(define literals (slotAt (compilation-method c) 2)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
332 |
(define defining-class (slotAt (compilation-method c) 5)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
333 |
(apply (eval code ns) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
334 |
(compilation-method c) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
335 |
(slotAt defining-class 1) ;; defining class's superclass |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
336 |
(VM-nil compile-time-vm) ;; assuming this VM is the one that will be used at call time! |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
337 |
(VM-true compile-time-vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
338 |
(VM-false compile-time-vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
339 |
(VM-Array compile-time-vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
340 |
(VM-Block compile-time-vm) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
341 |
(map car litmap-list))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
342 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
343 |
(define (compile-block-proc compile-time-vm |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
344 |
method |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
345 |
outer-args |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
346 |
actual-temporaries |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
347 |
argument-location |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
348 |
initial-ip) |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
349 |
(define class (obj-class* compile-time-vm (car outer-args))) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
350 |
(define c (top-compilation compile-time-vm class method)) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
351 |
(define body-code (gen-block c argument-location initial-ip)) ;; imperative! |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
352 |
(define inner-code |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
353 |
`(lambda (temporaries ,@(vector->list (compilation-argnames c))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
354 |
(let ((outer-k (outermost-k vm))) |
404
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
355 |
,(gen-label-definitions c body-code)))) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
356 |
(apply (finish-compilation c compile-time-vm inner-code) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
357 |
actual-temporaries |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
358 |
outer-args)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
359 |
|
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
360 |
(define (dump-stack vm ctx) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
361 |
(when (not (eq? (VM-nil vm) ctx)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
362 |
(define method (slotAt ctx 0)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
363 |
(define selector (slotAt method 0)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
364 |
(define receiver (slotAt (slotAt ctx 1) 0)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
365 |
(define receiver-class (obj-class* vm receiver)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
366 |
(define next-ctx (slotAt ctx 6)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
367 |
(log-vm/jit/recompile-info " ~a >> ~a" |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
368 |
(bv->string (slotAt receiver-class 0)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
369 |
(bv->string selector)) |
411
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
370 |
(define cached-method (lookup-method/cache vm receiver-class (bv-bytes selector))) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
371 |
(define compiled-method (unwrap-cached-method vm cached-method)) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
372 |
(when compiled-method |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
373 |
(match-define (compiled-method-info bytecode-method pics) (compiled-method)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
374 |
(log-vm/jit/recompile-info " has ~a bytes of bytecode" |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
375 |
(bytes-length (bv-bytes (slotAt bytecode-method 1)))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
376 |
(for [(pic pics)] |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
377 |
(define (pic-has-any-calls? pic) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
378 |
(or (positive? (vector-ref pic 4)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
379 |
(positive? (vector-ref pic 7)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
380 |
(positive? (vector-ref pic 10)))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
381 |
(when (pic-has-any-calls? pic) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
382 |
(log-vm/jit/recompile-info " ~a @~a ~a" |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
383 |
(vector-ref pic 0) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
384 |
(vector-ref pic 1) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
385 |
(for/list [(i (in-range 2 (vector-length pic) 3))] |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
386 |
(define c (vector-ref pic i)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
387 |
(if c |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
388 |
(match ((vector-ref pic (+ i 1))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
389 |
[(compiled-method-info bcm _pics) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
390 |
(list (bv->string (slotAt c 0)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
391 |
(vector-ref pic (+ i 2)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
392 |
(bytes-length (bv-bytes (slotAt bcm 1))))]) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
393 |
'-)))))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
394 |
(dump-stack vm next-ctx))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
395 |
|
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
396 |
(define (compile-method-proc compile-time-vm class method) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
397 |
(define c (top-compilation compile-time-vm class method)) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
398 |
(define body-code (gen-jump-to-label c 0 '())) ;; imperative! |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
399 |
(define inner-code |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
400 |
`(let ((call-counter 0)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
401 |
(case-lambda |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
402 |
[() |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
403 |
(compiled-method-info |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
404 |
method |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
405 |
(list |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
406 |
,@(let ((pic-count (length (compilation-result-pic-list-rev (compilation-state c))))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
407 |
(for/list [(n (in-range pic-count))] (mksym "pic~a" n)))))] |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
408 |
[(vm k ,@(vector->list (compilation-argnames c))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
409 |
(set! call-counter (+ call-counter 1)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
410 |
(when (= call-counter 1000) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
411 |
(log-vm/jit/recompile-info "Method ~a of class ~a is hot" |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
412 |
,(bv->string (slotAt method 0)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
413 |
,(bv->string (slotAt class 0))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
414 |
(dump-stack vm (k)) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
415 |
;; (set! call-counter 0) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
416 |
) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
417 |
(let ((outer-k k) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
418 |
(temporaries ,(gen-fresh-temps method))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
419 |
,(gen-label-definitions c body-code))]))) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
420 |
(finish-compilation c compile-time-vm inner-code)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
421 |
|
411
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
422 |
(struct cached-method (class name-bytes [bytecode-method #:mutable] [proc #:mutable])) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
423 |
|
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
424 |
(define (unwrap-cached-method vm cm) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
425 |
(or (cached-method-proc cm) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
426 |
(match cm |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
427 |
[(cached-method class name-bytes _bcm _proc) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
428 |
(define bcm (lookup-method vm class name-bytes)) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
429 |
(define proc (and bcm (compile-method-proc vm class bcm))) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
430 |
(set-cached-method-bytecode-method! cm bcm) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
431 |
(set-cached-method-proc! cm proc) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
432 |
proc]))) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
433 |
|
392
618244a1ee07
Small change toward avoiding consing selectors unnecessarily.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
389
diff
changeset
|
434 |
(define (lookup-method/cache vm class name-bytes) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
435 |
(define class-cache (hash-ref! (jit-VM-cache vm) class make-weak-hash)) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
436 |
(hash-ref! class-cache |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
437 |
name-bytes |
411
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
438 |
(lambda () (cached-method class name-bytes #f #f)))) |
368
bd33c8691bba
Simplest possible method cache. hop: 411861 bytecodes/sec; 65707 sends/sec --> 859845 bytecodes/sec; 106388 sends/sec
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
367
diff
changeset
|
439 |
|
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
440 |
(define (lookup-message/jit vm pic class selector) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
441 |
(define reserved 2) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
442 |
(define (@ i o) (vector-ref pic (+ reserved o (* i 3)))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
443 |
(define (@! i o v) (vector-set! pic (+ reserved o (* i 3)) v)) |
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
444 |
(let search-pic ((slot-index 0)) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
445 |
(define this-class (@ slot-index 0)) |
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
446 |
(if (eq? this-class class) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
447 |
(begin (@! slot-index 2 (+ 1 (@ slot-index 2))) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
448 |
(@ slot-index 1)) |
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
449 |
(let* ((next-slot-index (+ slot-index 1)) |
409
f19c9ff9d0d3
Repair pic fill-in code: it had been filling in only the final slot (!). ~7% speed boost
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
408
diff
changeset
|
450 |
(more-slots-to-check? (and this-class (< next-slot-index pic-entry-count)))) |
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
451 |
(if more-slots-to-check? |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
452 |
(search-pic next-slot-index) |
411
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
453 |
(let ((method |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
454 |
(unwrap-cached-method vm (lookup-method/cache vm class (bv-bytes selector))))) |
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
455 |
(if (not method) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
456 |
(lambda (vm ctx . args) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
457 |
(send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector)) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
458 |
(let ((slot-empty? (not this-class))) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
459 |
(when slot-empty? |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
460 |
(@! slot-index 0 class) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
461 |
(@! slot-index 1 method) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
462 |
(@! slot-index 2 1)) |
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
463 |
method)))))))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
464 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
465 |
(define (send-dnu vm ctx arguments class selector) |
392
618244a1ee07
Small change toward avoiding consing selectors unnecessarily.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
389
diff
changeset
|
466 |
(define dnu-name-bytes #"doesNotUnderstand:") |
411
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
467 |
(match (unwrap-cached-method vm (lookup-method/cache vm class dnu-name-bytes)) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
468 |
[#f (error 'send-message* "Unhandled selector ~a at class ~a" selector class)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
469 |
[dnu-method |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
470 |
(log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
471 |
(dnu-method vm ctx (slotAt arguments 0) (mkobj (VM-Array vm) selector arguments))])) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
472 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
473 |
(define (block->thunk vm block args) ;; Expects a real bytecode block, not an ffiv one |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
474 |
(lambda () |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
475 |
(define method (slotAt block 0)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
476 |
(define outer-args (vector->list (obj-slots (slotAt block 1)))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
477 |
(define temporaries (obj-slots (slotAt block 2))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
478 |
(define argument-location (slotAt block 7)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
479 |
(define block-ip (slotAt block 9)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
480 |
(define f (compile-block-proc vm method outer-args temporaries argument-location block-ip)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
481 |
(apply f vm (outermost-k vm) args))) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
482 |
|
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
483 |
(define (outermost-k vm) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
484 |
(case-lambda [() (VM-nil vm)] |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
485 |
[(result) result])) |
377
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
486 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
487 |
;;=========================================================================== |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
488 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
489 |
(define-primitive vm [6 inner-ctx] ;; "new context execute" |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
490 |
(when (not (zero? (slotAt inner-ctx 5))) (error 'execute "Cannot execute from nonempty stack")) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
491 |
(when (not (zero? (slotAt inner-ctx 4))) (error 'execute "Cannot execute from nonzero IP")) |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
492 |
(define args (slotAt inner-ctx 1)) |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
493 |
(define f (compile-method-proc vm (obj-class* vm (slotAt args 0)) (slotAt inner-ctx 0))) |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
494 |
(apply f vm (outermost-k vm) (vector->list (obj-slots args)))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
495 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
496 |
(define-primitive vm [116] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
497 |
(let ((image-bytes (serialize-image vm))) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
498 |
(display-to-file image-bytes (jit-VM-image-filename vm) #:exists 'replace))) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
499 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
500 |
;;=========================================================================== |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
501 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
502 |
(let* ((image-filename "SmallWorld/src/image") |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
503 |
(vm (call-with-input-file image-filename |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
504 |
(lambda (fh) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
505 |
(read-image fh jit-VM (list (make-weak-hasheq) image-filename)))))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
506 |
(boot-image vm |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
507 |
(lambda (vm source) |
411
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
508 |
(define compiled-method |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
509 |
(unwrap-cached-method vm (lookup-method/cache vm (obj-class source) #"doIt"))) |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
510 |
(compiled-method vm (outermost-k vm) source)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
511 |
(current-command-line-arguments))) |