author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Sat, 21 Jul 2018 19:01:20 +0100 | |
changeset 406 | 3a84d16cac19 |
parent 405 | 5a019affe985 |
child 408 | aa5e38d54ab0 |
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) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
13 |
|
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
14 |
(define pic-entry-count 3) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
15 |
(define (pic) (vector #f #f #f #f #f #f)) ;; pic-entry-count times two - one each for class & method |
395
3979401d44c1
Introduce struct mic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
394
diff
changeset
|
16 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
17 |
(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
|
18 |
#:methods gen:vm-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
19 |
[(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
|
20 |
;; 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
|
21 |
(lambda args |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
22 |
(thread (match action |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
23 |
[(unffiv block-proc) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
24 |
(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
|
25 |
[_ |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
26 |
(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
|
27 |
|
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
28 |
(struct compilation (vm receiver-class method litnames argnames labels [pic-count #:mutable])) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
29 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
30 |
(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
|
31 |
(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
|
32 |
(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
|
33 |
method |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
34 |
(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
|
35 |
(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
|
36 |
(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
|
37 |
(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
|
38 |
ip |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
39 |
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
|
40 |
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
|
41 |
|
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 (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
|
43 |
(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
|
44 |
(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
|
45 |
[(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
|
46 |
[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
|
47 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
48 |
(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
|
49 |
(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
|
50 |
|
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
|
51 |
(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
|
52 |
|
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
|
53 |
(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
|
54 |
(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
|
55 |
[(_ [n n-code-exp] body-code-exp) |
406
3a84d16cac19
Remove gratuitous layer of gensym
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
405
diff
changeset
|
56 |
(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
|
57 |
[(_ [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
|
58 |
(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
|
59 |
`(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
|
60 |
,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
|
61 |
|
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
62 |
(define (new-compilation compile-time-vm receiver-class method) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
63 |
(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
|
64 |
(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
|
65 |
(define bytecode (bv-bytes (slotAt method 1))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
66 |
(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
|
67 |
(define max-stack (slotAt method 3)) |
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
|
68 |
;; (define temp-count (slotAt method 4)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
69 |
(define defining-class (slotAt method 5)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
70 |
(define method-source (slotAt method 6)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
71 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
72 |
(log-vm/jit-info |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
73 |
"Compiling ~v defined in ~v, to be run in ~v, 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
|
74 |
(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
|
75 |
defining-class |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
76 |
receiver-class |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
77 |
arity |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
78 |
literals |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
79 |
(bytes->hex-string bytecode) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
80 |
(bv->string method-source)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
81 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
82 |
(define litnames (for/vector [(i (slotCount literals))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
83 |
(define lit (slotAt literals i)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
84 |
(if (bv? lit) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
85 |
(mksym "lit~a-~a" i (bv->string lit)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
86 |
(mksym "lit~a" i)))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
87 |
(define argnames (for/vector [(i arity)] (if (zero? i) 'self (mksym "arg~a" (- i 1))))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
88 |
|
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
89 |
(compilation compile-time-vm |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
90 |
receiver-class |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
91 |
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
|
92 |
litnames |
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
|
93 |
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
|
94 |
(make-hash) |
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
|
95 |
0)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
96 |
|
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
|
97 |
(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
|
98 |
(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
|
99 |
(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
|
100 |
(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
|
101 |
(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
|
102 |
(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
|
103 |
`(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
|
104 |
(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
|
105 |
`(,(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
|
106 |
|
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
|
107 |
(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
|
108 |
`(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
|
109 |
(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
|
110 |
(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
|
111 |
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
|
112 |
,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
|
113 |
,(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
|
114 |
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
|
115 |
(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
|
116 |
|
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
|
117 |
(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
|
118 |
(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
|
119 |
`(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
|
120 |
[(,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
|
121 |
|
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 |
(define (gen-send c class-exp selector-exp k-exp arg-exps) |
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 |
(define pic-index (compilation-pic-count 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
|
124 |
(set-compilation-pic-count! c (+ pic-index 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
|
125 |
(define m (mksym "pic~a" pic-index)) |
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 |
`((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
|
127 |
|
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
|
128 |
(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
|
129 |
(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
|
130 |
`(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
|
131 |
,(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
|
132 |
(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
|
133 |
`(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
|
134 |
`(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
|
135 |
(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
|
136 |
(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
|
137 |
,(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
|
138 |
,(gen-code c ip '()))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
139 |
|
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
|
140 |
(define (gen-code 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
|
141 |
(define bytecode (bv-bytes (slotAt (compilation-method c) 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
|
142 |
(define litnames (compilation-litnames 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
|
143 |
(define argnames (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
|
144 |
(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
|
145 |
(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
|
146 |
(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
|
147 |
(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
|
148 |
(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
|
149 |
(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
|
150 |
(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
|
151 |
(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
|
152 |
(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
|
153 |
(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
|
154 |
(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
|
155 |
(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
|
156 |
(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
|
157 |
(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
|
158 |
(match opcode |
386
552736e4616c
Preserve abstraction (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
385
diff
changeset
|
159 |
[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
|
160 |
(translate ip (cons n stack)))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
161 |
[2 (translate ip (cons (vector-ref argnames 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
|
162 |
[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
|
163 |
(translate ip (cons n stack)))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
164 |
[4 (translate ip (cons (vector-ref litnames 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
|
165 |
[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
|
166 |
[(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
|
167 |
[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
|
168 |
[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
|
169 |
[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
|
170 |
[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
|
171 |
[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
|
172 |
[8 (let* ((arg-count arg) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
173 |
(args (reverse (take stack arg-count))) |
387
9af7f893128d
Factor out gen-send
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
386
diff
changeset
|
174 |
(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
|
175 |
(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
|
176 |
(match/values (decode!) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
177 |
[(9 selector-literal-index) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
178 |
(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
|
179 |
[(15 11) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
180 |
(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
|
181 |
(define k (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
|
182 |
(gen-send c class-exp (vector-ref litnames selector-literal-index) k args))] |
389
befaa2a55f7b
Clean out comments & obsoleted code
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
388
diff
changeset
|
183 |
;; 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
|
184 |
[10 (match arg |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
185 |
[0 (let@ [isNil `(boolean->obj vm (eq? NIL ,(car stack)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
186 |
(translate ip (cons isNil (cdr stack))))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
187 |
[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
|
188 |
(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
|
189 |
[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
|
190 |
[(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
|
191 |
(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
|
192 |
`(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
|
193 |
,(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
|
194 |
[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
|
195 |
[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
|
196 |
[2 `(,binop-k (+ ,i ,j))]) |
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
|
197 |
,(gen-send 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
|
198 |
`(obj-class* vm ,i) |
387
9af7f893128d
Factor out gen-send
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
386
diff
changeset
|
199 |
`(mkbv NIL ,(match arg [0 #"<"] [1 #"<="] [2 #"+"])) |
9af7f893128d
Factor out gen-send
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
386
diff
changeset
|
200 |
binop-k |
9af7f893128d
Factor out gen-send
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
386
diff
changeset
|
201 |
(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
|
202 |
[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
|
203 |
(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
|
204 |
(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
|
205 |
[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
|
206 |
(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
|
207 |
[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
|
208 |
(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
|
209 |
(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
|
210 |
(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
|
211 |
`(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
|
212 |
[(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
|
213 |
(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
|
214 |
;; 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
|
215 |
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
|
216 |
;; ^ 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
|
217 |
;; 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
|
218 |
,@(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
|
219 |
[(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
|
220 |
(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
|
221 |
[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
|
222 |
[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
|
223 |
(translate ip (cons ctxref stack)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
224 |
[36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
225 |
(translate ip (cons arr (drop stack arg))))] |
388 | 226 |
[_ (let ((generator (hash-ref *primitive-code-snippets* |
227 |
primitive-number |
|
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
228 |
(lambda () (error 'gen-code |
388 | 229 |
"Unknown primitive: ~a" |
230 |
primitive-number))))) |
|
231 |
(let@ [primresult (generator 'vm (reverse (take stack arg)))] |
|
232 |
(translate ip (cons primresult (drop stack arg)))))])] |
|
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
233 |
[14 (let@ [clsvar `(slotAt (obj-class* vm self) ,(+ arg 5))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
234 |
(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
|
235 |
[15 (match arg |
378
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
236 |
[1 `(k self)] |
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
237 |
[2 `(k ,(car stack))] |
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
238 |
[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
|
239 |
[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
|
240 |
[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
|
241 |
[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
|
242 |
(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
|
243 |
`(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
|
244 |
,(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
|
245 |
,(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
|
246 |
[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
|
247 |
(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
|
248 |
`(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
|
249 |
,(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
|
250 |
,(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
|
251 |
;; 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
|
252 |
[_ (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
|
253 |
[_ (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
|
254 |
(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
|
255 |
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
|
256 |
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
|
257 |
|
404
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
258 |
(define (gen-label-definitions c body-exp) |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
259 |
`(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
|
260 |
`(,(mksym "label~a" ip) ,label))) |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
261 |
,body-exp)) |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
262 |
|
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
|
263 |
(define (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
|
264 |
(define 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
|
265 |
`(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(vector->list (compilation-litnames 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
|
266 |
,@(for/list [(i (compilation-pic-count c))] `(define ,(mksym "pic~a" i) (pic))) |
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
|
267 |
,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
|
268 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
269 |
(log-vm/jit-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
|
270 |
(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
|
271 |
(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
|
272 |
(apply (eval code ns) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
273 |
(compilation-method c) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
274 |
(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
|
275 |
(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
|
276 |
(VM-true compile-time-vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
277 |
(VM-false compile-time-vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
278 |
(VM-Array compile-time-vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
279 |
(VM-Block compile-time-vm) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
280 |
(vector->list (obj-slots literals)))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
281 |
|
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
|
282 |
(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
|
283 |
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
|
284 |
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
|
285 |
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
|
286 |
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
|
287 |
initial-ip) |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
288 |
(define class (obj-class* compile-time-vm (car outer-args))) |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
289 |
(define c (new-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
|
290 |
(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
|
291 |
(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
|
292 |
`(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
|
293 |
(let ((outer-k (outermost-k vm))) |
404
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
294 |
,(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
|
295 |
(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
|
296 |
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
|
297 |
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
|
298 |
|
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
299 |
(define (compile-method-proc compile-time-vm class method) |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
300 |
(define c (new-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
|
301 |
(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
|
302 |
(define temp-count (slotAt method 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
|
303 |
(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
|
304 |
`(lambda (vm k ,@(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
|
305 |
(let ((outer-k 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
|
306 |
(temporaries ,(if (zero? temp-count) `'#() `(make-vector ,temp-count NIL)))) |
404
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
307 |
,(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
|
308 |
(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
|
309 |
|
392
618244a1ee07
Small change toward avoiding consing selectors unnecessarily.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
389
diff
changeset
|
310 |
(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
|
311 |
(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
|
312 |
(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
|
313 |
name-bytes |
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
|
314 |
(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
|
315 |
(define m (lookup-method vm class name-bytes)) |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
316 |
(and m (compile-method-proc vm class m))))) |
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
|
317 |
|
396
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
318 |
(define (lookup-message/jit vm pic class selector) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
319 |
(let search-pic ((slot-index 0)) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
320 |
(define this-class (vector-ref pic (* slot-index 2))) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
321 |
(if (eq? this-class class) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
322 |
(vector-ref pic (+ (* slot-index 2) 1)) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
323 |
(let* ((next-slot-index (+ slot-index 1)) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
324 |
(more-slots-to-check? (< next-slot-index pic-entry-count))) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
325 |
(if more-slots-to-check? |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
326 |
(search-pic next-slot-index) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
327 |
(let ((method (lookup-method/cache vm class (bv-bytes selector)))) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
328 |
(if (not method) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
329 |
(lambda (vm ctx . args) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
330 |
(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
|
331 |
(let ((slot-empty? (not this-class))) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
332 |
(when slot-empty? |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
333 |
(vector-set! pic (* slot-index 2) class) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
334 |
(vector-set! pic (+ (* slot-index 2) 1) method)) |
3bfb9afdbd9d
Switch from mic to pic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset
|
335 |
method)))))))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
336 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
337 |
(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
|
338 |
(define dnu-name-bytes #"doesNotUnderstand:") |
618244a1ee07
Small change toward avoiding consing selectors unnecessarily.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
389
diff
changeset
|
339 |
(match (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
|
340 |
[#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
|
341 |
[dnu-method |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
342 |
(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
|
343 |
(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
|
344 |
|
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
|
345 |
(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
|
346 |
(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
|
347 |
(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
|
348 |
(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
|
349 |
(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
|
350 |
(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
|
351 |
(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
|
352 |
(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
|
353 |
(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
|
354 |
|
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
|
355 |
(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
|
356 |
(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
|
357 |
[(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
|
358 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
359 |
;;=========================================================================== |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
360 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
361 |
(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
|
362 |
(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
|
363 |
(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
|
364 |
(define args (slotAt inner-ctx 1)) |
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
365 |
(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
|
366 |
(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
|
367 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
368 |
(define-primitive vm [116] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
369 |
(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
|
370 |
(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
|
371 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
372 |
;;=========================================================================== |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
373 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
374 |
(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
|
375 |
(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
|
376 |
(lambda (fh) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
377 |
(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
|
378 |
(boot-image vm |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
379 |
(lambda (vm source) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
380 |
((lookup-method/cache vm (obj-class source) #"doIt") vm (outermost-k vm) source)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
381 |
(current-command-line-arguments))) |