author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Wed, 16 Jan 2019 17:15:58 +0000 | |
changeset 438 | 1fe179d53161 |
parent 426 | 930c499509be |
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) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
8 |
(require "object-memory.rkt") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
9 |
(require "primitives.rkt") |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
10 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
11 |
(define-logger vm) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
12 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
13 |
(struct int-VM VM (cache image-filename) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
14 |
#:methods gen:vm-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
15 |
[(define (vm-block-callback vm block) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
16 |
;; Runs block in a new thread |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
17 |
(lambda args |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
18 |
(let ((ctx (clone-array block))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
19 |
(define argument-location (slotAt ctx 7)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
20 |
(for [(i (in-naturals argument-location)) (arg (in-list args))] |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
21 |
(slotAtPut (slotAt ctx 2) i arg)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
22 |
(slotAtPut ctx 3 (mkarray vm (slotCount (slotAt ctx 3)))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
23 |
(slotAtPut ctx 4 (slotAt ctx 9)) ;; reset IP to correct block offset |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
24 |
(slotAtPut ctx 5 0) ;; zero stack-top |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
25 |
(slotAtPut ctx 6 (VM-nil vm)) ;; no previous context |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
26 |
(thread (lambda () (execute vm ctx))))))]) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
27 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
28 |
(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
|
29 |
(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
|
30 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
31 |
(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
|
32 |
(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
|
33 |
(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
|
34 |
(mkobj (VM-Context vm) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
35 |
method |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
36 |
args |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
37 |
(mkarray vm temp-count) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
38 |
(mkarray vm max-stack) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
39 |
0 ;; IP |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
40 |
0 ;; stack top |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
41 |
previous-context)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
42 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
43 |
(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
|
44 |
(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
|
45 |
(for [(i (in-range count))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
46 |
(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
|
47 |
b) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
48 |
|
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
|
49 |
(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
|
50 |
(define name-bytes (bv-bytes selector)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
51 |
(define class-cache (hash-ref! (int-VM-cache vm) class make-weak-hash)) |
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
|
52 |
(hash-ref! class-cache |
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
|
53 |
name-bytes |
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
|
54 |
(lambda () |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
55 |
(lookup-method vm class (bv-bytes selector))))) |
353
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 |
(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
|
58 |
(slotAtPut ctx 4 ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
59 |
(slotAtPut ctx 5 stack-top)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
60 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
61 |
(define (send-message* vm ctx ip stack-top arguments class selector) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
62 |
(store-registers! ctx ip stack-top) |
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
|
63 |
(match (lookup-method/cache vm class selector) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
64 |
[#f |
368
bd33c8691bba
Simplest possible method cache. hop: 411861 bytecodes/sec; 65707 sends/sec --> 859845 bytecodes/sec; 106388 sends/sec
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
367
diff
changeset
|
65 |
(match (lookup-method/cache vm class (mkbv (obj-class selector) #"doesNotUnderstand:")) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
66 |
[#f |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
67 |
(error 'send-message* "Unhandled selector ~a at class ~a" selector class)] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
68 |
[dnu-method |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
69 |
(log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
70 |
(execute vm (build-context vm |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
71 |
ctx |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
72 |
(mkobj (VM-Array vm) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
73 |
(slotAt arguments 0) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
74 |
(mkobj (VM-Array vm) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
75 |
selector |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
76 |
(clone-array arguments))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
77 |
dnu-method))])] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
78 |
[new-method |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
79 |
(execute vm (build-context vm ctx arguments new-method))])) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
80 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
81 |
(define (send-message vm ctx ip stack-top arguments selector) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
82 |
(log-vm-debug "sending: ~a ~a" selector arguments) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
83 |
(send-message* vm ctx ip stack-top arguments (obj-class* vm (slotAt arguments 0)) selector)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
84 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
85 |
(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
|
86 |
(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
|
87 |
result |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
88 |
(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
|
89 |
(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
|
90 |
(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
|
91 |
(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
|
92 |
(execute vm ctx)))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
93 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
94 |
(define (execute vm ctx) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
95 |
(define method (slotAt ctx 0)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
96 |
(define arguments (slotAt ctx 1)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
97 |
(define temporaries (slotAt ctx 2)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
98 |
(define stack (slotAt ctx 3)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
99 |
(define ip (slotAt ctx 4)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
100 |
(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
|
101 |
(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
|
102 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
103 |
(define receiver (slotAt arguments 0)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
104 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
105 |
(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
|
106 |
(define literals (slotAt method 2)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
107 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
108 |
(define (push! v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
109 |
(slotAtPut stack stack-top v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
110 |
(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
|
111 |
(define (pop!) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
112 |
(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
|
113 |
(slotAt stack stack-top)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
114 |
(define (peek) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
115 |
(slotAt stack (- stack-top 1))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
116 |
|
357 | 117 |
(define (pop-multiple! count) |
118 |
(set! stack-top (- stack-top count)) |
|
119 |
(clone-array stack stack-top count)) |
|
120 |
||
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
121 |
(define (continue-from next-ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
122 |
(set! ip next-ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
123 |
(interpret)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
124 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
125 |
(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
|
126 |
(push! v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
127 |
(continue-from next-ip)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
128 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
129 |
(define (push-and-continue v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
130 |
(push! v) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
131 |
(interpret)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
132 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
133 |
(define (next-byte!) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
134 |
(begin0 (bytes-ref bytecode ip) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
135 |
(set! ip (+ ip 1)))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
136 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
137 |
(define (decode!) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
138 |
(define byte (next-byte!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
139 |
(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
|
140 |
(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
|
141 |
(if (zero? high) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
142 |
(values low (next-byte!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
143 |
(values high low))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
144 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
145 |
(define (interpret) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
146 |
(define-values (high low) (decode!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
147 |
(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
|
148 |
(match high |
357 | 149 |
[1 (push-and-continue (slotAt receiver low))] ;; PushInstance |
150 |
[2 (push-and-continue (slotAt arguments low))] ;; PushArgument |
|
151 |
[3 (push-and-continue (slotAt temporaries low))] ;; PushTemporary |
|
152 |
[4 (push-and-continue (slotAt literals low))] ;; PushLiteral |
|
153 |
[5 (match low |
|
154 |
[(or 0 1 2 3 4 5 6 7 8 9) (push-and-continue low)] |
|
155 |
[10 (push-and-continue (VM-nil vm))] |
|
156 |
[11 (push-and-continue (VM-true vm))] |
|
157 |
[12 (push-and-continue (VM-false vm))])] |
|
158 |
[6 (slotAtPut receiver low (peek)) (interpret)] ;; AssignInstance |
|
159 |
[7 (slotAtPut temporaries low (peek)) (interpret)] ;; AssignTemporary |
|
160 |
[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
|
161 |
[9 ;; SendMessage |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
162 |
(define new-arguments (pop!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
163 |
(send-message vm ctx ip stack-top new-arguments (slotAt literals low))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
164 |
|
357 | 165 |
[10 (match low |
166 |
[0 (push-and-continue (boolean->obj vm (eq? (VM-nil vm) (pop!))))] ;; isNil |
|
167 |
[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
|
168 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
169 |
[11 ;; SendBinary |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
170 |
(define j (pop!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
171 |
(define i (pop!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
172 |
(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
|
173 |
(match low |
357 | 174 |
[0 (push-and-continue (boolean->obj vm (< i j)))] |
175 |
[1 (push-and-continue (boolean->obj vm (<= i j)))] |
|
176 |
[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
|
177 |
(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
|
178 |
(selector (match low |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
179 |
[0 (mkbv (VM-nil vm) #"<")] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
180 |
[1 (mkbv (VM-nil vm) #"<=")] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
181 |
[2 (mkbv (VM-nil vm) #"+")]))) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
182 |
(send-message vm ctx ip stack-top new-arguments selector)))] |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
183 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
184 |
[12 ;; PushBlock |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
185 |
(define target (next-byte!)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
186 |
(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
|
187 |
(push-and-go target |
357 | 188 |
(mkobj (VM-Block vm) method arguments temporaries stack ip 0 previous-ctx low ctx ip))] |
189 |
||
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
190 |
[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
|
191 |
(define primitive-number (next-byte!)) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
192 |
(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
|
193 |
(match primitive-number |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
194 |
[8 ;; block invocation |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
195 |
(define block (pop!)) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
196 |
(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
|
197 |
(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
|
198 |
(for [(i argument-count)] |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
199 |
(slotAtPut (slotAt block 2) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
200 |
(+ argument-location i) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
201 |
(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
|
202 |
(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
|
203 |
(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
|
204 |
(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
|
205 |
(slotAt block 0) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
206 |
(slotAt block 1) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
207 |
(slotAt block 2) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
208 |
(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
|
209 |
(slotAt block 9) ;; starting IP |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
210 |
0 ;; stack top |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
211 |
(slotAt ctx 6) ;; previous context |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
212 |
(slotAt block 7) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
213 |
(slotAt block 8) |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
214 |
(slotAt block 9)))] |
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
215 |
[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
|
216 |
[35 (push-and-continue ctx)] |
438
1fe179d53161
Add missing primitive implementation for the plain interpreter.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
426
diff
changeset
|
217 |
[36 (push-and-continue (pop-multiple! low))] |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
218 |
|
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
219 |
[_ (define args (pop-multiple! low)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
220 |
(define handler (hash-ref *primitive-handlers* primitive-number)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
221 |
(push-and-continue (handler vm args))])] |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
222 |
|
357 | 223 |
[14 (push-and-continue (slotAt (obj-class* vm receiver) (+ low 5)))] ;; PushClassVariable |
224 |
[15 ;; Do Special |
|
225 |
(match low |
|
226 |
[1 (resume-context vm previous-ctx receiver)] |
|
227 |
[2 (resume-context vm previous-ctx (pop!))] |
|
228 |
[3 (resume-context vm (slotAt (slotAt ctx 8) 6) (pop!))] |
|
229 |
[4 (push-and-continue (peek))] |
|
230 |
[5 (pop!) (interpret)] |
|
231 |
[6 (continue-from (next-byte!))] |
|
232 |
[7 ;; branch if true |
|
233 |
(define target (next-byte!)) |
|
234 |
(if (eq? (pop!) (VM-true vm)) |
|
235 |
(continue-from target) |
|
236 |
(interpret))] |
|
237 |
[8 ;; branch if false |
|
238 |
(define target (next-byte!)) |
|
239 |
(if (eq? (pop!) (VM-false vm)) |
|
240 |
(continue-from target) |
|
241 |
(interpret))] |
|
242 |
[11 ;; send to super |
|
243 |
(define selector (slotAt literals (next-byte!))) |
|
244 |
(define new-arguments (pop!)) |
|
245 |
(define defining-class (slotAt method 5)) ;; method's defining class |
|
246 |
(define super (slotAt defining-class 1)) ;; defining class's superclass |
|
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
247 |
(send-message* vm ctx ip stack-top new-arguments super selector)])])) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
248 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
249 |
(interpret)) |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
250 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
251 |
;;=========================================================================== |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
252 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
253 |
(define-primitive vm [6 inner-ctx] ;; "new context execute" |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
254 |
(execute vm inner-ctx)) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
255 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
256 |
(define-primitive vm [116] (save-image-to-file vm (int-VM-image-filename vm))) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
257 |
|
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
258 |
;;=========================================================================== |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
259 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
260 |
(let* ((image-filename "SmallWorld/src/image") |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
261 |
(vm (call-with-input-file image-filename |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
262 |
(lambda (fh) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
263 |
(read-image fh int-VM (list (make-weak-hasheq) image-filename)))))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
264 |
(boot-image vm |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
265 |
(lambda (vm source) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
266 |
(define args (mkobj (VM-Array vm) source)) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
267 |
(define doIt-method (search-class-method-dictionary (obj-class source) #"doIt")) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
268 |
(when (not doIt-method) (error 'doIt "Can't find doIt method via class True etc")) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
269 |
(execute vm (build-context vm (VM-nil vm) args doIt-method))) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
270 |
(current-command-line-arguments))) |