author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
Sun, 29 Jul 2018 18:06:07 +0100 | |
changeset 426 | 930c499509be |
parent 425 | a7f739fa4dee |
child 428 | a94fb6aff9ef |
permissions | -rw-r--r-- |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
1 |
#lang racket/gui |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
2 |
;; Loader for images (version 1 format) from Russell Allen's 2015 |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
3 |
;; variant of SmallWorld, a Tim Budd-authored Little Smalltalk |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
4 |
;; descendant. |
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
5 |
|
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
6 |
(require racket/bytes) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
7 |
(require (only-in sha bytes->hex-string)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
8 |
(require "object-memory.rkt") |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
9 |
(require "primitives.rkt") |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
10 |
|
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
11 |
(define-logger vm) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
12 |
(define-logger vm/jit) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
13 |
(define-logger vm/jit/code) |
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
14 |
(define-logger vm/jit/recompile) |
419
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
15 |
(define-logger vm/jit/recompile/candidates) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
16 |
|
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
17 |
;; Runtime support: We use `eval` with namespace `ns` to allow |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
18 |
;; generated code to access bindings in this module. |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
19 |
(define-namespace-anchor ns-anchor) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
20 |
(define ns (namespace-anchor->namespace ns-anchor)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
21 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
22 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
23 |
;; Structures |
395
3979401d44c1
Introduce struct mic
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
394
diff
changeset
|
24 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
25 |
(struct pe-VM VM (cache image-filename) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
26 |
#:methods gen:vm-callback |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
27 |
[(define (vm-block-callback vm action) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
28 |
;; Runs action in a new thread |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
29 |
(lambda args |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
30 |
(thread (match action |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
31 |
[(unffiv block-proc) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
32 |
(lambda () (apply block-proc (outermost-k vm) args))] |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
33 |
[_ |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
34 |
(block->thunk vm action args)]))))]) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
35 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
36 |
;; Just as the plain interpreter, `run-SmallWorld-2015.rkt`, builds |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
37 |
;; contexts at runtime describing a method activation, the JIT builds |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
38 |
;; contexts at compile time describing a method activation. |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
39 |
;; |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
40 |
;; Each context includes accumulator registers shared among all |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
41 |
;; contexts inlined into the top-level method being compiled, as well |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
42 |
;; as registers particular to itself. |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
43 |
;; |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
44 |
;; Runtime contexts include these registers: |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
45 |
;; - method, the bytecoded method being interpreted |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
46 |
;; - arguments, an Array of arguments to this activation |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
47 |
;; - temporaries, an Array of temporaries for this activation |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
48 |
;; - stack, an Array of size (slotAt method 3), an empty ascending stack |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
49 |
;; - ip, an index into `method`'s bytecode |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
50 |
;; - stack-top, an index into `stack` |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
51 |
;; - previous-ctx, either nil or a reference to a calling context |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
52 |
;; |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
53 |
;; Our contexts will include compile-time analogues of these. Almost |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
54 |
;; everywhere that a runtime context refers to a value, our |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
55 |
;; compile-time contexts will refer to an abstract value instead. |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
56 |
;; |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
57 |
;; Each context includes: |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
58 |
;; - vm, the compile-time vm |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
59 |
;; - method, a concrete value |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
60 |
;; - arguments, a Racket vector of abstract-values |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
61 |
;; - temporaries, a symbol naming the Racket-level temporaries vector |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
62 |
;; - stack, a Racket list of abstract-values; car = top of stack |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
63 |
;; - ip, a Racket number |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
64 |
;; - labels, a hashtable of code fragments roughly corresponding to basic blocks |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
65 |
;; - previous, the next context in the chain |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
66 |
;; - home, #f for non-blocks, otherwise the home context of a block |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
67 |
;; - state, accumulator registers |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
68 |
;; |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
69 |
;; The accumulator registers are: |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
70 |
;; - litmap, a Racket mutable hash table mapping actual runtime |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
71 |
;; values to compile-time variable names (symbols) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
72 |
;; - pic-list-rev, a Racket list of symbols naming PICs in the |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
73 |
;; compiled method |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
74 |
;; - old-picmap, either #f or a hash indexing PICs from a previous |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
75 |
;; compilation, for dynamic type feedback |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
76 |
;; - histories, a Racket parameter holding a list of lists of |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
77 |
;; `definition` structures |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
78 |
;; |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
79 |
(struct DynamicCtx (var) #:transparent) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
80 |
(struct Ctx (vm method arguments temporaries stack ip labels previous home state) #:transparent |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
81 |
#:methods gen:custom-write |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
82 |
[(define (write-proc c port mode) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
83 |
(fprintf port "#<~a>" (format-Ctx c)))]) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
84 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
85 |
(struct State (litmap [pic-list-rev #:mutable] old-picmap histories) #:transparent) |
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
diff
changeset
|
86 |
|
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
87 |
(struct compiled-method-info (bytecode-method pics stable?)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
88 |
|
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
89 |
(struct cached-method (class name-bytes [bytecode-method #:mutable] [proc #:mutable])) |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
90 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
91 |
(struct definition (var purity absval) #:transparent) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
92 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
93 |
(struct AbsVal (expr desc) #:transparent) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
94 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
95 |
(struct Unknown ()) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
96 |
(struct Constant (value) #:transparent) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
97 |
(struct Obj (class slots) #:transparent) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
98 |
(struct Bv Obj (bytes) #:transparent) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
99 |
(struct Ffiv Obj (value) #:transparent) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
100 |
|
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
101 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
102 |
;; Polymorphic Inline Caches - PICs |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
103 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
104 |
(define pic-reserved 0) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
105 |
(define pic-entry-count 3) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
106 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
107 |
(define (pic) ;; pic-entry-count ×3 - class, method, and count. |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
108 |
(vector #f #f 0 |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
109 |
#f #f 0 |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
110 |
#f #f 0)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
111 |
(define (extended-pic c0 m0 c1 m1 c2 m2) ;; normal pic plus previous knowledge |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
112 |
(vector #f #f 0 #f #f 0 #f #f 0 |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
113 |
c0 m0 0 c1 m1 0 c2 m2 0)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
114 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
115 |
(define (pic-size pic) (quotient (- (vector-length pic) pic-reserved) pic-entry-count)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
116 |
(define (pic@ pic index offset) (vector-ref pic (+ pic-reserved offset (* index 3)))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
117 |
(define (pic@! pic index offset v) (vector-set! pic (+ pic-reserved offset (* index 3)) v)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
118 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
119 |
(define (pic-bump! pic index) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
120 |
(define o (+ pic-reserved 2 (* index 3))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
121 |
(vector-set! pic o (+ 1 (vector-ref pic o)))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
122 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
123 |
(define empty-pic-extension (for/list [(i (in-range pic-entry-count))] '(#f #f))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
124 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
125 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
126 |
;; Dynamic Deoptimization |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
127 |
|
415
3d1ae8f1b0d7
Avoid passing around a literal stack length, when it's implicit
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
414
diff
changeset
|
128 |
(define (build-jit-context vm previous-context args method ip temporaries stack) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
129 |
;; TODO: build block contexts instead of just pretending everything is a method... |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
130 |
(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
|
131 |
(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
|
132 |
method |
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
133 |
(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
|
134 |
(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
|
135 |
(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
|
136 |
(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
|
137 |
ip |
415
3d1ae8f1b0d7
Avoid passing around a literal stack length, when it's implicit
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
414
diff
changeset
|
138 |
(vector-length 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
|
139 |
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
|
140 |
|
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
141 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
142 |
;; Method cache; relationship between bytecoded and compiled methods |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
143 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
144 |
(define (lookup-method/cache vm class name-bytes) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
145 |
(define class-cache (hash-ref! (pe-VM-cache vm) class make-weak-hash)) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
146 |
(hash-ref! class-cache |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
147 |
name-bytes |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
148 |
(lambda () (cached-method class name-bytes #f #f)))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
149 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
150 |
(define (bytecode->cached-compiled vm class method) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
151 |
(lookup-method/cache vm class (bv-bytes (slotAt method 0)))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
152 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
153 |
(define (compiled->bytecode cmethod) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
154 |
(compiled-method-info-bytecode-method (cmethod))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
155 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
156 |
(define (unwrap-cached-method vm cm) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
157 |
(or (cached-method-proc cm) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
158 |
(match cm |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
159 |
[(cached-method class name-bytes _bcm _proc) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
160 |
(define bcm (lookup-method vm class name-bytes)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
161 |
(define proc (and bcm (compile-method-proc vm class bcm #f))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
162 |
(set-cached-method-bytecode-method! cm bcm) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
163 |
(set-cached-method-proc! cm proc) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
164 |
proc]))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
165 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
166 |
(define (invalidate-cached-method! cm) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
167 |
(set-cached-method-bytecode-method! cm #f) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
168 |
(set-cached-method-proc! cm #f)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
169 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
170 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
171 |
;; Runtime method lookup via PIC |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
172 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
173 |
(define (lookup-message/jit vm pic class selector) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
174 |
(let search-pic ((slot-index 0)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
175 |
(define this-class (pic@ pic slot-index 0)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
176 |
(if (eq? this-class class) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
177 |
(begin (pic-bump! pic slot-index) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
178 |
(or (unwrap-cached-method vm (pic@ pic slot-index 1)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
179 |
(send-dnu vm class selector))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
180 |
(let* ((next-slot-index (+ slot-index 1)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
181 |
(more-slots-to-check? (and this-class (< next-slot-index pic-entry-count)))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
182 |
(if more-slots-to-check? |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
183 |
(search-pic next-slot-index) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
184 |
(let* ((cm (lookup-method/cache vm class (bv-bytes selector)))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
185 |
(when (not this-class) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
186 |
(pic@! pic slot-index 0 class) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
187 |
(pic@! pic slot-index 1 cm) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
188 |
(pic@! pic slot-index 2 1)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
189 |
(or (unwrap-cached-method vm cm) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
190 |
(send-dnu vm class selector)))))))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
191 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
192 |
(define ((send-dnu vm class selector) ctx . args) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
193 |
(define arguments (obj (VM-Array vm) (list->vector args))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
194 |
(define dnu-name-bytes #"doesNotUnderstand:") |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
195 |
(match (unwrap-cached-method vm (lookup-method/cache vm class dnu-name-bytes)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
196 |
[#f (error 'send-message* "Unhandled selector ~a at class ~a" selector class)] |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
197 |
[dnu-method |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
198 |
(log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
199 |
(dnu-method ctx (slotAt arguments 0) (mkobj (VM-Array vm) selector arguments))])) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
200 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
201 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
202 |
;; Compilation State |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
203 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
204 |
(define (top-compilation vm receiver-class method old-picmap top-k) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
205 |
(define litmap (make-hasheq)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
206 |
(Ctx-log 'top-compilation |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
207 |
(Ctx vm |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
208 |
method |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
209 |
(for/vector [(i (selector-string-arity (method-name method)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
210 |
(if (zero? i) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
211 |
(AbsVal 'self (Obj (gen-lit litmap receiver-class) #f)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
212 |
(AbsVal (mksym "arg~a" (- i 1)) (Unknown)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
213 |
(gensym 'temps) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
214 |
'() |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
215 |
0 |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
216 |
(make-hash) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
217 |
(DynamicCtx top-k) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
218 |
#f |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
219 |
(State litmap |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
220 |
'() |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
221 |
old-picmap |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
222 |
(make-parameter '()))))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
223 |
|
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
224 |
(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
|
225 |
(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
|
226 |
(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
|
227 |
[(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
|
228 |
[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
|
229 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
230 |
(define (mksym fmt . args) (string->symbol (apply format fmt args))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
231 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
232 |
(define (Ctx-log who c) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
233 |
(log-vm/jit/code-debug "~a ~a ~adefined in ~v (depth ~a)" |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
234 |
who |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
235 |
(Ctx-name c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
236 |
(if (Ctx-home c) "(BLOCK) " "") |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
237 |
(slotAt (Ctx-method c) 5) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
238 |
(Ctx-depth c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
239 |
(log-vm/jit/code-debug " bytecode: ~a\n----\n~a\n----" |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
240 |
(bytes->hex-string (bv-bytes (slotAt (Ctx-method c) 1))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
241 |
(bv->string (slotAt (Ctx-method c) 6))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
242 |
c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
243 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
244 |
(define (inline-compilation vm method actual-avs temporaries ip previous home state) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
245 |
(Ctx-log 'inline-compilation |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
246 |
(Ctx vm |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
247 |
method |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
248 |
actual-avs |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
249 |
(or temporaries (gensym (format "temps~a" (method-name method)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
250 |
'() |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
251 |
ip |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
252 |
(make-hash) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
253 |
previous |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
254 |
home |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
255 |
state))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
256 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
257 |
(define (Ctx-depth c) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
258 |
(if (DynamicCtx? c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
259 |
0 |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
260 |
(+ 1 (Ctx-depth (Ctx-previous c))))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
261 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
262 |
(define (Ctx-arg c n) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
263 |
(vector-ref (Ctx-arguments c) n)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
264 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
265 |
(define (Ctx-receiver c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
266 |
(Ctx-arg c 0)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
267 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
268 |
(define (Ctx-receiver-class c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
269 |
(Constant-value (AbsVal-desc (ObjClass (Ctx-vm c) (Ctx-receiver c))))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
270 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
271 |
(define (Ctx-name c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
272 |
(method-name (Ctx-method c) (Ctx-receiver-class c))) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
273 |
|
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
274 |
(define (already-compiling? c class method) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
275 |
(let check ((c c)) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
276 |
(cond [(DynamicCtx? c) #f] |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
277 |
[(and (eq? (Ctx-receiver-class c) class) (eq? (Ctx-method c) method)) #t] |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
278 |
[else (check (Ctx-previous c))]))) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
279 |
|
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
280 |
(define (gen-lit* litmap lit) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
281 |
(if (number? lit) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
282 |
lit |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
283 |
(hash-ref! litmap lit (lambda () |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
284 |
(define n (hash-count litmap)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
285 |
(cond |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
286 |
[(bv? lit) (mksym "lit~a-~a" n (bv->string lit))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
287 |
[(list? lit) (mksym "lit~a" n)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
288 |
[(vector? lit) (mksym "pic~a" n)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
289 |
[else (mksym "lit~a-~a" n lit)]))))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
290 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
291 |
(define (gen-lit litmap lit) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
292 |
(AbsVal (gen-lit* litmap lit) (Constant lit))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
293 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
294 |
(define (Ctx-litmap c) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
295 |
(State-litmap (Ctx-state c))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
296 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
297 |
(define (Ctx-lit c literal) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
298 |
(gen-lit (Ctx-litmap c) literal)) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
299 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
300 |
(define (Ctx-update c new-ip stack-transformer) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
301 |
(struct-copy Ctx c [ip new-ip] [stack (stack-transformer (Ctx-stack c))])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
302 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
303 |
(define (Ctx-push c v) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
304 |
(Ctx-update c (Ctx-ip c) (lambda (s) (cons v s)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
305 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
306 |
(define (Ctx-drop c n) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
307 |
(Ctx-update c (Ctx-ip c) (lambda (s) (drop s n)))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
308 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
309 |
(define (Ctx-goto c ip) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
310 |
(Ctx-update c ip values)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
311 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
312 |
(define (Ctx-push-and-goto c ip v) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
313 |
(Ctx-update c ip (lambda (s) (cons v s)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
314 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
315 |
(define (format-Ctx c) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
316 |
(string-join (reverse |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
317 |
(let pieces ((c c)) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
318 |
(if (DynamicCtx? c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
319 |
'() |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
320 |
(cons (format "~a @~a" (Ctx-name c) (Ctx-ip c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
321 |
(pieces (Ctx-previous c)))))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
322 |
"," |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
323 |
#:before-first "[" |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
324 |
#:after-last "]")) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
325 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
326 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
327 |
;; Compilation and code generation |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
328 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
329 |
(define (compile-method-proc compile-time-vm class method old-picmap) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
330 |
(define top-k (gensym 'top-k)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
331 |
(define c (top-compilation compile-time-vm class method old-picmap top-k)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
332 |
(define body-code (gen-code c)) ;; imperative! |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
333 |
(define pic-infos (reverse (State-pic-list-rev (Ctx-state c)))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
334 |
(define pic-infos-exp (gen-lit* (Ctx-litmap c) pic-infos)) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
335 |
(define stable? (equal? (if old-picmap (list->set (hash-keys old-picmap)) 'unknown) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
336 |
(list->set (map car pic-infos)))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
337 |
(log-vm/jit/recompile-debug "Evaluating stability of ~a:" (Ctx-name c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
338 |
(log-vm/jit/recompile-debug " old-picmap --> ~a" (if old-picmap (list->set (hash-keys old-picmap)) 'unknown)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
339 |
(log-vm/jit/recompile-debug " pic-infos --> ~a" (list->set (map car pic-infos))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
340 |
(when stable? |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
341 |
(log-vm/jit/recompile-info "Compilation of ~a is now stable." (method-name method class))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
342 |
(define inner-code |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
343 |
`(let ((call-counter 0) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
344 |
(cmi #f)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
345 |
(case-lambda |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
346 |
[() |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
347 |
(when (not cmi) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
348 |
(set! cmi |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
349 |
(compiled-method-info |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
350 |
,(AbsVal-expr (Ctx-lit c method)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
351 |
,pic-infos-exp |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
352 |
,stable?))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
353 |
cmi] |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
354 |
[(,top-k ,@(map AbsVal-expr (vector->list (Ctx-arguments c)))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
355 |
;; (log-vm/jit-debug "Entering ~a with ~a" |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
356 |
;; ,(method-name method class) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
357 |
;; (list ,@(map AbsVal-expr (vector->list (Ctx-arguments c))))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
358 |
(set! call-counter (+ call-counter 1)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
359 |
;; TODO: aging of call-counter by right-shifting at most once every few seconds, or so |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
360 |
(when (= call-counter 1000) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
361 |
(log-vm/jit/recompile-debug "Method ~a is hot" ,(method-name method class)) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
362 |
(recompile-something vm (,top-k)) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
363 |
;; (set! call-counter 0) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
364 |
) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
365 |
,(gen-fresh-temps c (gen-label-definitions c body-code))]))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
366 |
(finish-compilation c compile-time-vm inner-code)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
367 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
368 |
(define (finish-compilation c vm inner-code) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
369 |
(define litmap-list (hash->list (Ctx-litmap c))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
370 |
(define code `(lambda (vm ,@(map cdr litmap-list)) ,inner-code)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
371 |
(log-vm/jit/code-debug "Resulting code for ~a:\n~a" (Ctx-name c) (pretty-format code)) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
372 |
(apply (eval code ns) vm (map car litmap-list))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
373 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
374 |
;; (define (compile-block-proc compile-time-vm |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
375 |
;; method |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
376 |
;; outer-args |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
377 |
;; actual-temporaries |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
378 |
;; argument-location |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
379 |
;; initial-ip) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
380 |
;; (define class (obj-class* compile-time-vm (car outer-args))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
381 |
;; (define c (top-compilation compile-time-vm class method #f)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
382 |
;; (define body-code (gen-block c argument-location initial-ip)) ;; imperative! |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
383 |
;; (define inner-code |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
384 |
;; `(lambda (temporaries ,@(map AbsVal-expr (vector->list (compilation-argabsvals c)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
385 |
;; (let ((outer-k (outermost-k vm))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
386 |
;; ,(gen-label-definitions c body-code)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
387 |
;; (apply (finish-compilation c compile-time-vm inner-code) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
388 |
;; actual-temporaries |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
389 |
;; outer-args)) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
390 |
|
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
391 |
(define (block->thunk vm block args) ;; Expects a real bytecode block, not an ffiv one |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
392 |
(lambda () |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
393 |
(define method (slotAt block 0)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
394 |
(define outer-args (vector->list (obj-slots (slotAt block 1)))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
395 |
(define temporaries (obj-slots (slotAt block 2))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
396 |
(define argument-location (slotAt block 7)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
397 |
(define block-ip (slotAt block 9)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
398 |
(error 'block->thunk "Unimplemented") |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
399 |
;; (define f (compile-block-proc vm method outer-args temporaries argument-location block-ip)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
400 |
;; (apply f vm (outermost-k vm) args) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
401 |
)) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
402 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
403 |
(define (gen-build-jit-context c) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
404 |
(if (DynamicCtx? c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
405 |
`(,(DynamicCtx-var c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
406 |
`(build-jit-context vm |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
407 |
,(gen-build-jit-context (Ctx-previous c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
408 |
(vector ,@(map AbsVal-expr (vector->list (Ctx-arguments c)))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
409 |
,(AbsVal-expr (Ctx-lit c (Ctx-method c))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
410 |
,(Ctx-ip c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
411 |
,(Ctx-temporaries c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
412 |
(vector ,@(map AbsVal-expr (reverse (Ctx-stack c))))))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
413 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
414 |
(define (gen-fresh-temps c body-code) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
415 |
`(let ((,(Ctx-temporaries c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
416 |
,(match (slotAt (Ctx-method c) 4) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
417 |
[0 `'#()] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
418 |
[temp-count |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
419 |
`(make-vector ,temp-count ,(AbsVal-expr (Ctx-lit c (VM-nil (Ctx-vm c)))))]))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
420 |
,body-code)) |
408
aa5e38d54ab0
Inline self sends - a kind of method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset
|
421 |
|
419
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
422 |
(define (bytecode-exceeding? method limit) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
423 |
(define bytecode (bv-bytes (slotAt method 1))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
424 |
(log-vm/jit/code-debug "Method ~v bytecode length ~a compared against limit ~a" |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
425 |
(method-name method) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
426 |
(bytes-length bytecode) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
427 |
limit) |
419
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
428 |
(> (bytes-length bytecode) limit)) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
429 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
430 |
(define (gen-pic c name-bytes extension) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
431 |
(define p (if (null? extension) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
432 |
(pic) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
433 |
(apply extended-pic |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
434 |
(flatten (take (append extension empty-pic-extension) pic-entry-count))))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
435 |
(set-State-pic-list-rev! (Ctx-state c) (cons (list c name-bytes p) (State-pic-list-rev (Ctx-state c)))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
436 |
(gen-lit* (Ctx-litmap c) p)) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
437 |
|
422
de67b7cb9451
TODO re dependency links
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
421
diff
changeset
|
438 |
;; TODO: record dependency links properly, so that if a method is |
de67b7cb9451
TODO re dependency links
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
421
diff
changeset
|
439 |
;; changed, inlined copies of the old version of the method are |
de67b7cb9451
TODO re dependency links
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
421
diff
changeset
|
440 |
;; discarded. |
de67b7cb9451
TODO re dependency links
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
421
diff
changeset
|
441 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
442 |
(define (gen-inline-send kc method arg-avs) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
443 |
(define ic |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
444 |
(inline-compilation (Ctx-vm kc) method (list->vector arg-avs) #f 0 kc #f (Ctx-state kc))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
445 |
(log-vm/jit/code-debug "Inlining send of ~a into method ~a" (Ctx-name ic) (Ctx-name kc)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
446 |
(define body-code |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
447 |
`(begin |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
448 |
;; (log-vm/jit/code-debug "Entering inlined send of ~a returning to ~a with ~a" |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
449 |
;; ,(method-name method) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
450 |
;; ,(format-Ctx kc) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
451 |
;; (list ,@(map AbsVal-expr arg-avs))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
452 |
,(gen-fresh-temps ic (gen-label-definitions ic (gen-code ic))))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
453 |
(log-vm/jit/code-debug "INLINED for send of ~a into method ~a:\n~a" |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
454 |
(Ctx-name ic) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
455 |
(Ctx-name kc) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
456 |
(pretty-format body-code)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
457 |
body-code) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
458 |
|
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
459 |
(define (analyse-pic c pic) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
460 |
(define unsorted (for/list [(i (in-range (pic-size pic))) #:when (pic@ pic i 0)] |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
461 |
(list (pic@ pic i 2) (pic@ pic i 0) (pic@ pic i 1)))) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
462 |
(define descending-by-call-count (map cdr (sort unsorted > #:key car))) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
463 |
(for [(entry descending-by-call-count)] |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
464 |
(unwrap-cached-method (Ctx-vm c) (cadr entry))) ;; fills cache entry |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
465 |
descending-by-call-count) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
466 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
467 |
(define (tiny-method? bmethod) (not (bytecode-exceeding? bmethod 32))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
468 |
(define (small-method? bmethod) (not (bytecode-exceeding? bmethod 40))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
469 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
470 |
(define (remaining-basic-block-size-tiny? c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
471 |
(define method (Ctx-method c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
472 |
(define bytecode (bv-bytes (slotAt method 1))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
473 |
(define ip (Ctx-ip c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
474 |
(define remaining-bytes (- (bytes-length bytecode) ip)) ;; TODO: actually figure this out properly |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
475 |
(log-vm/jit-debug "Evaluating continuation size: ~a bytes left in ~a" remaining-bytes c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
476 |
(not (> remaining-bytes 6))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
477 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
478 |
(define (Ctx->expr c) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
479 |
(if (DynamicCtx? c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
480 |
(DynamicCtx-var c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
481 |
(let ((ans (gensym 'answer))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
482 |
`(case-lambda [() ,(gen-build-jit-context c)] |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
483 |
[(,ans) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
484 |
;; (log-vm/jit-debug "Continuing ~a with ~a" ,(format-Ctx c) ,ans) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
485 |
,(truncate-histories c (gen-continuation (Ctx-push c (AbsVal ans (Unknown)))))])))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
486 |
|
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
487 |
(define (gen-continuation c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
488 |
(if (remaining-basic-block-size-tiny? c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
489 |
(gen-code c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
490 |
(gen-jump-to-label c))) |
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset
|
491 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
492 |
(define (gen-send c class-absval name-bytes selector-absval arg-avs kc) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
493 |
(log-vm/jit-debug "Send of ~a at ~a returning to ~a" name-bytes c kc) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
494 |
(define vm (Ctx-vm c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
495 |
(define class-desc (AbsVal-desc class-absval)) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
496 |
;; (log-vm/jit-debug "class-absval is ~a" class-absval) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
497 |
(log-vm/jit-debug "arg-avs = ~a" arg-avs) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
498 |
(if (Constant? class-desc) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
499 |
(let* ((class (Constant-value class-desc)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
500 |
(cm (lookup-method/cache vm class name-bytes)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
501 |
(bmethod (or (cached-method-bytecode-method cm) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
502 |
(lookup-method vm class name-bytes) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
503 |
(error 'gen-send "DNU at compile time: ~a ~a" class name-bytes)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
504 |
(if (or (already-compiling? c class bmethod) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
505 |
(not (tiny-method? bmethod)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
506 |
(not (sufficiently-static? c arg-avs))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
507 |
`((unwrap-cached-method vm ,(AbsVal-expr (Ctx-lit c cm))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
508 |
,(Ctx->expr kc) ,@(map AbsVal-expr arg-avs)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
509 |
(gen-inline-send kc bmethod arg-avs))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
510 |
(let () |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
511 |
(define old-picmap (State-old-picmap (Ctx-state c))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
512 |
(define old-entry (and old-picmap (hash-ref old-picmap c #f))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
513 |
(define previous-pic-entries (if old-entry (analyse-pic c (cadr old-entry)) '())) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
514 |
(define pic-m (gen-pic c name-bytes previous-pic-entries)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
515 |
`(let ((k-send ,(Ctx->expr kc))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
516 |
,(let loop ((predictions previous-pic-entries) (counter pic-entry-count)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
517 |
(match predictions |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
518 |
['() |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
519 |
`((lookup-message/jit vm ,pic-m ,(AbsVal-expr class-absval) ,(AbsVal-expr selector-absval)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
520 |
k-send ,@(map AbsVal-expr arg-avs))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
521 |
[(cons (list predicted-class predicted-cm) more-predictions) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
522 |
(define predicted-bmethod (cached-method-bytecode-method predicted-cm)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
523 |
(define final-arg-avs (augment-receiver-class c arg-avs predicted-class)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
524 |
`(if (eq? ,(AbsVal-expr class-absval) ,(AbsVal-expr (Ctx-lit c predicted-class))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
525 |
(begin |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
526 |
(pic-bump! ,pic-m ,counter) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
527 |
,(if (or (already-compiling? c predicted-class predicted-bmethod) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
528 |
(not (small-method? predicted-bmethod)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
529 |
(not (sufficiently-static? c final-arg-avs))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
530 |
`((unwrap-cached-method vm ,(AbsVal-expr (Ctx-lit c predicted-cm))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
531 |
k-send ,@(map AbsVal-expr final-arg-avs)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
532 |
(gen-inline-send kc predicted-bmethod final-arg-avs))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
533 |
,(loop more-predictions (+ counter 1)))])))))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
534 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
535 |
(define (sufficiently-static? c avs) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
536 |
(or (andmap (lambda (av) (not (Unknown? (AbsVal-desc av)))) avs) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
537 |
(< (Ctx-depth c) 3))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
538 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
539 |
(define (augment-receiver-class c arg-avs class) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
540 |
(match-define (cons (AbsVal expr _desc) rest) arg-avs) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
541 |
(cons (AbsVal expr (Obj (Ctx-lit c class) #f)) rest)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
542 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
543 |
(define (gen-block c argument-location) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
544 |
(define temp-count (slotAt (Ctx-method c) 4)) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
545 |
(define block-k (gensym 'block-k)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
546 |
(define bc (inline-compilation (Ctx-vm c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
547 |
(Ctx-method c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
548 |
(Ctx-arguments c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
549 |
(Ctx-temporaries c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
550 |
(Ctx-ip c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
551 |
(DynamicCtx block-k) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
552 |
(or (Ctx-home c) (Ctx-previous c)) ;; ?? |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
553 |
(Ctx-state c))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
554 |
`(lambda (,block-k . block-arguments) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
555 |
;; (log-vm/jit-debug "Entering block at ~a with ~a" ,(format-Ctx bc) block-arguments) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
556 |
,(let loop ((i argument-location)) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
557 |
(if (>= i temp-count) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
558 |
`(void) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
559 |
`(when (pair? block-arguments) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
560 |
(vector-set! ,(Ctx-temporaries c) ,i (car block-arguments)) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
561 |
(let ((block-arguments (cdr block-arguments))) |
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
562 |
,(loop (+ i 1)))))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
563 |
,(truncate-histories bc (gen-label-definitions bc (gen-code bc))))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
564 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
565 |
(define (emit* c var purity absval) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
566 |
(define param (State-histories (Ctx-state c))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
567 |
(match-define (cons era hs) (param)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
568 |
(param (cons (cons (definition var purity absval) era) hs)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
569 |
(AbsVal var (AbsVal-desc absval))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
570 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
571 |
(define (historical-match c purity expr) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
572 |
(define param (State-histories (Ctx-state c))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
573 |
(and (eq? purity 'pure) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
574 |
(let search-hs ((hs (param))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
575 |
(match hs |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
576 |
['() #f] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
577 |
[(cons era hs) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
578 |
(let search-era ((era era)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
579 |
(match era |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
580 |
['() (search-hs hs)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
581 |
[(cons (definition var 'pure (AbsVal (== expr) desc)) _) (AbsVal var desc)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
582 |
[(cons _ era) (search-era era)]))])))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
583 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
584 |
(define-syntax emit |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
585 |
(syntax-rules () |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
586 |
[(_ c-expr [(var vargen) purity absval-expr] body-expr) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
587 |
(let* ((c c-expr) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
588 |
(absval absval-expr)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
589 |
(let ((var (or (historical-match c 'purity (AbsVal-expr absval)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
590 |
(emit* c vargen 'purity absval)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
591 |
body-expr))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
592 |
[(_ c-expr [var purity absval-expr] body-expr) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
593 |
(emit c-expr [(var (gensym 'var)) purity absval-expr] body-expr)])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
594 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
595 |
(define-syntax-rule (residualize c code-expr) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
596 |
(let ((param (State-histories (Ctx-state c)))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
597 |
(parameterize ((param (cons '() (param)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
598 |
(define code code-expr) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
599 |
(wrap-era (car (param)) code (free-names code))))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
600 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
601 |
(define-syntax-rule (truncate-histories c-expr code-expr) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
602 |
(let* ((c c-expr) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
603 |
(param (State-histories (Ctx-state c)))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
604 |
(parameterize ((param '())) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
605 |
(residualize c code-expr)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
606 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
607 |
(define (wrap-era era body outstanding) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
608 |
(match era |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
609 |
['() body] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
610 |
[(cons (definition var purity (AbsVal expr _desc)) era) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
611 |
(if (or (eq? purity 'effect) (set-member? outstanding var)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
612 |
(wrap-era era |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
613 |
(if (equal? body var) expr `(let ((,var ,expr)) ,body)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
614 |
(set-remove (set-union (free-names expr) outstanding) var)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
615 |
(wrap-era era body (set-remove outstanding var)))])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
616 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
617 |
(define (free-names expr) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
618 |
(log-vm-debug "free-names is a hideous overapproximation") |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
619 |
(match expr |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
620 |
[(? symbol? n) (seteq n)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
621 |
[`(,exprs ...) (apply set-union (seteq) (map free-names exprs))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
622 |
[_ (seteq)])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
623 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
624 |
(define (SlotAt c absval index) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
625 |
(match (AbsVal-desc absval) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
626 |
[(Obj _ (? vector? slot-absvals)) (vector-ref slot-absvals index)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
627 |
[_ (AbsVal `(slotAt ,(AbsVal-expr absval) ,index) (Unknown))])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
628 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
629 |
(define (ObjClass vm absval) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
630 |
(match (AbsVal-desc absval) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
631 |
[(Obj cls _) cls] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
632 |
[(Constant v) (AbsVal `(obj-class* vm ,(AbsVal-expr absval)) (Constant (obj-class* vm v)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
633 |
[_ (AbsVal `(obj-class* vm ,(AbsVal-expr absval)) (Unknown))])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
634 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
635 |
(define (read-opcode read-byte) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
636 |
(define byte (read-byte)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
637 |
(define low (bitwise-and byte #x0f)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
638 |
(define high (bitwise-and (arithmetic-shift byte -4) #x0f)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
639 |
(if (zero? high) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
640 |
(values low (read-byte)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
641 |
(values high low))) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
642 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
643 |
(define (gen-code c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
644 |
(log-vm/jit-debug "gen-code for ~a, stack ~a" c (Ctx-stack c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
645 |
(residualize |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
646 |
c |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
647 |
(let translate ((c c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
648 |
(define vm (Ctx-vm c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
649 |
(define method (Ctx-method c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
650 |
(define bytecode (bv-bytes (slotAt method 1))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
651 |
(define literals (slotAt method 2)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
652 |
(define c0 c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
653 |
(define stack (Ctx-stack c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
654 |
(define (next-byte!) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
655 |
(let ((ip (Ctx-ip c))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
656 |
(begin0 (bytes-ref bytecode ip) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
657 |
(set! c (Ctx-goto c (+ ip 1)))))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
658 |
(define (decode!) (read-opcode next-byte!)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
659 |
(define-values (opcode arg) (decode!)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
660 |
(log-vm/jit-debug " ~a: ~a ~a" c0 opcode arg) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
661 |
(match opcode |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
662 |
[1 (emit c [slotval pure (SlotAt c (Ctx-receiver c) arg)] (translate (Ctx-push c slotval)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
663 |
[2 (translate (Ctx-push c (Ctx-arg c arg)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
664 |
[3 (emit c [(n (gensym (format "temp~a-" arg))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
665 |
pure |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
666 |
(AbsVal `(vector-ref ,(Ctx-temporaries c) ,arg) (Unknown))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
667 |
(translate (Ctx-push c n)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
668 |
[4 (translate (Ctx-push c (Ctx-lit c (slotAt literals arg))))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
669 |
[5 (translate (Ctx-push c (Ctx-lit c (match arg |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
670 |
[(or 0 1 2 3 4 5 6 7 8 9) arg] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
671 |
[10 (VM-nil vm)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
672 |
[11 (VM-true vm)] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
673 |
[12 (VM-false vm)]))))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
674 |
[6 (let ((self-expr (AbsVal-expr (Ctx-receiver c))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
675 |
(val-expr (AbsVal-expr (car stack)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
676 |
(emit c [ignored effect (AbsVal `(slotAtPut ,self-expr ,arg ,val-expr) (Unknown))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
677 |
(truncate-histories c (translate c))))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
678 |
[7 (let ((val-expr (AbsVal-expr (car stack)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
679 |
(emit c [ignored effect (AbsVal `(vector-set! ,(Ctx-temporaries c) ,arg ,val-expr) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
680 |
(Unknown))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
681 |
(truncate-histories c (translate c))))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
682 |
[8 (let* ((arg-count arg) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
683 |
(args (reverse (take stack arg-count)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
684 |
(set! c (Ctx-drop c arg-count)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
685 |
(define-values (selector-literal-index class-absval) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
686 |
(match/values (decode!) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
687 |
[(9 selector-literal-index) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
688 |
(emit c [cls pure (ObjClass vm (car args))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
689 |
(values selector-literal-index cls))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
690 |
[(15 11) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
691 |
(define super (slotAt (slotAt method 5) 1)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
692 |
(values (next-byte!) (Ctx-lit c super))])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
693 |
(define selector (slotAt literals selector-literal-index)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
694 |
(gen-send c0 class-absval (bv-bytes selector) (Ctx-lit c selector) args c))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
695 |
;; 9 inlined in the processing of bytecode 8 |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
696 |
[10 (match arg |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
697 |
[0 (emit c [isNil pure |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
698 |
(if (equal? (Constant (VM-nil vm)) (AbsVal-desc (car stack))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
699 |
(Ctx-lit c (VM-true vm)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
700 |
(AbsVal `(boolean->obj vm (eq? ,(AbsVal-expr (Ctx-lit c (VM-nil vm))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
701 |
,(AbsVal-expr (car stack)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
702 |
(Unknown)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
703 |
(translate (Ctx-push (Ctx-drop c 1) isNil)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
704 |
[1 (emit c [notNil pure |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
705 |
(if (equal? (Constant (VM-nil vm)) (AbsVal-desc (car stack))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
706 |
(Ctx-lit c (VM-false vm)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
707 |
(AbsVal `(boolean->obj vm (not (eq? ,(AbsVal-expr (Ctx-lit c (VM-nil vm))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
708 |
,(AbsVal-expr (car stack))))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
709 |
(Unknown)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
710 |
(translate (Ctx-push (Ctx-drop c 1) notNil)))])] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
711 |
[11 (match stack |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
712 |
[(list* jv iv _stack) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
713 |
;; TODO: Fix now-unwanted special-casing of these sends. REQUIRES |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
714 |
;; IMAGE CHANGES, particularly in `addToSmallInt:`. |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
715 |
(set! c (Ctx-drop c 2)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
716 |
(define i (AbsVal-expr iv)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
717 |
(define j (AbsVal-expr jv)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
718 |
`(if (and (number? ,i) (number? ,j)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
719 |
,(residualize c |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
720 |
(emit c [opresult pure (AbsVal (match arg |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
721 |
[0 `(boolean->obj vm (< ,i ,j))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
722 |
[1 `(boolean->obj vm (<= ,i ,j))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
723 |
[2 `(+ ,i ,j)]) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
724 |
(Unknown))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
725 |
(translate (Ctx-push c opresult)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
726 |
,(residualize c |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
727 |
(let ((name-bytes (match arg [0 #"<"] [1 #"<="] [2 #"+"]))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
728 |
(gen-send c0 |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
729 |
(ObjClass vm iv) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
730 |
name-bytes |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
731 |
(AbsVal `(mkbv ,(AbsVal-expr (Ctx-lit c (VM-nil vm))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
732 |
,name-bytes) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
733 |
(Bv (Ctx-lit c (VM-nil vm)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
734 |
(vector) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
735 |
name-bytes)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
736 |
(list iv jv) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
737 |
c))))])] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
738 |
[12 (let ((target (next-byte!)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
739 |
(argument-location arg)) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
740 |
(emit c [block pure |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
741 |
(AbsVal |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
742 |
`(mkffiv ,(AbsVal-expr (Ctx-lit c (VM-Block vm))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
743 |
,(gen-block c argument-location)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
744 |
(Ffiv (Ctx-lit c (VM-Block vm)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
745 |
#f |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
746 |
(let ((c c)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
747 |
(lambda (kc arg-avs) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
748 |
(log-vm/jit-debug "Inlining block ~a returning to ~a" c kc) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
749 |
(define bc |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
750 |
(inline-compilation vm |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
751 |
method |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
752 |
(Ctx-arguments c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
753 |
(Ctx-temporaries c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
754 |
(Ctx-ip c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
755 |
kc |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
756 |
(or (Ctx-home c) (Ctx-previous c)) ;; ?? |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
757 |
(Ctx-state c))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
758 |
(for [(i (in-naturals argument-location)) (arg arg-avs)] |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
759 |
(define av |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
760 |
(AbsVal `(vector-set! ,(Ctx-temporaries c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
761 |
,i |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
762 |
,(AbsVal-expr arg)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
763 |
(Unknown))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
764 |
(emit bc [blkarg effect av] (void))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
765 |
(truncate-histories |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
766 |
bc |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
767 |
(gen-label-definitions bc (gen-code bc)))))))] |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
768 |
(translate (Ctx-push-and-goto c target block))))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
769 |
[13 (define primitive-number (next-byte!)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
770 |
(define primitive-arg-count arg) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
771 |
(define primitive-args (reverse (take stack primitive-arg-count))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
772 |
(set! c (Ctx-drop c arg)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
773 |
(match primitive-number |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
774 |
[2 (emit c [primcls pure (ObjClass vm (car primitive-args))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
775 |
(translate (Ctx-push c primcls)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
776 |
[7 (match-define (list class count) primitive-args) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
777 |
(emit c [(obj (gensym (class-temp-name class))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
778 |
effect |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
779 |
(AbsVal `(obj ,(AbsVal-expr class) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
780 |
(make-vector ,(AbsVal-expr count) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
781 |
,(AbsVal-expr (Ctx-lit c (VM-nil vm))))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
782 |
(Obj class #f))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
783 |
(translate (Ctx-push c obj)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
784 |
[8 (let ((v (gensym 'blockresult)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
785 |
(block (last primitive-args)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
786 |
(argc (- arg 1)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
787 |
(primitive-args (reverse (cdr (reverse primitive-args))))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
788 |
(log-vm/jit-debug "Attempt to invoke block ~a" block) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
789 |
(if (and (Ffiv? (AbsVal-desc block)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
790 |
(equal? (Constant (VM-Block vm)) (AbsVal-desc (ObjClass vm block)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
791 |
;; NB relies on tail call effect of primitive 8 (!) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
792 |
((Ffiv-value (AbsVal-desc block)) (Ctx-previous c) primitive-args) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
793 |
`(match ,(AbsVal-expr block) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
794 |
[(unffiv block-proc) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
795 |
(block-proc |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
796 |
;; TODO vvv : use case-lambda to translate the context chain |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
797 |
,(Ctx->expr (Ctx-previous c)) ;; not ,(Ctx->expr c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
798 |
;; ^ reason being the image BUGGILY (?!?) relies on primitive 8 |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
799 |
;; immediately returning to the surrounding context!! |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
800 |
,@(map AbsVal-expr primitive-args))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
801 |
[(obj (== ,(AbsVal-expr (Ctx-lit c (VM-Block vm)))) _) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
802 |
(log-vm/jit-warning "Unoptimized block!") |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
803 |
,(let ((expr `((block->thunk vm |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
804 |
,(AbsVal-expr block) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
805 |
(list ,@(map AbsVal-expr primitive-args)))))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
806 |
(match (Ctx-previous c) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
807 |
[(DynamicCtx dk) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
808 |
`(,dk ,expr)] |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
809 |
[caller |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
810 |
(gen-code (Ctx-push caller (AbsVal expr (Unknown))))]))])))] |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
811 |
[34 (Ctx-lit c (VM-nil vm))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
812 |
[35 (emit c [ctxref pure (AbsVal (gen-build-jit-context c) (Unknown))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
813 |
(translate (Ctx-push c ctxref)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
814 |
[36 (emit c [arr effect (AbsVal `(mkobj ,(AbsVal-expr (Ctx-lit c (VM-Array vm))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
815 |
,@(map AbsVal-expr primitive-args)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
816 |
(Obj (Ctx-lit c (VM-Array vm)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
817 |
(list->vector primitive-args)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
818 |
(translate (Ctx-push c arr)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
819 |
[_ (let ((generator (hash-ref *primitive-code-snippets* |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
820 |
primitive-number |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
821 |
(lambda () (error 'gen-code |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
822 |
"Unknown primitive: ~a" |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
823 |
primitive-number))))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
824 |
(emit c [primresult effect |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
825 |
(AbsVal (generator 'vm (map AbsVal-expr primitive-args)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
826 |
(Unknown))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
827 |
(translate (Ctx-push c primresult))))])] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
828 |
[14 (emit c [clsvar pure (SlotAt c (ObjClass vm (Ctx-receiver c)) (+ arg 5))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
829 |
(translate (Ctx-push c clsvar)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
830 |
[15 (define (continue c av) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
831 |
(match c |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
832 |
[(DynamicCtx dk) `(,dk ,(AbsVal-expr av))] |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
833 |
[_ (translate (Ctx-push c av))])) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
834 |
(match arg |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
835 |
[1 (continue (Ctx-previous c) (Ctx-receiver c))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
836 |
[2 (continue (Ctx-previous c) (car stack))] |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
837 |
[3 (continue (Ctx-home c) (car stack))] |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
838 |
[5 (translate (Ctx-drop c 1))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
839 |
[6 (gen-jump-to-label (Ctx-goto c (next-byte!)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
840 |
[7 (let ((target (next-byte!)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
841 |
(disc (car stack))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
842 |
(set! c (Ctx-drop c 1)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
843 |
(log-vm/jit-debug "if ~a true jump to ~a, else continue at ~a" disc target (Ctx-ip c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
844 |
(if (equal? (Constant (VM-true vm)) (AbsVal-desc disc)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
845 |
(gen-code (Ctx-goto c target)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
846 |
`(if (eq? ,(AbsVal-expr disc) ,(AbsVal-expr (Ctx-lit c (VM-true vm)))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
847 |
,(gen-continuation (Ctx-goto c target)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
848 |
,(gen-continuation c))))] |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
849 |
[8 (let ((target (next-byte!)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
850 |
(disc (car stack))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
851 |
(set! c (Ctx-drop c 1)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
852 |
(log-vm/jit-debug "if ~a false jump to ~a, else continue at ~a" disc target (Ctx-ip c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
853 |
(if (equal? (Constant (VM-false vm)) (AbsVal-desc disc)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
854 |
(gen-code (Ctx-goto c target)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
855 |
`(if (eq? ,(AbsVal-expr disc) ,(AbsVal-expr (Ctx-lit c (VM-false vm)))) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
856 |
,(gen-continuation (Ctx-goto c target)) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
857 |
,(gen-continuation c))))] |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
858 |
;; 11 inlined in the processing of bytecode 8 |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
859 |
[_ (error 'gen-code "Unhandled do-special case ~v" arg)])] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
860 |
[_ (error 'gen-code "~a - unhandled opcode ~v, arg ~v" (Ctx-name c) opcode 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
|
861 |
|
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
862 |
(define (class-temp-name av) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
863 |
(match (AbsVal-desc av) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
864 |
[(Constant (obj _ (vector (? bv? name) _ ...))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
865 |
(string-append "new" (bv->string name))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
866 |
[_ |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
867 |
"newobj"])) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
868 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
869 |
;; (define (dump-full-context c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
870 |
;; (log-vm/jit-debug "FULL CONTEXT:") |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
871 |
;; (let loop ((c c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
872 |
;; (log-vm/jit-debug " ~a: stack ~a" c (Ctx-stack c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
873 |
;; (cond [(Ctx-previous c) => loop] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
874 |
;; [else (void)])) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
875 |
;; (log-vm/jit-debug "HISTORIES: ~a" ((State-histories (Ctx-state c))))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
876 |
|
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
877 |
(define (gen-jump-to-label c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
878 |
(define labels (Ctx-labels c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
879 |
(define key (Ctx-ip c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
880 |
(when (not (hash-has-key? labels key)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
881 |
(define var |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
882 |
(gensym (mksym "label-~a-~a-" |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
883 |
(bv->string (slotAt (Ctx-method c) 0)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
884 |
(Ctx-ip c)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
885 |
(hash-set! labels key (cons 'placeholder var)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
886 |
(define newstack (for/list [(i (length (Ctx-stack c)))] (AbsVal (mksym "stack~a" i) (Unknown)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
887 |
(log-vm/jit-debug "Producing label ~a" var) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
888 |
(define bb-k (gensym 'bb-k)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
889 |
(define expr (truncate-histories |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
890 |
c |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
891 |
(let* ((c (Ctx-update c (Ctx-ip c) (lambda (_s) newstack))) |
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
892 |
(c (struct-copy Ctx c [previous (DynamicCtx bb-k)]))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
893 |
;; (dump-full-context c) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
894 |
(gen-code c)))) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
895 |
(log-vm/jit-debug "Produced label ~a" var) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
896 |
(hash-set! labels key (cons `(lambda (,bb-k ,@(map AbsVal-expr newstack)) ,expr) var))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
897 |
`(,(cdr (hash-ref labels key)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
898 |
,(Ctx->expr (Ctx-previous c)) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
899 |
,@(map AbsVal-expr (Ctx-stack c)))) |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
900 |
|
404
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
901 |
(define (gen-label-definitions c body-exp) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
902 |
`(letrec (,@(for/list [(label-info (in-hash-values (Ctx-labels c)))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
903 |
(match-define (cons label-exp var) label-info) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
904 |
(log-vm/jit-debug "Emitting label ~a" var) |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
905 |
`(,var ,label-exp))) |
404
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
906 |
,body-exp)) |
158def14bb15
Pull out gen-label-definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset
|
907 |
|
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
908 |
(define (outermost-k vm) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
909 |
(case-lambda [() (VM-nil vm)] |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
910 |
[(result) result])) |
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset
|
911 |
|
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
912 |
;;=========================================================================== |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
913 |
;; Recompilation |
410
7e5d9e957c2f
Expose pics, collect call stats, preparing for dynamic type feedback / recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
409
diff
changeset
|
914 |
|
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
915 |
(define (recompilation-candidate vm ctx) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
916 |
(let search ((ctx ctx) (candidate #f) (candidate-class #f) (candidate-hotness 0)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
917 |
(cond |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
918 |
[(eq? (VM-nil vm) ctx) (values candidate candidate-class)] |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
919 |
[else (define method (slotAt ctx 0)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
920 |
(define receiver (slotAt (slotAt ctx 1) 0)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
921 |
(define receiver-class (obj-class* vm receiver)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
922 |
(define next-ctx (slotAt ctx 6)) |
419
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
923 |
(log-vm/jit/recompile/candidates-debug " ~a" (method-name method receiver-class)) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
924 |
(define cached-method (bytecode->cached-compiled vm receiver-class method)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
925 |
(define compiled-method (unwrap-cached-method vm cached-method)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
926 |
(cond |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
927 |
[(not compiled-method) (search next-ctx candidate candidate-class candidate-hotness)] |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
928 |
[else |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
929 |
(match-define (compiled-method-info (== method eq?) pics stable?) (compiled-method)) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
930 |
(log-vm/jit/recompile/candidates-debug " has ~a bytes of bytecode; ~a" |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
931 |
(bytes-length (bv-bytes (slotAt method 1))) |
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
932 |
(if stable? "stable" "not yet stable")) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
933 |
(define hotness |
420
a2e3a40b28fa
Remove redundant filter step in recompilation-candidate.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
419
diff
changeset
|
934 |
(for/sum [(entry pics)] |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
935 |
(match-define (list c _name-bytes pic) entry) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
936 |
(for/sum [(i (in-range (pic-size pic)))] |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
937 |
(match (pic@ pic i 0) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
938 |
[#f 0] |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
939 |
[slot-class |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
940 |
(define slot-cm (pic@ pic i 1)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
941 |
(unwrap-cached-method vm slot-cm) ;; fills cache entry |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
942 |
(define slot-bmethod (cached-method-bytecode-method slot-cm)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
943 |
(define slot-count (pic@ pic i 2)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
944 |
(define bytecode-count (bytes-length (bv-bytes (slotAt slot-bmethod 1)))) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
945 |
(define weight (/ 40.0 bytecode-count)) |
419
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
946 |
(log-vm/jit/recompile/candidates-debug |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
947 |
" context ~a class ~a count ~a length ~a weight ~a" |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
948 |
c |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
949 |
(bv->string (slotAt slot-class 0)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
950 |
slot-count |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
951 |
bytecode-count |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
952 |
weight) |
419
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
953 |
(if (< weight 1) |
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
954 |
0 |
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
955 |
(* slot-count weight))])))) |
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
956 |
(log-vm/jit/recompile/candidates-debug " hotness: ~a" hotness) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
957 |
(if (and (> hotness candidate-hotness) (not stable?)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
958 |
(search next-ctx method receiver-class hotness) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
959 |
(search next-ctx candidate candidate-class candidate-hotness))])]))) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
960 |
|
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
961 |
(define (recompile-method! vm class method) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
962 |
(log-vm/jit/recompile-info "Recompiling ~a" (method-name method class)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
963 |
(define cached-method (bytecode->cached-compiled vm class method)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
964 |
(define old-proc (cached-method-proc cached-method)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
965 |
(define old-picmap |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
966 |
(for/hash [(entry (in-list (if old-proc (compiled-method-info-pics (old-proc)) '())))] |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
967 |
(values (car entry) (cdr entry)))) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
968 |
(when (not (hash-empty? old-picmap)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
969 |
(log-vm/jit/recompile-info "Retrieved old pics for method ~a" (method-name method class)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
970 |
(for [((c p) (in-hash old-picmap))] |
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
971 |
(log-vm/jit/recompile-info " ~a --> ~v" (format-Ctx c) p))) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
972 |
(define recompiled-proc (compile-method-proc vm class method old-picmap)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
973 |
(log-vm/jit/recompile-info "Updating cached compiled method for ~a" (method-name method class)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
974 |
(set-cached-method-proc! cached-method recompiled-proc)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
975 |
|
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
976 |
(define (recompile-something vm ctx) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
977 |
(define-values (candidate candidate-class) (recompilation-candidate vm ctx)) |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
978 |
(if candidate |
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
979 |
(recompile-method! vm candidate-class candidate) |
417
a56b893c78bf
info -> debug recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
416
diff
changeset
|
980 |
(log-vm/jit/recompile-debug "No recompilation candidate available?"))) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
981 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
982 |
;;=========================================================================== |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
983 |
;; VM-specific primitives (aside from the core primitives found in `gen-code`) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
984 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
985 |
(define-primitive vm [6 inner-ctx] ;; "new context execute" |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
986 |
(when (not (zero? (slotAt inner-ctx 5))) (error 'execute "Cannot execute from nonempty stack")) |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
987 |
(when (not (zero? (slotAt inner-ctx 4))) (error 'execute "Cannot execute from nonzero IP")) |
405
5a019affe985
Plumbing preparation for method customization
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset
|
988 |
(define args (slotAt inner-ctx 1)) |
413
99a706eaf2cf
Recompilation and pic-based inlining. Slower than before!
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
411
diff
changeset
|
989 |
(define f (compile-method-proc vm (obj-class* vm (slotAt args 0)) (slotAt inner-ctx 0) #f)) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
990 |
(apply f (outermost-k vm) (vector->list (obj-slots args)))) |
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
991 |
|
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
992 |
(define-primitive vm [116] (save-image-to-file vm (pe-VM-image-filename vm))) |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
993 |
|
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset
|
994 |
;;=========================================================================== |
423
8c544e15ad92
Cosmetic: rearrange code in jit-SmallWorld-2015.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
422
diff
changeset
|
995 |
;; Entry point |
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset
|
996 |
|
419
26771937eee3
Tweak inliner heuristics
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
417
diff
changeset
|
997 |
(pretty-print-columns 230) |
369
3e1f84e6289d
Image saving
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset
|
998 |
(let* ((image-filename "SmallWorld/src/image") |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
999 |
(vm (call-with-input-file image-filename |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
1000 |
(lambda (fh) |
426
930c499509be
Now working, up to recompilation
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
425
diff
changeset
|
1001 |
(read-image fh pe-VM (list (make-weak-hasheq) image-filename)))))) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
1002 |
(boot-image vm |
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
1003 |
(lambda (vm source) |
411
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
1004 |
(define compiled-method |
ba74f97d2ba9
Indirection to allow invalidation of cached compiled method
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
410
diff
changeset
|
1005 |
(unwrap-cached-method vm (lookup-method/cache vm (obj-class source) #"doIt"))) |
425
a7f739fa4dee
WIP, not running yet; needs work on home context references
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
424
diff
changeset
|
1006 |
(compiled-method (outermost-k vm) source)) |
403
5e81df1d79c4
Factor out object-memory.rkt and primitives.rkt
Tony Garnock-Jones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset
|
1007 |
(current-command-line-arguments))) |