Prep for PE experimental JIT
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Sun, 29 Jul 2018 06:15:15 +0100
changeset 424 e55f9163af2f
parent 423 8c544e15ad92
child 425 a7f739fa4dee
Prep for PE experimental JIT
experiments/little-smalltalk/pe-SmallWorld-2015.rkt
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/little-smalltalk/pe-SmallWorld-2015.rkt	Sun Jul 29 06:15:15 2018 +0100
@@ -0,0 +1,684 @@
+#lang racket/gui
+;; Loader for images (version 1 format) from Russell Allen's 2015
+;; variant of SmallWorld, a Tim Budd-authored Little Smalltalk
+;; descendant.
+
+(require racket/bytes)
+(require (only-in sha bytes->hex-string))
+(require "object-memory.rkt")
+(require "primitives.rkt")
+
+(define-logger vm)
+(define-logger vm/jit)
+(define-logger vm/jit/code)
+(define-logger vm/jit/recompile)
+(define-logger vm/jit/recompile/candidates)
+
+;; Runtime support: We use `eval` with namespace `ns` to allow
+;; generated code to access bindings in this module.
+(define-namespace-anchor ns-anchor)
+(define ns (namespace-anchor->namespace ns-anchor))
+
+;;===========================================================================
+;; Structures
+
+(struct jit-VM VM (cache image-filename)
+  #:methods gen:vm-callback
+  [(define (vm-block-callback vm action)
+     ;; Runs action in a new thread
+     (lambda args
+       (thread (match action
+                 [(unffiv block-proc)
+                  (lambda () (apply block-proc vm (outermost-k vm) args))]
+                 [_
+                  (block->thunk vm action args)]))))])
+
+(struct pic-info (name-bytes variable context extension) #:transparent)
+(struct compilation-result (litmap [pic-list-rev #:mutable] old-picmap))
+(struct compilation (outer outer-ip vm receiver-class method argnames labels state))
+
+(struct compiled-method-info (bytecode-method pics stable?))
+
+(struct cached-method (class name-bytes [bytecode-method #:mutable] [proc #:mutable]))
+
+;;===========================================================================
+;; Polymorphic Inline Caches - PICs
+
+(define pic-reserved 0)
+(define pic-entry-count 3)
+
+(define (pic) ;; pic-entry-count ×3 - class, method, and count.
+  (vector #f #f 0
+          #f #f 0
+          #f #f 0))
+(define (extended-pic c0 m0 c1 m1 c2 m2) ;; normal pic plus previous knowledge
+  (vector #f #f 0 #f #f 0 #f #f 0
+          c0 m0 0 c1 m1 0 c2 m2 0))
+
+(define (pic-size pic) (quotient (- (vector-length pic) pic-reserved) pic-entry-count))
+(define (pic@ pic index offset) (vector-ref pic (+ pic-reserved offset (* index 3))))
+(define (pic@! pic index offset v) (vector-set! pic (+ pic-reserved offset (* index 3)) v))
+
+(define (pic-bump! pic index)
+  (define o (+ pic-reserved 2 (* index 3)))
+  (vector-set! pic o (+ 1 (vector-ref pic o))))
+
+(define empty-pic-extension (for/list [(i (in-range pic-entry-count))] '(#f #f)))
+
+;;===========================================================================
+;; Dynamic Deoptimization
+
+(define (build-jit-context vm previous-context args method ip temporaries stack)
+  ;; TODO: build block contexts instead of just pretending everything is a method...
+  (define max-stack (slotAt method 3))
+  (mkobj (VM-Context vm)
+         method
+         (obj (VM-Array vm) args)
+         (obj (VM-Array vm) temporaries)
+         (obj (VM-Array vm) (vector-append stack (make-vector (- max-stack (vector-length stack))
+                                                              (VM-nil vm))))
+         ip
+         (vector-length stack)
+         previous-context))
+
+;;===========================================================================
+;; Method cache; relationship between bytecoded and compiled methods
+
+(define (lookup-method/cache vm class name-bytes)
+  (define class-cache (hash-ref! (jit-VM-cache vm) class make-weak-hash))
+  (hash-ref! class-cache
+             name-bytes
+             (lambda () (cached-method class name-bytes #f #f))))
+
+(define (bytecode->cached-compiled vm class method)
+  (lookup-method/cache vm class (bv-bytes (slotAt method 0))))
+
+(define (compiled->bytecode cmethod)
+  (compiled-method-info-bytecode-method (cmethod)))
+
+(define (unwrap-cached-method vm cm)
+  (or (cached-method-proc cm)
+      (match cm
+        [(cached-method class name-bytes _bcm _proc)
+         (define bcm (lookup-method vm class name-bytes))
+         (define proc (and bcm (compile-method-proc vm class bcm #f)))
+         (set-cached-method-bytecode-method! cm bcm)
+         (set-cached-method-proc! cm proc)
+         proc])))
+
+(define (invalidate-cached-method! cm)
+  (set-cached-method-bytecode-method! cm #f)
+  (set-cached-method-proc! cm #f))
+
+;;===========================================================================
+;; Runtime method lookup via PIC
+
+(define (lookup-message/jit vm pic class selector)
+  (let search-pic ((slot-index 0))
+    (define this-class (pic@ pic slot-index 0))
+    (if (eq? this-class class)
+        (begin (pic-bump! pic slot-index)
+               (or (unwrap-cached-method vm (pic@ pic slot-index 1))
+                   (send-dnu class selector)))
+        (let* ((next-slot-index (+ slot-index 1))
+               (more-slots-to-check? (and this-class (< next-slot-index pic-entry-count))))
+          (if more-slots-to-check?
+              (search-pic next-slot-index)
+              (let* ((cm (lookup-method/cache vm class (bv-bytes selector))))
+                (when (not this-class)
+                  (pic@! pic slot-index 0 class)
+                  (pic@! pic slot-index 1 cm)
+                  (pic@! pic slot-index 2 1))
+                (or (unwrap-cached-method vm cm)
+                    (send-dnu class selector))))))))
+
+(define ((send-dnu class selector) vm ctx . args)
+  (define arguments (obj (VM-Array vm) (list->vector args)))
+  (define dnu-name-bytes #"doesNotUnderstand:")
+  (match (unwrap-cached-method vm (lookup-method/cache vm class dnu-name-bytes))
+    [#f (error 'send-message* "Unhandled selector ~a at class ~a" selector class)]
+    [dnu-method
+     (log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector)
+     (dnu-method vm ctx (slotAt arguments 0) (mkobj (VM-Array vm) selector arguments))]))
+
+;;===========================================================================
+;; Compilation State
+
+(define (top-compilation vm receiver-class method old-picmap)
+  (compilation* vm #f #f receiver-class method (compilation-result (make-hasheq) '() old-picmap)))
+
+(define (inline-compilation c c-ip receiver-class method)
+  (compilation* (compilation-vm c) c c-ip receiver-class method (compilation-state c)))
+
+(define (compilation* vm outer outer-ip receiver-class method state)
+  (define arity (selector-string-arity (method-name method)))
+  (define literals (slotAt method 2))
+
+  (define litmap (compilation-result-litmap state))
+  (for [(lit (obj-slots literals))] (gen-lit* litmap lit))
+
+  (define argnames (for/vector [(i arity)] (if (zero? i) 'self (mksym "arg~a" (- i 1)))))
+
+  (define c (compilation outer outer-ip vm receiver-class method argnames (make-hash) state))
+  (log-vm/jit/code-info "Compiling ~a defined in ~v (depth ~a)"
+                        (compilation-method-name c)
+                        (slotAt method 5)
+                        (compilation-depth c))
+  (log-vm/jit/code-info "  bytecode: ~a\n----\n~a\n----"
+                        (bytes->hex-string (bv-bytes (slotAt method 1)))
+                        (bv->string (slotAt method 6)))
+  c)
+
+(define (mksym fmt . args) (string->symbol (apply format fmt args)))
+
+(define (selector-string-arity str)
+  (define colon-count (for/sum [(c str)] (if (eqv? c #\:) 1 0)))
+  (cond [(positive? colon-count) (+ colon-count 1)]
+        [(char-alphabetic? (string-ref str 0)) 1]
+        [else 2])) ;; assume binary operator
+
+(define (compilation-method-name c)
+  (method-name (compilation-method c) (compilation-receiver-class c)))
+
+(define (compilation-depth c)
+  (define o (compilation-outer c))
+  (if o (+ 1 (compilation-depth o)) 0))
+
+(define (already-compiling? c class method)
+  (let check ((c c))
+    (cond [(not c) #f]
+          [(and (eq? (compilation-receiver-class c) class) (eq? (compilation-method c) method)) #t]
+          [else (check (compilation-outer c))])))
+
+(define (gen-lit* litmap lit)
+  (hash-ref! litmap lit (lambda ()
+                          (define n (hash-count litmap))
+                          (if (bv? lit)
+                              (mksym "lit~a-~a" n (bv->string lit))
+                              (mksym "lit~a" n)))))
+
+(define (compilation-litname c literal)
+  (hash-ref (compilation-result-litmap (compilation-state c)) literal))
+
+(define (compilation-context c ip)
+  (if (not c)
+      '()
+      (cons (list (compilation-receiver-class c) (compilation-method c) ip)
+            (compilation-context (compilation-outer c) (compilation-outer-ip c)))))
+
+(define (format-compilation-context x)
+  (string-join (reverse
+                (map (match-lambda [(list c m ip) (format "~a @~a" (method-name m c) ip)]) x))
+               ","
+               #:before-first "["
+               #:after-last "]"))
+
+;;===========================================================================
+;; Compilation and code generation
+
+(define (compile-method-proc compile-time-vm class method old-picmap)
+  (define c (top-compilation compile-time-vm class method old-picmap))
+  (define body-code (gen-jump-to-label c 0 '())) ;; imperative!
+  (define pic-infos (reverse (compilation-result-pic-list-rev (compilation-state c))))
+  (define pic-infos-exp (gen-lit* (compilation-result-litmap (compilation-state c)) pic-infos))
+  (define stable? (equal? (if old-picmap (list->set (hash-keys old-picmap)) 'unknown)
+                          (list->set (map pic-info-context pic-infos))))
+  (when stable?
+    (log-vm/jit/recompile-info "Compilation of ~a is now stable." (method-name method class)))
+  (define inner-code
+    `(let ((call-counter 0)
+           (cmi #f))
+       (case-lambda
+         [()
+          (when (not cmi)
+            (set! cmi
+                  (compiled-method-info
+                   method
+                   (for/list [(pi (in-list ,pic-infos-exp))
+                              (pic (in-list (list ,@(map pic-info-variable pic-infos))))]
+                     (cons pi pic))
+                   ,stable?)))
+          cmi]
+         [(vm k ,@(vector->list (compilation-argnames c)))
+          (set! call-counter (+ call-counter 1))
+          ;; TODO: aging of call-counter by right-shifting at most once every few seconds, or so
+          (when (= call-counter 1000)
+            (log-vm/jit/recompile-debug "Method ~a is hot" ,(method-name method class))
+            (recompile-something vm (k))
+            ;; (set! call-counter 0)
+            )
+          (let ((outer-k k)
+                (temporaries ,(gen-fresh-temps method)))
+            ,(gen-label-definitions c body-code))])))
+  (finish-compilation c compile-time-vm inner-code))
+
+(define (compile-block-proc compile-time-vm
+                            method
+                            outer-args
+                            actual-temporaries
+                            argument-location
+                            initial-ip)
+  (define class (obj-class* compile-time-vm (car outer-args)))
+  (define c (top-compilation compile-time-vm class method #f))
+  (define body-code (gen-block c argument-location initial-ip)) ;; imperative!
+  (define inner-code
+    `(lambda (temporaries ,@(vector->list (compilation-argnames c)))
+       (let ((outer-k (outermost-k vm)))
+         ,(gen-label-definitions c body-code))))
+  (apply (finish-compilation c compile-time-vm inner-code)
+         actual-temporaries
+         outer-args))
+
+(define (block->thunk vm block args) ;; Expects a real bytecode block, not an ffiv one
+  (lambda ()
+    (define method (slotAt block 0))
+    (define outer-args (vector->list (obj-slots (slotAt block 1))))
+    (define temporaries (obj-slots (slotAt block 2)))
+    (define argument-location (slotAt block 7))
+    (define block-ip (slotAt block 9))
+    (define f (compile-block-proc vm method outer-args temporaries argument-location block-ip))
+    (apply f vm (outermost-k vm) args)))
+
+(define (gen-build-jit-context c ip stack)
+  `(build-jit-context vm
+                      (k)
+                      (vector ,@(vector->list (compilation-argnames c)))
+                      method
+                      ,ip
+                      temporaries
+                      (vector ,@(reverse stack))))
+
+(define (gen-send-k c ip stack)
+  (define result (gensym 'result))
+  `(case-lambda [() ,(gen-build-jit-context c ip stack)]
+                [(,result) ,(gen-code c ip (cons result stack))]))
+
+(define (gen-fresh-temps method)
+  (match (slotAt method 4)
+    [0 `'#()]
+    [temp-count `(make-vector ,temp-count NIL)]))
+
+(define (bytecode-exceeding? method limit)
+  (define bytecode (bv-bytes (slotAt method 1)))
+  (> (bytes-length bytecode) limit))
+
+(define (gen-pic c name-bytes send-ip extension)
+  (define old-pics (compilation-result-pic-list-rev (compilation-state c)))
+  (define pic-index (length old-pics))
+  (define m (mksym "pic~a" pic-index))
+  (define pi (pic-info name-bytes m (compilation-context c send-ip) extension))
+  (set-compilation-result-pic-list-rev! (compilation-state c) (cons pi old-pics))
+  (log-vm/jit/recompile-debug "Produced pic at ip ~a for send of ~a in method ~a"
+                              send-ip
+                              name-bytes
+                              (compilation-method-name c))
+  m)
+
+;; TODO: record dependency links properly, so that if a method is
+;; changed, inlined copies of the old version of the method are
+;; discarded.
+
+(define (gen-inline-send c c-ip class method k-exp arg-exps)
+  (log-vm/jit/code-info "Inlining send of ~a into method ~a"
+                        (method-name method class)
+                        (compilation-method-name c))
+  (define ic (inline-compilation c c-ip class method))
+  (define body-code (gen-jump-to-label ic 0 '()))
+  (define defining-class (slotAt method 5))
+  (define litmap (compilation-result-litmap (compilation-state ic)))
+  (define inner-code
+    `(let ((k ,k-exp)
+           (method ,(gen-lit* litmap method))
+           (super ,(gen-lit* litmap (slotAt defining-class 1))))
+       (let ,(for/list [(formal (vector->list (compilation-argnames ic)))
+                        (actual (in-list arg-exps))]
+               `(,formal ,actual))
+         (let ((outer-k k)
+               (temporaries ,(gen-fresh-temps method)))
+           ,(gen-label-definitions ic body-code)))))
+  ;; (log-vm/jit/code-debug "INLINED:\n~a" (pretty-format inner-code))
+  inner-code)
+
+(define (analyse-pic c pic)
+  (define vm (compilation-vm c))
+  (define unsorted (for/list [(i (in-range (pic-size pic))) #:when (pic@ pic i 0)]
+                     (list (pic@ pic i 2) (pic@ pic i 0) (pic@ pic i 1))))
+  (define descending-by-call-count (map cdr (sort unsorted > #:key car)))
+  (for [(entry descending-by-call-count)]
+    (unwrap-cached-method vm (cadr entry))) ;; fills cache entry
+  descending-by-call-count)
+
+(define (gen-send c send-ip class-exp name-bytes selector-exp k-exp arg-exps)
+  (define receiver-class (compilation-receiver-class c))
+  (define method (lookup-method (compilation-vm c) receiver-class name-bytes))
+  (cond
+    [(and (equal? class-exp `(obj-class* vm self)) ;; self send
+          (< (compilation-depth c) 2)
+          method
+          (not (bytecode-exceeding? method 32)))
+     (gen-inline-send c send-ip receiver-class method k-exp arg-exps)]
+    [else
+     (define old-picmap (compilation-result-old-picmap (compilation-state c)))
+     (define old-entry
+       (and old-picmap (hash-ref old-picmap (compilation-context c send-ip) #f)))
+     (define previous-pic-entries (if old-entry (analyse-pic c (cdr old-entry)) '()))
+     (define litmap (compilation-result-litmap (compilation-state c)))
+     (define pic-m (gen-pic c name-bytes send-ip previous-pic-entries))
+     `(let ((actual-class ,class-exp)
+            (k-send ,k-exp))
+        ,(let loop ((predictions previous-pic-entries) (counter pic-entry-count))
+           (match predictions
+             ['()
+              `((lookup-message/jit vm ,pic-m actual-class ,selector-exp) vm k-send ,@arg-exps)]
+             [(cons (list predicted-class predicted-cm) more-predictions)
+              (define predicted-bmethod (cached-method-bytecode-method predicted-cm))
+              `(if (eq? actual-class ,(gen-lit* litmap predicted-class))
+                   (begin
+                     (pic-bump! ,pic-m ,counter)
+                     ,(if (or (already-compiling? c predicted-class predicted-bmethod)
+                              (bytecode-exceeding? predicted-bmethod 40))
+                          `((unwrap-cached-method vm ,(gen-lit* litmap predicted-cm))
+                            vm k-send ,@arg-exps)
+                          (gen-inline-send c send-ip predicted-class predicted-bmethod 'k-send arg-exps)))
+                   ,(loop more-predictions (+ counter 1)))])))]))
+
+(define (gen-block c argument-location ip)
+  (define temp-count (slotAt (compilation-method c) 4))
+  `(lambda (vm k . block-arguments)
+     ,(let loop ((i argument-location))
+        (if (>= i temp-count)
+            `(void)
+            `(when (pair? block-arguments)
+               (vector-set! temporaries ,i (car block-arguments))
+               (let ((block-arguments (cdr block-arguments)))
+                 ,(loop (+ i 1))))))
+     ,(gen-code c ip '())))
+
+(define-syntax let@
+  (syntax-rules ()
+    [(_ [n n-code-exp] body-code-exp)
+     (let@ [n 'n n-code-exp] body-code-exp)]
+    [(_ [n n-exp n-code-exp] body-code-exp)
+     (let ((n (gensym n-exp)))
+       `(let ((,n ,n-code-exp))
+          ,body-code-exp))]))
+
+(define (gen-code c ip stack)
+  (define method (compilation-method c))
+  (define bytecode (bv-bytes (slotAt method 1)))
+  (define literals (slotAt method 2))
+  (let translate ((ip ip) (stack stack))
+    (define (next-byte!)
+      (begin0 (bytes-ref bytecode ip)
+        (set! ip (+ ip 1))))
+    (define (decode!)
+      (define byte (next-byte!))
+      (define low (bitwise-and byte #x0f))
+      (define high (bitwise-and (arithmetic-shift byte -4) #x0f))
+      (if (zero? high)
+          (values low (next-byte!))
+          (values high low)))
+    (define ip0 ip)
+    (define-values (opcode arg) (decode!))
+    (log-vm/jit-debug " ~a: ~a ~a" ip0 opcode arg)
+    (match opcode
+      [1 (let@ [n (mksym "slot~a_" arg) `(slotAt self ,arg)]
+               (translate ip (cons n stack)))]
+      [2 (translate ip (cons (vector-ref (compilation-argnames c) arg) stack))]
+      [3 (let@ [n (mksym "tmp~a_" arg) `(vector-ref temporaries ,arg)]
+               (translate ip (cons n stack)))]
+      [4 (let ((name (compilation-litname c (slotAt literals arg))))
+           (translate ip (cons name stack)))]
+      [5 (match arg
+           [(or 0 1 2 3 4 5 6 7 8 9) (translate ip (cons arg stack))]
+           [10 (translate ip (cons `NIL stack))]
+           [11 (translate ip (cons `TRUE stack))]
+           [12 (translate ip (cons `FALSE stack))])]
+      [6 `(begin (slotAtPut self ,arg ,(car stack)) ,(translate ip stack))]
+      [7 `(begin (vector-set! temporaries ,arg ,(car stack)) ,(translate ip stack))]
+      [8 (let* ((arg-count arg)
+                (args (reverse (take stack arg-count)))
+                (stack (drop stack arg-count)))
+           (define-values (selector-literal-index class-exp)
+             (match/values (decode!)
+               [(9 selector-literal-index)
+                (values selector-literal-index `(obj-class* vm ,(car args)))]
+               [(15 11)
+                (values (next-byte!) `super)]))
+           (define k (gen-send-k c ip stack))
+           (define selector (slotAt literals selector-literal-index))
+           (define selector-exp (compilation-litname c selector))
+           (gen-send c ip0 class-exp (bv-bytes selector) selector-exp k args))]
+      ;; 9 inlined in the processing of bytecode 8
+      [10 (match arg
+            [0 (let@ [isNil `(boolean->obj vm (eq? NIL ,(car stack)))]
+                     (translate ip (cons isNil (cdr stack))))]
+            [1 (let@ [notNil `(boolean->obj vm (not (eq? NIL ,(car stack))))]
+                     (translate ip (cons notNil (cdr stack))))])]
+      [11 (match stack
+            [(list* j i stack)
+             ;; TODO: Remove special-casing of these sends. REQUIRES
+             ;; IMAGE CHANGES, particularly in `addToSmallInt:`.
+             (let@ [binop-k (gen-send-k c ip stack)]
+                   `(if (and (number? ,i) (number? ,j))
+                        ,(match arg
+                           [0 `(,binop-k (boolean->obj vm (< ,i ,j)))]
+                           [1 `(,binop-k (boolean->obj vm (<= ,i ,j)))]
+                           [2 `(,binop-k (+ ,i ,j))])
+                        ,(let ((name-bytes (match arg [0 #"<"] [1 #"<="] [2 #"+"])))
+                           (gen-send c
+                                     ip0
+                                     `(obj-class* vm ,i)
+                                     name-bytes
+                                     `(mkbv NIL ,name-bytes)
+                                     binop-k
+                                     (list i j)))))])]
+      [12 (let ((target (next-byte!)))
+            (let@ [block `(mkffiv BLOCK ,(gen-block c arg ip))]
+                  (translate target (cons block stack))))]
+      [13 (define primitive-number (next-byte!))
+          (match primitive-number
+            [8 (let ((v (gensym 'blockresult))
+                     (block (car stack))
+                     (argc (- arg 1))
+                     (stack (cdr stack)))
+                 `(match ,block
+                    [(unffiv block-proc)
+                     (block-proc vm
+                                 ;; TODO vvv : use case-lambda to translate the context chain
+                                 k ;; not (lambda (,v) ,(translate ip (cons v (drop stack argc))))
+                                 ;; ^ reason being the image BUGGILY (?!?) relies on primitive 8
+                                 ;; immediately returning to the surrounding context!!
+                                 ,@(reverse (take stack argc)))]
+                    [(obj (== BLOCK) _)
+                     (k ((block->thunk vm ,block (list ,@(reverse (take stack argc))))))]))]
+            [34 'NIL]
+            [35 (let@ [ctxref (gen-build-jit-context c ip stack)]
+                      (translate ip (cons ctxref stack)))]
+            [36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))]
+                      (translate ip (cons arr (drop stack arg))))]
+            [_ (let ((generator (hash-ref *primitive-code-snippets*
+                                          primitive-number
+                                          (lambda () (error 'gen-code
+                                                            "Unknown primitive: ~a"
+                                                            primitive-number)))))
+                 (let@ [primresult (generator 'vm (reverse (take stack arg)))]
+                       (translate ip (cons primresult (drop stack arg)))))])]
+      [14 (let@ [clsvar `(slotAt (obj-class* vm self) ,(+ arg 5))]
+                (translate ip (cons clsvar stack)))]
+      [15 (match arg
+            [1 `(k self)]
+            [2 `(k ,(car stack))]
+            [3 `(outer-k ,(car stack))]
+            [5 (translate ip (cdr stack))]
+            [6 (gen-jump-to-label c (next-byte!) stack)]
+            [7 (let ((target (next-byte!)))
+                 (log-vm/jit-debug "if ~a true jump to ~a, else continue at ~a" (car stack) target ip)
+                 `(if (eq? ,(car stack) TRUE)
+                      ,(gen-jump-to-label c target (cdr stack))
+                      ,(gen-jump-to-label c ip (cdr stack))))]
+            [8 (let ((target (next-byte!)))
+                 (log-vm/jit-debug "if ~a false jump to ~a, else continue at ~a" (car stack) target ip)
+                 `(if (eq? ,(car stack) FALSE)
+                      ,(gen-jump-to-label c target (cdr stack))
+                      ,(gen-jump-to-label c ip (cdr stack))))]
+            ;; 11 inlined in the processing of bytecode 8
+            [_ (error 'gen-code "Unhandled do-special case ~v" arg)])]
+      [_ (error 'gen-code "Method ~v - unhandled opcode ~v, arg ~v"
+                (slotAt (compilation-method c) 0) ;; selector
+                opcode
+                arg)])))
+
+(define (gen-jump-to-label c ip stack)
+  (define labels (compilation-labels c))
+  (when (not (hash-has-key? labels ip))
+    (hash-set! labels ip 'placeholder)
+    (define actual-label
+      (let ((newstack (for/list [(i (length stack))] (mksym "stack~a" i))))
+        `(lambda (k ,@newstack) ,(gen-code c ip newstack))))
+    (hash-set! labels ip actual-label))
+  `(,(mksym "label~a" ip) k ,@stack))
+
+(define (gen-label-definitions c body-exp)
+  `(letrec (,@(for/list [((ip label) (in-hash (compilation-labels c)))]
+                `(,(mksym "label~a" ip) ,label)))
+     ,body-exp))
+
+(define (finish-compilation c compile-time-vm inner-code)
+  (define litmap (compilation-result-litmap (compilation-state c)))
+  (define pic-definitions
+    (for/list [(pi (reverse (compilation-result-pic-list-rev (compilation-state c))))]
+      (define extension (pic-info-extension pi))
+      `(define ,(pic-info-variable pi)
+         ,(if (null? extension)
+              `(pic)
+              `(extended-pic
+                ,@(append-map (lambda (entry)
+                                (list (and (car entry) (gen-lit* litmap (car entry)))
+                                      (and (cadr entry) (gen-lit* litmap (cadr entry)))))
+                              (take (append extension empty-pic-extension) pic-entry-count)))))))
+  (define litmap-list (hash->list litmap))
+  (define code
+    `(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(map cdr litmap-list))
+       ,@pic-definitions
+       ,inner-code))
+
+  (log-vm/jit/code-debug "Resulting code for ~a:\n~a"
+                         (compilation-method-name c)
+                         (pretty-format code))
+  (define literals (slotAt (compilation-method c) 2))
+  (define defining-class (slotAt (compilation-method c) 5))
+  (apply (eval code ns)
+         (compilation-method c)
+         (slotAt defining-class 1) ;; defining class's superclass
+         (VM-nil compile-time-vm) ;; assuming this VM is the one that will be used at call time!
+         (VM-true compile-time-vm)
+         (VM-false compile-time-vm)
+         (VM-Array compile-time-vm)
+         (VM-Block compile-time-vm)
+         (map car litmap-list)))
+
+(define (outermost-k vm)
+  (case-lambda [() (VM-nil vm)]
+               [(result) result]))
+
+;;===========================================================================
+;; Recompilation
+
+(define (recompilation-candidate vm ctx)
+  (let search ((ctx ctx) (candidate #f) (candidate-class #f) (candidate-hotness 0))
+    (cond
+      [(eq? (VM-nil vm) ctx) (values candidate candidate-class)]
+      [else (define method (slotAt ctx 0))
+            (define receiver (slotAt (slotAt ctx 1) 0))
+            (define receiver-class (obj-class* vm receiver))
+            (define next-ctx (slotAt ctx 6))
+            (log-vm/jit/recompile/candidates-debug "  ~a" (method-name method receiver-class))
+            (define cached-method (bytecode->cached-compiled vm receiver-class method))
+            (define compiled-method (unwrap-cached-method vm cached-method))
+            (cond
+              [(not compiled-method) (search next-ctx candidate candidate-class candidate-hotness)]
+              [else
+               (match-define (compiled-method-info (== method eq?) pics stable?) (compiled-method))
+               (log-vm/jit/recompile/candidates-debug "    has ~a bytes of bytecode; ~a"
+                                                      (bytes-length (bv-bytes (slotAt method 1)))
+                                                      (if stable? "stable" "not yet stable"))
+               (define hotness
+                 (for/sum [(entry pics)]
+                   (match-define (cons pi pic) entry)
+                   (for/sum [(i (in-range (pic-size pic)))]
+                     (match (pic@ pic i 0)
+                       [#f 0]
+                       [slot-class
+                        (define slot-cm (pic@ pic i 1))
+                        (unwrap-cached-method vm slot-cm) ;; fills cache entry
+                        (define slot-bmethod (cached-method-bytecode-method slot-cm))
+                        (define slot-count (pic@ pic i 2))
+                        (define bytecode-count (bytes-length (bv-bytes (slotAt slot-bmethod 1))))
+                        (define weight (/ 40.0 bytecode-count))
+                        (log-vm/jit/recompile/candidates-debug
+                         "      ~a context ~a class ~a count ~a length ~a weight ~a"
+                         (pic-info-name-bytes pi)
+                         (pic-info-context pi)
+                         (bv->string (slotAt slot-class 0))
+                         slot-count
+                         bytecode-count
+                         weight)
+                        (if (< weight 1)
+                            0
+                            (* slot-count weight))]))))
+               (log-vm/jit/recompile/candidates-debug "    hotness: ~a" hotness)
+               (if (and (> hotness candidate-hotness) (not stable?))
+                   (search next-ctx method receiver-class hotness)
+                   (search next-ctx candidate candidate-class candidate-hotness))])])))
+
+(define (recompile-method! vm class method)
+  (log-vm/jit/recompile-info "Recompiling ~a" (method-name method class))
+  (define cached-method (bytecode->cached-compiled vm class method))
+  (define old-proc (cached-method-proc cached-method))
+  (define old-picmap
+    (for/hash [(entry (in-list (if old-proc (compiled-method-info-pics (old-proc)) '())))]
+      (define pi (car entry))
+      (values (pic-info-context pi) entry)))
+  (when (not (hash-empty? old-picmap))
+    (log-vm/jit/recompile-info "Retrieved old pics for method ~a" (method-name method class))
+    (for [((i p) (in-hash old-picmap))]
+      (log-vm/jit/recompile-info "   ~a --> ~v" (format-compilation-context i) p)))
+  (define recompiled-proc (compile-method-proc vm class method old-picmap))
+  (log-vm/jit/recompile-info "Updating cached compiled method for ~a" (method-name method class))
+  (set-cached-method-proc! cached-method recompiled-proc))
+
+(define (recompile-something vm ctx)
+  (define-values (candidate candidate-class) (recompilation-candidate vm ctx))
+  (if candidate
+      (recompile-method! vm candidate-class candidate)
+      (log-vm/jit/recompile-debug "No recompilation candidate available?")))
+
+;;===========================================================================
+;; VM-specific primitives (aside from the core primitives found in `gen-code`)
+
+(define-primitive vm [6 inner-ctx] ;; "new context execute"
+  (when (not (zero? (slotAt inner-ctx 5))) (error 'execute "Cannot execute from nonempty stack"))
+  (when (not (zero? (slotAt inner-ctx 4))) (error 'execute "Cannot execute from nonzero IP"))
+  (define args (slotAt inner-ctx 1))
+  (define f (compile-method-proc vm (obj-class* vm (slotAt args 0)) (slotAt inner-ctx 0) #f))
+  (apply f vm (outermost-k vm) (vector->list (obj-slots args))))
+
+(define-primitive vm [116]
+  (let ((image-bytes (serialize-image vm)))
+    (display-to-file image-bytes (jit-VM-image-filename vm) #:exists 'replace)))
+
+;;===========================================================================
+;; Entry point
+
+(pretty-print-columns 230)
+(let* ((image-filename "SmallWorld/src/image")
+       (vm (call-with-input-file image-filename
+             (lambda (fh)
+               (read-image fh jit-VM (list (make-weak-hasheq) image-filename))))))
+  (boot-image vm
+              (lambda (vm source)
+                (define compiled-method
+                  (unwrap-cached-method vm (lookup-method/cache vm (obj-class source) #"doIt")))
+                (compiled-method vm (outermost-k vm) source))
+              (current-command-line-arguments)))