author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Mon, 16 Jul 2018 15:27:24 +0100 | |
changeset 386 | 552736e4616c |
parent 385 | 0d3839af02db |
child 387 | 9af7f893128d |
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 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
6 |
(require racket/struct) |
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
7 |
(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
|
8 |
(require (only-in sha bytes->hex-string)) |
364
0a3d798252f2
Use oneshot.rkt instead of nasty async-channel
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
363
diff
changeset
|
9 |
(require "oneshot.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) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
12 |
(define-logger vm/gui) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
13 |
(define-logger vm/jit) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
14 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
15 |
(struct obj ([class #:mutable] slots) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
16 |
#:methods gen:custom-write |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
17 |
[(define write-proc |
357 | 18 |
(make-constructor-style-printer (lambda (o) (format "obj:~a" (obj-class-name o))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
19 |
(lambda (o) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
20 |
(match (obj-class-name o) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
21 |
[#"Array" (list (vector->list (obj-slots o)))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
22 |
[#"Class" (list (slotAt o 0))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
23 |
[_ '()]))))]) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
24 |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
25 |
(struct bv obj (bytes) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
26 |
#:methods gen:custom-write |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
27 |
[(define write-proc |
357 | 28 |
(make-constructor-style-printer (lambda (o) (format "bv:~a" (obj-class-name o))) |
358
979291ad3ab5
Tidy tidy for debugging
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
357
diff
changeset
|
29 |
(lambda (o) (list (bv-bytes o)))))]) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
30 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
31 |
(struct ffiv obj (value) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
32 |
#:methods gen:custom-write |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
33 |
[(define write-proc |
357 | 34 |
(make-constructor-style-printer (lambda (o) (format "ffiv:~a" (obj-class-name o))) |
35 |
(lambda (o) (list (ffiv-value o)))))]) |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
36 |
|
357 | 37 |
(define-match-expander unbv |
38 |
(syntax-rules () [(_ bytes-pat) (bv _ _ bytes-pat)])) |
|
39 |
(define-match-expander unbv* |
|
40 |
(syntax-rules () [(_ this-pat bytes-pat) (and this-pat (bv _ _ bytes-pat))])) |
|
41 |
(define-match-expander unstr |
|
42 |
(syntax-rules () [(_ str-pat) (bv _ _ (app bytes->string/utf-8 str-pat))])) |
|
43 |
(define-match-expander unffiv |
|
44 |
(syntax-rules () [(_ val-pat) (ffiv _ _ val-pat)])) |
|
45 |
(define-match-expander unffiv* |
|
46 |
(syntax-rules () [(_ this-pat val-pat) (and this-pat (ffiv _ _ val-pat))])) |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
47 |
|
376
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 (bv->string b) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
49 |
(bytes->string/utf-8 (bv-bytes b))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
50 |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
51 |
(define (obj-class-name o) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
52 |
(define c (obj-class o)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
53 |
(if (and (positive? (slotCount c)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
54 |
(bv? (slotAt c 0))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
55 |
(bv-bytes (slotAt c 0)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
56 |
#"???")) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
57 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
58 |
(struct VM (nil true false Array Block Context Integer cache image-filename)) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
59 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
60 |
(define (read-image image-filename fh) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
61 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
62 |
(define (next-int #:signed? [signed? #t] #:eof-ok? [eof-ok? #f]) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
63 |
(define bs (read-bytes 4 fh)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
64 |
(if (eof-object? bs) |
367
e7ff3e80ab7b
Tighten (almost cosmetic)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
366
diff
changeset
|
65 |
(if eof-ok? bs (error 'read-image "Early EOF")) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
66 |
(integer-bytes->integer bs signed? #t))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
67 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
68 |
(let ((image-version (next-int)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
69 |
(expected-version 1)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
70 |
(when (not (= image-version expected-version)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
71 |
(error 'read-image "Wrong image version: got ~a, expected ~a" |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
72 |
image-version |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
73 |
expected-version))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
74 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
75 |
(define object-table |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
76 |
(let loop ((acc '())) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
77 |
(define (emit x) (loop (cons x acc))) |
367
e7ff3e80ab7b
Tighten (almost cosmetic)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
366
diff
changeset
|
78 |
(match (next-int #:eof-ok? #t) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
79 |
[(? eof-object?) (list->vector (reverse acc))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
80 |
[obj-length |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
81 |
(define type-code (next-int)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
82 |
(define class-index (next-int)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
83 |
(define slot-count (next-int)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
84 |
(match type-code |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
85 |
[0 ;; SmallInt |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
86 |
(when (not (= obj-length 5)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
87 |
(error 'read-image "Strange SmallInt obj-length: ~a" obj-length)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
88 |
(when (not (zero? slot-count)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
89 |
(error 'read-image "Strange SmallInt with ~a slots" slot-count)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
90 |
(emit (next-int))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
91 |
[1 ;; SmallByteArray |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
92 |
(define byte-count (- obj-length slot-count 4)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
93 |
(emit (bv class-index |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
94 |
(for/vector [(i slot-count)] (next-int)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
95 |
(read-bytes byte-count fh)))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
96 |
[2 ;; SmallObject |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
97 |
(emit (obj class-index |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
98 |
(for/vector [(i slot-count)] (next-int))))])]))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
99 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
100 |
(for [(x object-table)] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
101 |
(when (obj? x) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
102 |
(set-obj-class! x (vector-ref object-table (obj-class x))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
103 |
(for [(i (vector-length (obj-slots x)))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
104 |
(vector-set! (obj-slots x) i (vector-ref object-table (vector-ref (obj-slots x) i)))))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
105 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
106 |
(VM (vector-ref object-table 0) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
107 |
(vector-ref object-table 1) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
108 |
(vector-ref object-table 2) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
109 |
(vector-ref object-table 3) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
110 |
(vector-ref object-table 4) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
111 |
(vector-ref object-table 5) |
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
|
112 |
(vector-ref object-table 6) |
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
113 |
(make-weak-hasheq) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
114 |
image-filename)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
115 |
|
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
116 |
(define (serialize-image vm) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
117 |
(define indices (make-hasheq)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
118 |
(define output-rev '()) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
119 |
(define worklist-rev '()) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
120 |
(define next-index 0) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
121 |
|
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
122 |
(define (push-bytes! item) (set! output-rev (cons item output-rev))) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
123 |
(define (push-int! n) (push-bytes! (integer->integer-bytes n 4 #t #t))) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
124 |
|
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
125 |
(define (object->index o) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
126 |
(if (ffiv? o) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
127 |
(object->index (VM-nil vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
128 |
(hash-ref! indices o (lambda () |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
129 |
(begin0 next-index |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
130 |
(set! next-index (+ next-index 1)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
131 |
(set! worklist-rev (cons o worklist-rev))))))) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
132 |
|
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
133 |
(push-int! 1) ;; version number |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
134 |
(object->index (VM-nil vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
135 |
(object->index (VM-true vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
136 |
(object->index (VM-false vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
137 |
(object->index (VM-Array vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
138 |
(object->index (VM-Block vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
139 |
(object->index (VM-Context vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
140 |
(object->index (VM-Integer vm)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
141 |
(for [(i 10)] (object->index i)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
142 |
|
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
143 |
(let loop () |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
144 |
(define worklist (reverse worklist-rev)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
145 |
(set! worklist-rev '()) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
146 |
(when (pair? worklist) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
147 |
(for [(o worklist)] |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
148 |
(match o |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
149 |
[(? number?) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
150 |
(push-int! 5) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
151 |
(push-int! 0) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
152 |
(push-int! (object->index (VM-Integer vm))) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
153 |
(push-int! 0) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
154 |
(push-int! o)] |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
155 |
[(bv class slots bytes) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
156 |
(push-int! (+ (bytes-length bytes) (vector-length slots) 4)) ;; weird |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
157 |
(push-int! 1) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
158 |
(push-int! (object->index class)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
159 |
(push-int! (vector-length slots)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
160 |
(for [(s slots)] (push-int! (object->index s))) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
161 |
(push-bytes! bytes)] |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
162 |
[(obj class slots) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
163 |
(push-int! (+ (vector-length slots) 4)) ;; weird |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
164 |
(push-int! 2) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
165 |
(push-int! (object->index class)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
166 |
(push-int! (vector-length slots)) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
167 |
(for [(s slots)] (push-int! (object->index s)))])) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
168 |
(loop))) |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
169 |
|
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
170 |
(bytes-append* (reverse output-rev))) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
171 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
172 |
(define (slotCount o) (vector-length (obj-slots o))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
173 |
(define (slotAt o i) (vector-ref (obj-slots o) i)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
174 |
(define (slotAtPut o i v) (vector-set! (obj-slots o) i v)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
175 |
|
357 | 176 |
(define (search-class-method-dictionary c name-bytes) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
177 |
(define methods (slotAt c 2)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
178 |
(for/first [(m (obj-slots methods)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
179 |
#:when (equal? name-bytes (bv-bytes (slotAt m 0)))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
180 |
m)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
181 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
182 |
(define (mkobj cls . fields) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
183 |
(obj cls (list->vector fields))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
184 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
185 |
(define (mkbv cls bs . fields) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
186 |
(bv cls (list->vector fields) bs)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
187 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
188 |
(define (mkffiv cls value) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
189 |
(ffiv cls '#() value)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
190 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
191 |
(define (mkarray vm count [init (VM-nil vm)]) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
192 |
(obj (VM-Array vm) (make-vector count init))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
193 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
194 |
(define (build-context vm previous-context args method) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
195 |
(define temp-count (slotAt method 4)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
196 |
(define max-stack (slotAt method 3)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
197 |
(mkobj (VM-Context vm) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
198 |
method |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
199 |
args |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
200 |
(mkarray vm temp-count) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
201 |
(mkarray vm max-stack) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
202 |
0 ;; IP |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
203 |
0 ;; stack top |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
204 |
previous-context)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
205 |
|
376
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 (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
|
207 |
(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
|
208 |
(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
|
209 |
method |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
210 |
(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
|
211 |
(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
|
212 |
(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
|
213 |
(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
|
214 |
ip |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
215 |
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
|
216 |
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
|
217 |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
218 |
(define (clone-array a [start 0] [count (- (slotCount a) start)]) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
219 |
(define b (obj (obj-class a) (make-vector count))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
220 |
(for [(i (in-range count))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
221 |
(slotAtPut b i (slotAt a (+ i start)))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
222 |
b) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
223 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
224 |
(define (boolean->obj vm b) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
225 |
(if b (VM-true vm) (VM-false vm))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
226 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
227 |
(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
|
228 |
(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
|
229 |
(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
|
230 |
[(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
|
231 |
[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
|
232 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
233 |
(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
|
234 |
(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
|
235 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
236 |
(define (compile-native-proc compile-time-vm method) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
237 |
(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
|
238 |
(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
|
239 |
(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
|
240 |
(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
|
241 |
(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
|
242 |
(define temp-count (slotAt method 4)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
243 |
(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
|
244 |
(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
|
245 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
246 |
(log-vm/jit-info |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
247 |
"Compiling ~v defined in ~v, arity ~a, literals ~a, bytecode ~a, text:\n----\n~a\n----" |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
248 |
(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
|
249 |
defining-class |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
250 |
arity |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
251 |
literals |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
252 |
(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
|
253 |
(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
|
254 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
255 |
(define (mksym fmt . args) (string->symbol (apply format fmt args))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
256 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
257 |
(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
|
258 |
(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
|
259 |
(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
|
260 |
(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
|
261 |
(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
|
262 |
(define tmpnames (for/vector [(i temp-count)] (mksym "tmp~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
|
263 |
(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
|
264 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
265 |
(define (build-jit-context-exp ip 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 |
`(build-jit-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
|
267 |
(k) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
268 |
(vector ,@(vector->list argnames)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
269 |
method |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
270 |
,ip |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
271 |
,(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
|
272 |
(vector ,@(vector->list tmpnames)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
273 |
(vector ,@(reverse stack)))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
274 |
|
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
275 |
(define-syntax let@ |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
276 |
(syntax-rules () |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
277 |
[(_ [n n-code-exp] body-code-exp) |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
278 |
(let@ [n (gensym 'n) n-code-exp] body-code-exp)] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
279 |
[(_ [n n-exp n-code-exp] body-code-exp) |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
280 |
(let ((n (gensym n-exp))) |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
281 |
`(let ((,n ,n-code-exp)) |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
282 |
,body-code-exp))])) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
283 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
284 |
(define labels (make-hash)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
285 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
286 |
(define (jump-to-label ip stack) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
287 |
(when (not (hash-has-key? labels ip)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
288 |
(hash-set! labels ip 'placeholder) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
289 |
(define actual-label |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
290 |
(let ((newstack (for/list [(i (length stack))] (mksym "stack~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
|
291 |
`(lambda (k ,@newstack) ,(translate ip newstack)))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
292 |
(hash-set! labels ip actual-label)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
293 |
`(,(mksym "label~a" ip) k ,@stack)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
294 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
295 |
(define mic-count 0) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
296 |
(define (next-mic!) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
297 |
(begin0 mic-count |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
298 |
(set! mic-count (+ mic-count 1)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
299 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
300 |
(define (translate ip stack) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
301 |
(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
|
302 |
(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
|
303 |
(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
|
304 |
(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
|
305 |
(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
|
306 |
(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
|
307 |
(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
|
308 |
(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
|
309 |
(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
|
310 |
(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
|
311 |
(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
|
312 |
(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
|
313 |
(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
|
314 |
(match opcode |
386
552736e4616c
Preserve abstraction (!)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
385
diff
changeset
|
315 |
[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
|
316 |
(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
|
317 |
[2 (translate ip (cons (vector-ref argnames arg) stack))] |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
318 |
[3 (let@ [n (mksym "tmp~a_" arg) (vector-ref tmpnames 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
|
319 |
(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
|
320 |
[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
|
321 |
[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
|
322 |
[(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
|
323 |
[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
|
324 |
[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
|
325 |
[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
|
326 |
[6 `(begin (slotAtPut self ,arg ,(car stack)) ,(translate ip stack))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
327 |
[7 `(begin (set! ,(vector-ref tmpnames 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
|
328 |
[8 (let* ((arg-count arg) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
329 |
(args (reverse (take stack arg-count))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
330 |
(stack (drop stack arg-count)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
331 |
(mic-index (next-mic!)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
332 |
(result (gensym 'result))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
333 |
(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
|
334 |
(match/values (decode!) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
335 |
[(9 selector-literal-index) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
336 |
(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
|
337 |
[(15 11) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
338 |
(values (next-byte!) `super)])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
339 |
`((lookup-message/jit vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
340 |
,(mksym "mic~a-class" mic-index) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
341 |
,(mksym "mic~a-method" mic-index) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
342 |
,class-exp |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
343 |
,(vector-ref litnames selector-literal-index)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
344 |
vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
345 |
(case-lambda |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
346 |
[() ,(build-jit-context-exp ip stack)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
347 |
[(,result) ,(translate ip (cons result stack))]) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
348 |
,@args))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
349 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
350 |
;; [9 (let ((args (car stack)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
351 |
;; (result (gensym 'result))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
352 |
;; (log-vm/jit-debug "send of ~a" (slotAt literals arg)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
353 |
;; `(send-message vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
354 |
;; (case-lambda |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
355 |
;; [() ,(build-jit-context-exp ip (cdr stack))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
356 |
;; [(,result) ,(translate ip (cons result (cdr stack)))]) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
357 |
;; (obj ARRAY (list->vector ,args)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
358 |
;; ,(vector-ref litnames arg)))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
359 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
360 |
[10 (match arg |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
361 |
[0 (let@ [isNil `(boolean->obj vm (eq? NIL ,(car stack)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
362 |
(translate ip (cons isNil (cdr stack))))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
363 |
[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
|
364 |
(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
|
365 |
[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
|
366 |
[(list* j i stack) |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
367 |
(let@ [binop-k (let ((binop-result (gensym 'binop-result))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
368 |
`(case-lambda |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
369 |
[() ,(build-jit-context-exp ip stack)] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
370 |
[(,binop-result) ,(translate ip (cons binop-result stack))]))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
371 |
`(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
|
372 |
,(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
|
373 |
[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
|
374 |
[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
|
375 |
[2 `(,binop-k (+ ,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
|
376 |
(send-message vm |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
377 |
,binop-k |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
378 |
(mkobj ARRAY ,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
|
379 |
(mkbv NIL ,(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
|
380 |
[0 #"<"] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
381 |
[1 #"<="] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
382 |
[2 #"+"])))))])] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
383 |
[12 (let ((target (next-byte!))) |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
384 |
(let@ [block `(mkffiv BLOCK |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
385 |
(lambda (_vm k . block-arguments) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
386 |
,(let loop ((i arg)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
387 |
(if (>= i temp-count) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
388 |
`(void) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
389 |
`(when (pair? block-arguments) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
390 |
(set! ,(vector-ref tmpnames i) (car block-arguments)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
391 |
(let ((block-arguments (cdr block-arguments))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
392 |
,(loop (+ 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
|
393 |
,(translate ip '())))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
394 |
(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
|
395 |
[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
|
396 |
(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
|
397 |
[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
|
398 |
(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
|
399 |
(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
|
400 |
(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
|
401 |
`(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
|
402 |
[(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
|
403 |
(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
|
404 |
;; 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
|
405 |
k ;; not (lambda (,v) ,(translate ip (cons v (drop stack argc)))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
406 |
;; ^ reason being the image BUGGILY relies on primitive 8 |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
407 |
;; 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
|
408 |
,@(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
|
409 |
[(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
|
410 |
(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
|
411 |
[34 'NIL] |
385
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
412 |
[35 (let@ [ctxref (build-jit-context-exp ip stack)] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
413 |
(translate ip (cons ctxref stack)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
414 |
[36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
415 |
(translate ip (cons arr (drop stack arg))))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
416 |
[_ (let@ [primresult (let ((generator (hash-ref *primitive-code-snippets* |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
417 |
primitive-number |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
418 |
(lambda () |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
419 |
(error 'compile-native-proc |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
420 |
"Unknown primitive: ~a" |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
421 |
primitive-number))))) |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
422 |
(generator 'vm (reverse (take stack arg))))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
423 |
(translate ip (cons primresult (drop stack arg))))])] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
424 |
[14 (let@ [clsvar `(slotAt (obj-class* vm self) ,(+ arg 5))] |
0d3839af02db
Tighten let@ definition
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset
|
425 |
(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
|
426 |
[15 (match arg |
378
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
427 |
[1 `(k self)] |
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
428 |
[2 `(k ,(car stack))] |
2a35e7fcba59
Remove resume-jit-context
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset
|
429 |
[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
|
430 |
[5 (translate ip (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
|
431 |
[6 (jump-to-label (next-byte!) stack)] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
432 |
[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
|
433 |
(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
|
434 |
`(if (eq? ,(car stack) TRUE) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
435 |
,(jump-to-label target (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
|
436 |
,(jump-to-label ip (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
|
437 |
[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
|
438 |
(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
|
439 |
`(if (eq? ,(car stack) FALSE) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
440 |
,(jump-to-label target (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
|
441 |
,(jump-to-label ip (cdr stack))))] |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
442 |
;; [11 (let ((args (car stack)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
443 |
;; (result (gensym 'result)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
444 |
;; (selector-literal (next-byte!))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
445 |
;; `(send-message* vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
446 |
;; (case-lambda |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
447 |
;; [() ,(build-jit-context-exp ip (cdr stack))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
448 |
;; [(,result) ,(translate ip (cons result (cdr stack)))]) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
449 |
;; (obj ARRAY (list->vector ,args)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
450 |
;; super |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
451 |
;; ,(vector-ref litnames selector-literal)))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
452 |
[_ (error 'compile-native-proc "Unhandled do-special case ~v" arg)])] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
453 |
[_ (error 'compile-native-proc "Method ~v - unhandled opcode ~v, arg ~v" |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
454 |
selector |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
455 |
opcode |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
456 |
arg)])) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
457 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
458 |
(define code |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
459 |
(let ((inner (jump-to-label 0 '()))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
460 |
`(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(vector->list litnames)) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
461 |
,@(for/list [(i mic-count)] `(define ,(mksym "mic~a-class" i) (box NIL))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
462 |
,@(for/list [(i mic-count)] `(define ,(mksym "mic~a-method" i) (box NIL))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
463 |
(lambda (vm k ,@(vector->list argnames)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
464 |
(let ((outer-k k) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
465 |
,@(for/list [(t tmpnames)] `(,t NIL))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
466 |
(letrec (,@(for/list [((ip label) (in-hash labels))] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
467 |
`(,(mksym "label~a" ip) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
468 |
,label))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
469 |
,inner)))))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
470 |
(log-vm/jit-info "Resulting code:\n~a" (pretty-format code)) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
471 |
(define final-proc |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
472 |
(apply (eval code ns) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
473 |
method |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
474 |
(slotAt defining-class 1) ;; defining class's superclass |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
475 |
(VM-nil compile-time-vm) ;; assuming this VM is the one that will be used at call time! |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
476 |
(VM-true compile-time-vm) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
477 |
(VM-false compile-time-vm) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
478 |
(VM-Array compile-time-vm) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
479 |
(VM-Block compile-time-vm) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
480 |
(vector->list (obj-slots literals)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
481 |
(log-vm/jit-info "Final proc: ~a" final-proc) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
482 |
final-proc) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
483 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
484 |
(define (install-native-proc! vm class selector native-proc) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
485 |
(define name-bytes (bv-bytes selector)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
486 |
(define class-cache (hash-ref! (VM-cache vm) class make-weak-hash)) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
487 |
(hash-set! class-cache name-bytes native-proc) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
488 |
native-proc) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
489 |
|
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
|
490 |
(define (lookup-method/cache vm class selector) |
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
|
491 |
(define name-bytes (bv-bytes selector)) |
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
|
492 |
(define class-cache (hash-ref! (VM-cache vm) class make-weak-hash)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
493 |
(hash-ref! class-cache name-bytes (lambda () (lookup-method vm class selector)))) |
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
|
494 |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
495 |
(define (lookup-method vm class selector) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
496 |
(define name-bytes (bv-bytes selector)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
497 |
(let search ((class class)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
498 |
(and (not (eq? class (VM-nil vm))) |
357 | 499 |
(or (search-class-method-dictionary class name-bytes) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
500 |
(search (slotAt class 1)))))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
501 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
502 |
(define (store-registers! ctx ip stack-top) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
503 |
(slotAtPut ctx 4 ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
504 |
(slotAtPut ctx 5 stack-top)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
505 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
506 |
;; (define (lookup-message/jit vm mic-class mic-method class selector) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
507 |
;; (when (not (eq? (unbox mic-class) class)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
508 |
;; (set-box! mic-class class) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
509 |
;; (set-box! mic-method #f)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
510 |
;; (when (not (unbox mic-method)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
511 |
;; (set-box! mic-method (lookup-method/cache vm class selector)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
512 |
;; (when (not (procedure? (unbox mic-method))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
513 |
;; (set-box! mic-method (install-native-proc! vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
514 |
;; class |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
515 |
;; selector |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
516 |
;; (compile-native-proc vm (unbox mic-method)))))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
517 |
;; (or (unbox mic-method) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
518 |
;; (lambda (vm ctx . args) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
519 |
;; (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
520 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
521 |
(define (lookup-message/jit vm mic-class mic-method class selector) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
522 |
(define method (unbox mic-method)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
523 |
(when (or (not (eq? (unbox mic-class) class)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
524 |
(not method)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
525 |
(set-box! mic-class class) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
526 |
(set! method (lookup-method/cache vm class selector)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
527 |
(when (and method (not (procedure? method))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
528 |
(set! method (install-native-proc! vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
529 |
class |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
530 |
selector |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
531 |
(compile-native-proc vm method)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
532 |
(set-box! mic-method method)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
533 |
(or method |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
534 |
(lambda (vm ctx . args) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
535 |
(send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
536 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
537 |
(define (send-dnu vm ctx arguments class selector) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
538 |
(define dnu-selector (mkbv (obj-class selector) #"doesNotUnderstand:")) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
539 |
(match (lookup-method/cache vm class dnu-selector) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
540 |
[#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
|
541 |
[dnu-method |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
542 |
(log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
543 |
(apply-method class |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
544 |
dnu-selector |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
545 |
dnu-method |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
546 |
vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
547 |
ctx |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
548 |
(list (slotAt arguments 0) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
549 |
(mkobj (VM-Array vm) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
550 |
selector |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
551 |
(clone-array arguments))))])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
552 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
553 |
(define (send-message* vm ctx arguments class selector) |
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
|
554 |
(match (lookup-method/cache vm class selector) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
555 |
[#f (send-dnu vm ctx arguments class selector)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
556 |
[new-method (apply-method class |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
557 |
selector |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
558 |
new-method |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
559 |
vm |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
560 |
ctx |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
561 |
(vector->list (obj-slots arguments)))])) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
562 |
|
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
563 |
(define (apply-method class selector method vm ctx arglist) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
564 |
(define native-proc |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
565 |
(if (procedure? method) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
566 |
method |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
567 |
(install-native-proc! vm class selector (compile-native-proc vm method)))) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
568 |
(apply native-proc |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
569 |
vm |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
570 |
(if (procedure? ctx) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
571 |
ctx |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
572 |
(case-lambda |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
573 |
[() ctx] |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
574 |
[(result) (resume-context vm ctx result)])) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
575 |
arglist)) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
576 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
577 |
(define (obj-class* vm o) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
578 |
(if (number? o) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
579 |
(VM-Integer vm) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
580 |
(obj-class o))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
581 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
582 |
(define (send-message vm ctx arguments selector) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
583 |
(log-vm-debug "sending: ~a ~a" selector arguments) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
584 |
(send-message* vm ctx arguments (obj-class* vm (slotAt arguments 0)) selector)) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
585 |
|
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
|
586 |
(define (block->thunk vm block args) ;; Expects a real bytecode block, not an ffiv one |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
587 |
(let ((ctx (clone-array 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
|
588 |
(define argument-location (slotAt ctx 7)) |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
589 |
(for [(i (in-naturals argument-location)) (arg (in-list args))] |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
590 |
(slotAtPut (slotAt ctx 2) i arg)) |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
591 |
(slotAtPut ctx 3 (mkarray vm (slotCount (slotAt ctx 3)))) |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
592 |
(slotAtPut ctx 4 (slotAt ctx 9)) ;; reset IP to correct block offset |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
593 |
(slotAtPut ctx 5 0) ;; zero stack-top |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
594 |
(slotAtPut ctx 6 (VM-nil vm)) ;; no previous context |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
595 |
(lambda () (execute vm ctx)))) |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
596 |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
597 |
(define (block-callback vm block) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
598 |
;; Runs block in a new thread |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
599 |
(lambda args |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
600 |
(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
|
601 |
[(unffiv block-proc) |
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
|
602 |
(thread (lambda () (apply block-proc |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
603 |
vm |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
604 |
(case-lambda [() (VM-nil vm)] [(result) (void)]) |
8accd6d3f51d
Extract and make use of block->thunk, to support image-produced block calls.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset
|
605 |
args)))] |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
606 |
[_ |
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
|
607 |
(thread (block->thunk vm block args))]))) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
608 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
609 |
(define smalltalk-frame% |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
610 |
(class frame% |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
611 |
(field [close-handler void]) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
612 |
(define/public (set-close-handler new-handler) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
613 |
(set! close-handler new-handler)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
614 |
(define/augment (on-close) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
615 |
(close-handler this)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
616 |
(super-new))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
617 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
618 |
(define (resume-context vm ctx result) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
619 |
(if (eq? (VM-nil vm) ctx) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
620 |
result |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
621 |
(let ((stack-top (slotAt ctx 5))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
622 |
(slotAtPut (slotAt ctx 3) stack-top result) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
623 |
(slotAtPut ctx 5 (+ stack-top 1)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
624 |
(log-vm-debug "resuming: ~a" result) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
625 |
(execute vm ctx)))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
626 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
627 |
(define (execute vm ctx) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
628 |
(define method (slotAt ctx 0)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
629 |
(define arguments (slotAt ctx 1)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
630 |
(define temporaries (slotAt ctx 2)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
631 |
(define stack (slotAt ctx 3)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
632 |
(define ip (slotAt ctx 4)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
633 |
(define stack-top (slotAt ctx 5)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
634 |
(define previous-ctx (slotAt ctx 6)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
635 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
636 |
(define receiver (slotAt arguments 0)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
637 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
638 |
(define bytecode (bv-bytes (slotAt method 1))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
639 |
(define literals (slotAt method 2)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
640 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
641 |
(log-vm-info "Interpreter bytecode, ctx slotcount ~a, method name ~a: ~a" |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
642 |
(slotCount ctx) |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
643 |
(bv->string (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
|
644 |
(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
|
645 |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
646 |
(define (push! v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
647 |
(slotAtPut stack stack-top v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
648 |
(set! stack-top (+ stack-top 1))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
649 |
(define (pop!) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
650 |
(set! stack-top (- stack-top 1)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
651 |
(slotAt stack stack-top)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
652 |
(define (peek) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
653 |
(slotAt stack (- stack-top 1))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
654 |
|
357 | 655 |
(define (pop-multiple! count) |
656 |
(set! stack-top (- stack-top count)) |
|
657 |
(clone-array stack stack-top count)) |
|
658 |
||
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
659 |
(define (continue-from next-ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
660 |
(set! ip next-ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
661 |
(interpret)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
662 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
663 |
(define (push-and-go next-ip v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
664 |
(push! v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
665 |
(continue-from next-ip)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
666 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
667 |
(define (push-and-continue v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
668 |
(push! v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
669 |
(interpret)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
670 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
671 |
(define (next-byte!) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
672 |
(begin0 (bytes-ref bytecode ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
673 |
(set! ip (+ ip 1)))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
674 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
675 |
(define (decode!) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
676 |
(define byte (next-byte!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
677 |
(define low (bitwise-and byte #x0f)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
678 |
(define high (bitwise-and (arithmetic-shift byte -4) #x0f)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
679 |
(if (zero? high) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
680 |
(values low (next-byte!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
681 |
(values high low))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
682 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
683 |
(define (interpret) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
684 |
(define-values (high low) (decode!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
685 |
(log-vm-debug "> ~a ~a ~a" high low (vector-copy (obj-slots stack) 0 stack-top)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
686 |
(match high |
357 | 687 |
[1 (push-and-continue (slotAt receiver low))] ;; PushInstance |
688 |
[2 (push-and-continue (slotAt arguments low))] ;; PushArgument |
|
689 |
[3 (push-and-continue (slotAt temporaries low))] ;; PushTemporary |
|
690 |
[4 (push-and-continue (slotAt literals low))] ;; PushLiteral |
|
691 |
[5 (match low |
|
692 |
[(or 0 1 2 3 4 5 6 7 8 9) (push-and-continue low)] |
|
693 |
[10 (push-and-continue (VM-nil vm))] |
|
694 |
[11 (push-and-continue (VM-true vm))] |
|
695 |
[12 (push-and-continue (VM-false vm))])] |
|
696 |
[6 (slotAtPut receiver low (peek)) (interpret)] ;; AssignInstance |
|
697 |
[7 (slotAtPut temporaries low (peek)) (interpret)] ;; AssignTemporary |
|
698 |
[8 (push-and-continue (pop-multiple! low))] ;; MarkArguments |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
699 |
[9 ;; SendMessage |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
700 |
(define new-arguments (pop!)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
701 |
(store-registers! ctx ip 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
|
702 |
(send-message vm ctx new-arguments (slotAt literals low))] |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
703 |
|
357 | 704 |
[10 (match low |
705 |
[0 (push-and-continue (boolean->obj vm (eq? (VM-nil vm) (pop!))))] ;; isNil |
|
706 |
[1 (push-and-continue (boolean->obj vm (not (eq? (VM-nil vm) (pop!)))))])] ;; notNil |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
707 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
708 |
[11 ;; SendBinary |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
709 |
(define j (pop!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
710 |
(define i (pop!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
711 |
(if (and (number? i) (number? j)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
712 |
(match low |
357 | 713 |
[0 (push-and-continue (boolean->obj vm (< i j)))] |
714 |
[1 (push-and-continue (boolean->obj vm (<= i j)))] |
|
715 |
[2 (push-and-continue (+ i j))]) ;; TODO: overflow to bignum arithmetic |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
716 |
(let ((new-arguments (mkobj (VM-Array vm) i j)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
717 |
(selector (match low |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
718 |
[0 (mkbv (VM-nil vm) #"<")] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
719 |
[1 (mkbv (VM-nil vm) #"<=")] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
720 |
[2 (mkbv (VM-nil 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
|
721 |
(store-registers! ctx ip 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
|
722 |
(send-message vm ctx new-arguments selector)))] |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
723 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
724 |
[12 ;; PushBlock |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
725 |
(define target (next-byte!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
726 |
(log-vm-debug "pushblock; temporaries = ~a" temporaries) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
727 |
(push-and-go target |
357 | 728 |
(mkobj (VM-Block vm) method arguments temporaries stack ip 0 previous-ctx low ctx ip))] |
729 |
||
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
730 |
[13 ;; Primitive; low = arg count; next byte = primitive number |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
731 |
(define primitive-number (next-byte!)) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
732 |
(log-vm-debug "primitive ~a (arg count = ~a)" primitive-number low) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
733 |
(match primitive-number |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
734 |
[8 ;; block invocation |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
735 |
(define block (pop!)) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
736 |
(define argument-location (slotAt block 7)) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
737 |
(define argument-count (- low 1)) ;; one of the primitive args is the block itself |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
738 |
(for [(i argument-count)] |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
739 |
(slotAtPut (slotAt block 2) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
740 |
(+ argument-location i) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
741 |
(slotAt stack (+ (- stack-top argument-count) i)))) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
742 |
(set! stack-top (- stack-top argument-count)) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
743 |
(store-registers! ctx ip stack-top) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
744 |
(execute vm (mkobj (VM-Context vm) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
745 |
(slotAt block 0) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
746 |
(slotAt block 1) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
747 |
(slotAt block 2) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
748 |
(mkarray vm (slotCount (slotAt block 3))) ;; new stack (!) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
749 |
(slotAt block 9) ;; starting IP |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
750 |
0 ;; stack top |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
751 |
(slotAt ctx 6) ;; previous context |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
752 |
(slotAt block 7) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
753 |
(slotAt block 8) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
754 |
(slotAt block 9)))] |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
755 |
[34 (VM-nil vm)] ;; "thread kill" |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
756 |
[35 (push-and-continue ctx)] |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
757 |
[36 (push-and-continue (pop-multiple! low))] ;; "fast array creation" |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
758 |
|
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
759 |
[_ (define args (pop-multiple! low)) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
760 |
(push-and-continue (perform-primitive vm primitive-number args))])] |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
761 |
|
357 | 762 |
[14 (push-and-continue (slotAt (obj-class* vm receiver) (+ low 5)))] ;; PushClassVariable |
763 |
[15 ;; Do Special |
|
764 |
(match low |
|
765 |
[1 (resume-context vm previous-ctx receiver)] |
|
766 |
[2 (resume-context vm previous-ctx (pop!))] |
|
767 |
[3 (resume-context vm (slotAt (slotAt ctx 8) 6) (pop!))] |
|
768 |
[4 (push-and-continue (peek))] |
|
769 |
[5 (pop!) (interpret)] |
|
770 |
[6 (continue-from (next-byte!))] |
|
771 |
[7 ;; branch if true |
|
772 |
(define target (next-byte!)) |
|
773 |
(if (eq? (pop!) (VM-true vm)) |
|
774 |
(continue-from target) |
|
775 |
(interpret))] |
|
776 |
[8 ;; branch if false |
|
777 |
(define target (next-byte!)) |
|
778 |
(if (eq? (pop!) (VM-false vm)) |
|
779 |
(continue-from target) |
|
780 |
(interpret))] |
|
781 |
[11 ;; send to super |
|
782 |
(define selector (slotAt literals (next-byte!))) |
|
783 |
(define new-arguments (pop!)) |
|
784 |
(define defining-class (slotAt method 5)) ;; method's defining class |
|
785 |
(define super (slotAt defining-class 1)) ;; defining class's superclass |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
786 |
(store-registers! ctx ip 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
|
787 |
(send-message* vm ctx new-arguments super selector)])])) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
788 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
789 |
(interpret)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
790 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
791 |
(define *primitive-handlers* (make-hash)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
792 |
(define *primitive-code-snippets* (make-hash)) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
793 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
794 |
(define-syntax-rule (define-primitive vm [n arg-pat ...] body ...) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
795 |
(begin (hash-set! *primitive-handlers* |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
796 |
n |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
797 |
(lambda (vm args) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
798 |
(match (obj-slots args) [(vector arg-pat ...) (let () body ...)]))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
799 |
(hash-set! *primitive-code-snippets* |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
800 |
n |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
801 |
(lambda (vm-exp arg-exps) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
802 |
`(match* [,vm-exp ,@arg-exps] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
803 |
[[vm arg-pat ...] (let () body ...)]))))) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
804 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
805 |
(define (perform-primitive vm primitive-number args) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
806 |
((hash-ref *primitive-handlers* |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
807 |
primitive-number |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
808 |
(lambda () (error 'perform-primitive "Unimplemented primitive: ~a args: ~a" |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
809 |
primitive-number |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
810 |
(obj-slots args)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
811 |
vm args)) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
812 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
813 |
;;=========================================================================== |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
814 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
815 |
(define-primitive vm [1 b a] (boolean->obj vm (eq? a b))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
816 |
(define-primitive vm [2 x] (obj-class* vm x)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
817 |
(define-primitive vm [4 o] (cond [(bv? o) (bytes-length (bv-bytes o))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
818 |
[(obj? o) (slotCount o)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
819 |
[(number? o) 0] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
820 |
[else (error 'execute "Primitive 4 failed")])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
821 |
(define-primitive vm [5 value target index] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
822 |
(slotAtPut target (- index 1) value) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
823 |
target) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
824 |
(define-primitive vm [6 inner-ctx] ;; "new context execute" |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
825 |
(execute vm inner-ctx)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
826 |
(define-primitive vm [7 class count] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
827 |
(obj class (make-vector count (VM-nil vm)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
828 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
829 |
(define-primitive vm [10 b a] (+ a b)) ;; TODO: overflow |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
830 |
(define-primitive vm [11 n d] (quotient n d)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
831 |
(define-primitive vm [12 n d] (modulo n d)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
832 |
(define-primitive vm [14 b a] (boolean->obj vm (= a b))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
833 |
(define-primitive vm [15 b a] (* a b)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
834 |
(define-primitive vm [16 a b] (- a b)) ;; NB. ordering |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
835 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
836 |
(define-primitive vm [18 v] (log-vm-info "DEBUG: value ~v class ~v" v (obj-class* vm v))) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
837 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
838 |
(define-primitive vm [20 class count] (mkbv class (make-bytes count))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
839 |
(define-primitive vm [21 source index] (bytes-ref (bv-bytes source) (- index 1))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
840 |
(define-primitive vm [22 value target index] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
841 |
(bytes-set! (bv-bytes target) (- index 1) value) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
842 |
target) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
843 |
(define-primitive vm [24 (unbv b) (unbv* av a)] (mkbv (obj-class av) (bytes-append a b))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
844 |
(define-primitive vm [26 (unbv a) (unbv b)] ;; NB. ordering |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
845 |
(cond [(bytes<? a b) -1] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
846 |
[(bytes=? a b) 0] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
847 |
[(bytes>? a b) 1])) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
848 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
849 |
(define-primitive vm [30 source index] (slotAt source (- index 1))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
850 |
(define-primitive vm [31 v o] (obj (obj-class o) (vector-append (obj-slots o) (vector v)))) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
851 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
852 |
(define-primitive vm [41 class (unstr filename)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
853 |
(mkffiv class (open-output-file filename #:exists 'replace))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
854 |
(define-primitive vm [42 class (unstr filename)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
855 |
(mkffiv class (open-input-file filename))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
856 |
(define-primitive vm [44 class (unffiv fh)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
857 |
(match (read-bytes-line fh) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
858 |
[(? eof-object?) (VM-nil vm)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
859 |
[bs (mkbv class bs)])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
860 |
|
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
861 |
;;--------------------------------------------------------------------------- |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
862 |
;; GUI |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
863 |
;;--------------------------------------------------------------------------- |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
864 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
865 |
(define-primitive vm [60 class] ;; make window |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
866 |
(log-vm/gui-debug "Creating window") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
867 |
(mkffiv class (new smalltalk-frame% [label "Racket SmallWorld"]))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
868 |
(define-primitive vm [61 (unffiv window) flag] ;; show/hide text window |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
869 |
(log-vm/gui-debug "Show/hide window ~a" (eq? flag (VM-true vm))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
870 |
(send window show (eq? flag (VM-true vm))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
871 |
flag) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
872 |
(define-primitive vm [62 (unffiv* wv window) (unffiv (list _item factory))] ;; set content pane |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
873 |
(log-vm/gui-debug "Set content pane") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
874 |
(factory window) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
875 |
wv) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
876 |
(define-primitive vm [63 (unffiv* wv window) height width] ;; set size |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
877 |
(log-vm/gui-debug "Window resize ~ax~a" width height) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
878 |
(send window resize width height) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
879 |
wv) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
880 |
(define-primitive vm [64 (unffiv* wv window) (unffiv (list _queue-item add-menu-bar-to))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
881 |
;; add menu to window |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
882 |
(define mb (or (send window get-menu-bar) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
883 |
(new menu-bar% [parent window]))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
884 |
(log-vm/gui-debug "Add menu to window") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
885 |
(add-menu-bar-to mb) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
886 |
wv) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
887 |
(define-primitive vm [65 (unffiv* wv window) (unstr text)] ;; set title |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
888 |
(log-vm/gui-debug "Set window title ~v" text) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
889 |
(send window set-label text) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
890 |
wv) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
891 |
(define-primitive vm [66 window] ;; repaint window |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
892 |
;; nothing needed |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
893 |
window) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
894 |
(define-primitive vm [70 class (unstr label)] ;; new label panel |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
895 |
(log-vm/gui-debug "Schedule label panel ~v" label) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
896 |
(define (create-label-in parent) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
897 |
(log-vm/gui-debug "Create label panel ~v" label) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
898 |
(new message% [parent parent] [label label])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
899 |
(mkffiv class (list 'label create-label-in))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
900 |
(define-primitive vm [71 class (unstr label) action] ;; new button |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
901 |
(define callback (block-callback vm action)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
902 |
(log-vm/gui-debug "Schedule button ~v" label) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
903 |
(define (create-button-in parent) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
904 |
(log-vm/gui-debug "Create button ~v" label) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
905 |
(new button% |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
906 |
[label label] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
907 |
[parent parent] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
908 |
[callback (lambda args (queue-callback callback))])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
909 |
(mkffiv class (list 'button create-button-in))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
910 |
(define-primitive vm [72 class] ;; new text line |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
911 |
(log-vm/gui-debug "Schedule textfield") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
912 |
(define textfield-editor #f) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
913 |
(define (add-textfield-to parent) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
914 |
(set! textfield-editor (send (new text-field% [label #f] [parent parent]) get-editor)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
915 |
textfield-editor) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
916 |
(mkffiv class (list (lambda () textfield-editor) add-textfield-to))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
917 |
(define-primitive vm [73 class] ;; new text area |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
918 |
(log-vm/gui-debug "Schedule textarea") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
919 |
(define editor (new text%)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
920 |
(define (add-editor-to frame) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
921 |
(log-vm/gui-debug "Create textarea") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
922 |
(new editor-canvas% [parent frame] [editor editor])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
923 |
(mkffiv class (list (lambda () editor) add-editor-to))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
924 |
(define-primitive vm [74 class width height data] ;; new grid panel |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
925 |
(log-vm/gui-debug "Schedule grid panel ~ax~a ~a" width height data) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
926 |
(define (create-grid-in parent) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
927 |
(log-vm/gui-debug "Create grid panel ~ax~a ~a" width height data) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
928 |
(define vp (new vertical-pane% [parent parent])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
929 |
(for [(row height)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
930 |
(define hp (new horizontal-pane% [parent vp])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
931 |
(for [(col width)] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
932 |
(define i (+ col (* row width))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
933 |
(when (< i (slotCount data)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
934 |
(match (slotAt data i) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
935 |
[(unffiv (list _ factory)) (factory hp)])))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
936 |
vp) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
937 |
(mkffiv class (list 'grid create-grid-in))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
938 |
(define-primitive vm [75 class data action] ;; new list panel |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
939 |
(define callback (block-callback vm action)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
940 |
(log-vm/gui-debug "Schedule listpanel ~a" data) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
941 |
(define lb #f) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
942 |
(define old-selection #f) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
943 |
(define (create-list-panel-in parent) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
944 |
(log-vm/gui-debug "Create listpanel ~a" data) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
945 |
(set! lb (new list-box% |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
946 |
[label #f] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
947 |
[parent parent] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
948 |
[choices (for/list [(c (obj-slots data))] (bv->string c))] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
949 |
[callback (lambda _args |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
950 |
(log-vm/gui-debug "_args: ~v for listpanel ~a" |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
951 |
_args |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
952 |
(eq-hash-code lb)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
953 |
(define selection (send lb get-selection)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
954 |
(when (not (equal? old-selection selection)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
955 |
(set! old-selection selection) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
956 |
(queue-callback |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
957 |
(lambda () |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
958 |
(log-vm/gui-debug "Item selected ~v" selection) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
959 |
(callback (if selection (+ selection 1) 0))))))])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
960 |
(log-vm/gui-debug "The result is ~a" (eq-hash-code lb)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
961 |
lb) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
962 |
(mkffiv class (list (lambda () lb) create-list-panel-in))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
963 |
(define-primitive vm [76 class north south east west center] ;; new border panel |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
964 |
(log-vm/gui-debug "Schedule borderpanel") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
965 |
(define (add-w w p) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
966 |
(when (not (eq? (VM-nil vm) w)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
967 |
(match w [(unffiv (list _ factory)) (factory p)]))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
968 |
(define (create-border-panel-in parent) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
969 |
(log-vm/gui-debug "Create borderpanel") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
970 |
(define vp (new vertical-pane% [parent parent])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
971 |
(add-w north vp) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
972 |
(when (for/or [(w (list west center east))] (not (eq? (VM-nil vm) w))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
973 |
(define hp (new horizontal-pane% [parent vp])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
974 |
(add-w west hp) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
975 |
(add-w center hp) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
976 |
(add-w east hp)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
977 |
(add-w south vp) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
978 |
vp) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
979 |
(mkffiv class (list 'border-panel create-border-panel-in))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
980 |
(define-primitive vm [80 class (unffiv (list get-textarea _factory))] ;; content of text area |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
981 |
(mkbv class (string->bytes/utf-8 (send (get-textarea) get-text)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
982 |
(define-primitive vm [81 class (unffiv (list get-textarea _factory))] ;; content of selected text area |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
983 |
(define start (box 0)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
984 |
(define end (box 0)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
985 |
(send (get-textarea) get-position start end) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
986 |
(define has-selection (not (= (unbox start) (unbox end)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
987 |
(mkbv class |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
988 |
(string->bytes/utf-8 (send (get-textarea) get-text |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
989 |
(if has-selection (unbox start) 0) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
990 |
(if has-selection (unbox end) 'eof))))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
991 |
(define-primitive vm [82 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set text area |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
992 |
(log-vm/gui-debug "Update textarea ~v" text) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
993 |
(send (get-textarea) erase) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
994 |
(send (get-textarea) insert text) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
995 |
textv) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
996 |
(define-primitive vm [83 (unffiv (list get-lb _factory))] ;; get selected index |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
997 |
(log-vm/gui-debug "Get selected index") |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
998 |
(define lb (get-lb)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
999 |
(define s (send lb get-selection)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1000 |
(if s (+ s 1) 0)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1001 |
(define-primitive vm [84 (unffiv* lbv (list get-lb _factory)) data] ;; set list data |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1002 |
(define lb (get-lb)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1003 |
(log-vm/gui-debug "Update list ~a data ~v" (eq-hash-code lb) data) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1004 |
(send lb set (for/list [(c (obj-slots data))] (bv->string c))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1005 |
lbv) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1006 |
(define-primitive vm [89 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set selected text area |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1007 |
(define start (box 0)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1008 |
(define end (box 0)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1009 |
(send (get-textarea) get-position start end) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1010 |
(define has-selection (not (= (unbox start) (unbox end)))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1011 |
(if has-selection |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1012 |
(send (get-textarea) insert text (unbox start) (unbox end)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1013 |
(begin (send (get-textarea) erase) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1014 |
(send (get-textarea) insert text))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1015 |
textv) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1016 |
(define-primitive vm [90 class (unstr title)] ;; new menu |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1017 |
(define pending-items '()) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1018 |
(define (queue-item i) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1019 |
(set! pending-items (cons i pending-items))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1020 |
(define (add-menu-bar-to frame) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1021 |
(define m (new menu% [parent frame] [label title])) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1022 |
(for [(i (reverse pending-items))] (i m)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1023 |
m) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1024 |
(mkffiv class (list queue-item add-menu-bar-to))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1025 |
(define-primitive vm [91 (unffiv* menu (list queue-item _add-menu-bar-to)) (unstr title) action] ;; new menu item |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1026 |
(define callback (block-callback vm action)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1027 |
(queue-item (lambda (m) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1028 |
(new menu-item% |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1029 |
[label title] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1030 |
[parent m] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1031 |
[callback (lambda args (queue-callback callback))]))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1032 |
menu) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1033 |
(define-primitive vm [100 class] (mkffiv class (oneshot))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1034 |
(define-primitive vm [101 (unffiv o)] (oneshot-ref o)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1035 |
(define-primitive vm [102 (unffiv o) v] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1036 |
(oneshot-set! o v) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1037 |
v) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1038 |
(define-primitive vm [116] |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1039 |
(let ((image-bytes (serialize-image vm))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1040 |
(display-to-file image-bytes (VM-image-filename vm) #:exists 'replace))) |
381
2a18c578bc8f
Primitive 117 has a dummy argument that I had neglected previously.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
379
diff
changeset
|
1041 |
(define-primitive vm [117 _self] (exit)) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1042 |
(define-primitive vm [118 (unffiv* wv window) action] ;; "onWindow close b" |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1043 |
(define callback (block-callback vm action)) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1044 |
(send window set-close-handler (lambda (_frame) (queue-callback callback) (sleep 0.2))) |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1045 |
wv) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
1046 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1047 |
;;--------------------------------------------------------------------------- |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1048 |
;; END GUI |
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1049 |
;;--------------------------------------------------------------------------- |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
1050 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1051 |
(define-primitive vm [119] (inexact->exact (round (current-inexact-milliseconds)))) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
1052 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
1053 |
;;=========================================================================== |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
1054 |
|
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1055 |
(define (doIt vm task) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1056 |
(define true-class (obj-class (VM-true vm))) ;; class True |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1057 |
(define name (slotAt true-class 0)) ;; "a known string", namely the name of class True |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1058 |
(define string-class (obj-class name)) ;; class String |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1059 |
(define source (mkbv string-class (string->bytes/utf-8 task))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1060 |
(define args (mkobj (VM-Array vm) source)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
1061 |
(send-message vm (VM-nil vm) args (mkbv (VM-nil vm) #"doIt"))) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1062 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
1063 |
(let* ((image-filename "SmallWorld/src/image") |
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
1064 |
(vm (call-with-input-file image-filename (lambda (fh) (read-image image-filename fh))))) |
383
bcad96e920f0
Use log-vm-info instead of printf.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
381
diff
changeset
|
1065 |
(log-vm-info "Sending 'SmallWorld startUp'...") |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1066 |
(thread-wait (thread (lambda () |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1067 |
(define result (doIt vm "SmallWorld startUp")) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1068 |
(log-vm-info "Final startUp result: ~a" result) |
372
1de7be3b9aeb
Support fileIn of files named on command-line
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
370
diff
changeset
|
1069 |
(for [(a (current-command-line-arguments))] |
1de7be3b9aeb
Support fileIn of files named on command-line
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
370
diff
changeset
|
1070 |
(log-vm-info "Filing in ~a" a) |
1de7be3b9aeb
Support fileIn of files named on command-line
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
370
diff
changeset
|
1071 |
(doIt vm (format "(File openRead: '~a') fileIn" a))) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1072 |
(yield)))) |
383
bcad96e920f0
Use log-vm-info instead of printf.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
381
diff
changeset
|
1073 |
(log-vm-info "... terminating.")) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1074 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1075 |
;;; Local Variables: |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1076 |
;;; eval: (put 'primitive-action 'scheme-indent-function 1) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1077 |
;;; End: |