WIP, not running yet; needs work on home context references
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Sun, 29 Jul 2018 16:20:03 +0100
changeset 425 a7f739fa4dee
parent 424 e55f9163af2f
child 426 930c499509be
WIP, not running yet; needs work on home context references
experiments/little-smalltalk/pe-SmallWorld-2015.rkt
--- a/experiments/little-smalltalk/pe-SmallWorld-2015.rkt	Sun Jul 29 06:15:15 2018 +0100
+++ b/experiments/little-smalltalk/pe-SmallWorld-2015.rkt	Sun Jul 29 16:20:03 2018 +0100
@@ -29,18 +29,84 @@
      (lambda args
        (thread (match action
                  [(unffiv block-proc)
-                  (lambda () (apply block-proc vm (outermost-k vm) args))]
+                  (lambda () (apply block-proc (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))
+;; Just as the plain interpreter, `run-SmallWorld-2015.rkt`, builds
+;; contexts at runtime describing a method activation, the JIT builds
+;; contexts at compile time describing a method activation.
+;;
+;; A complication is that, thanks to inlining, our contexts take two
+;; forms: "outer" and "inner", representing a regular entry point
+;; (with a statically unknown calling context) and an inlined entry
+;; point (with statically known context) to a method, respectively.
+;;
+;; Each outer context includes registers shared among all its inner
+;; contexts as well as registers particular to itself. Inner contexts
+;; know their outer context as well as their immediate calling
+;; context; sometimes these are one and the same.
+;;
+;; Runtime contexts include these registers:
+;;   - method, the bytecoded method being interpreted
+;;   - arguments, an Array of arguments to this activation
+;;   - temporaries, an Array of temporaries for this activation
+;;   - stack, an Array of size (slotAt method 3), an empty ascending stack
+;;   - ip, an index into `method`'s bytecode
+;;   - stack-top, an index into `stack`
+;;   - previous-ctx, either nil or a reference to a calling context
+;;
+;; Our contexts will include compile-time analogues of these. Almost
+;; everywhere that a runtime context refers to a value, our
+;; compile-time contexts will refer to an abstract value instead.
+;;
+;; Both outer and inner contexts will include common fields:
+;;   - vm, the compile-time vm
+;;   - method, a concrete value
+;;   - arguments, a Racket vector of abstract-values
+;;   - temporaries, a symbol naming the Racket-level temporaries vector
+;;   - stack, a Racket list of abstract-values; car = top of stack
+;;   - ip, a Racket number
+;;   - labels, a hashtable of code fragments roughly corresponding to basic blocks
+;;   - home, #f or the home context of a block
+;;
+;; Outer contexts will include these fields alongside the common fields:
+;;   - litmap, a Racket mutable hash table mapping actual runtime
+;;     values to compile-time variable names (symbols)
+;;   - pic-list-rev, a Racket list of symbols naming PICs in the
+;;     compiled method
+;;   - old-picmap, either #f or a hash indexing PICs from a previous
+;;     compilation, for dynamic type feedback
+;;   - histories, a Racket parameter holding a list of lists of
+;;     `definition` structures
+;;
+;; Inner contexts will include these fields alongside the common fields:
+;;   - previous, either an inner or an outer context (TODO: or #f ??)
+;;   - outer, the outermost context for this compilation
+;;
+(struct Ctx (vm method arguments temporaries stack ip labels home detail) #:transparent
+  #:methods gen:custom-write
+  [(define (write-proc c port mode)
+     (fprintf port "#<~a>" (format-Ctx c)))])
+(struct DynamicCtx (var) #:transparent)
+
+(struct OuterCtx (litmap [pic-list-rev #:mutable] old-picmap histories) #:transparent)
+(struct InnerCtx (previous outer) #:transparent)
 
 (struct compiled-method-info (bytecode-method pics stable?))
 
 (struct cached-method (class name-bytes [bytecode-method #:mutable] [proc #:mutable]))
 
+(struct definition (var purity absval) #:transparent)
+
+(struct AbsVal (expr desc) #:transparent)
+
+(struct Unknown ())
+(struct Constant (value) #:transparent)
+(struct Obj (class slots) #:transparent)
+(struct Bv Obj (bytes) #:transparent)
+(struct Ffiv Obj (value) #:transparent)
+
 ;;===========================================================================
 ;; Polymorphic Inline Caches - PICs
 
@@ -119,7 +185,7 @@
     (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)))
+                   (send-dnu vm 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?
@@ -130,46 +196,38 @@
                   (pic@! pic slot-index 1 cm)
                   (pic@! pic slot-index 2 1))
                 (or (unwrap-cached-method vm cm)
-                    (send-dnu class selector))))))))
+                    (send-dnu vm class selector))))))))
 
-(define ((send-dnu class selector) vm ctx . args)
+(define ((send-dnu vm class selector) 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))]))
+     (dnu-method 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 litmap (make-hasheq))
+  (Ctx-log 'top-compilation
+           (Ctx vm
+                method
+                (for/vector [(i (selector-string-arity (method-name method)))]
+                  (if (zero? i)
+                      (AbsVal 'self (Obj (gen-lit litmap receiver-class) #f))
+                      (AbsVal (mksym "arg~a" (- i 1)) (Unknown))))
+                (gensym 'temps)
+                '()
+                0
+                (make-hash)
+                #f
+                (OuterCtx litmap
+                          '()
+                          old-picmap
+                          (make-parameter '())))))
 
 (define (selector-string-arity str)
   (define colon-count (for/sum [(c str)] (if (eqv? c #\:) 1 0)))
@@ -177,38 +235,105 @@
         [(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 (mksym fmt . args) (string->symbol (apply format fmt args)))
+
+(define (Ctx-log who c)
+  (log-vm/jit/code-info "~a ~a defined in ~v (depth ~a)"
+                        who
+                        (Ctx-name c)
+                        (slotAt (Ctx-method c) 5)
+                        (Ctx-depth c))
+  (log-vm/jit/code-info "  bytecode: ~a\n----\n~a\n----"
+                        (bytes->hex-string (bv-bytes (slotAt (Ctx-method c) 1)))
+                        (bv->string (slotAt (Ctx-method c) 6)))
+  c)
+
+(define (Ctx-outer c)
+  (define d (Ctx-detail c))
+  (if (OuterCtx? d)
+      d
+      (InnerCtx-outer d)))
 
-(define (compilation-depth c)
-  (define o (compilation-outer c))
-  (if o (+ 1 (compilation-depth o)) 0))
+(define (inline-compilation previous method actual-avs temporaries ip home)
+  (Ctx-log 'inline-compilation
+           (Ctx (Ctx-vm previous)
+                method
+                actual-avs
+                (or temporaries (gensym (format "temps~a" (method-name method))))
+                '()
+                ip
+                (make-hash)
+                home
+                (InnerCtx previous
+                          (Ctx-outer previous)))))
+
+(define (Ctx-previous c)
+  (define d (Ctx-detail c))
+  (and (InnerCtx? d) (InnerCtx-previous d)))
+
+(define (Ctx-depth c)
+  (+ 1 (cond [(Ctx-previous c) => Ctx-depth]
+             [else 0])))
+
+(define (Ctx-arg c n)
+  (vector-ref (Ctx-arguments c) n))
+
+(define (Ctx-receiver c)
+  (Ctx-arg c 0))
+
+(define (Ctx-receiver-class c)
+  (Constant-value (AbsVal-desc (ObjClass (Ctx-vm c) (Ctx-receiver c)))))
+
+(define (Ctx-name c)
+  (method-name (Ctx-method c) (Ctx-receiver-class c)))
 
 (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))])))
+    (cond [(and (eq? (Ctx-receiver-class c) class) (eq? (Ctx-method c) method)) #t]
+          [(Ctx-previous c) => check]
+          [else #f])))
 
 (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)))))
+  (if (number? lit)
+      lit
+      (hash-ref! litmap lit (lambda ()
+                              (define n (hash-count litmap))
+                              (cond
+                                [(bv? lit) (mksym "lit~a-~a" n (bv->string lit))]
+                                [(list? lit) (mksym "lit~a" n)]
+                                [(vector? lit) (mksym "pic~a" n)]
+                                [else (mksym "lit~a-~a" n lit)])))))
 
-(define (compilation-litname c literal)
-  (hash-ref (compilation-result-litmap (compilation-state c)) literal))
+(define (gen-lit litmap lit)
+  (AbsVal (gen-lit* litmap lit) (Constant lit)))
+
+(define (Ctx-litmap c)
+  (OuterCtx-litmap (Ctx-outer c)))
+
+(define (Ctx-lit c literal)
+  (gen-lit (Ctx-litmap 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 (Ctx-update c new-ip stack-transformer)
+  (struct-copy Ctx c [ip new-ip] [stack (stack-transformer (Ctx-stack c))]))
+
+(define (Ctx-push c v)
+  (Ctx-update c (Ctx-ip c) (lambda (s) (cons v s))))
+
+(define (Ctx-drop c n)
+  (Ctx-update c (Ctx-ip c) (lambda (s) (drop s n))))
 
-(define (format-compilation-context x)
+(define (Ctx-goto c ip)
+  (Ctx-update c ip values))
+
+(define (Ctx-push-and-goto c ip v)
+  (Ctx-update c ip (lambda (s) (cons v s))))
+
+(define (format-Ctx c)
   (string-join (reverse
-                (map (match-lambda [(list c m ip) (format "~a @~a" (method-name m c) ip)]) x))
+                (let pieces ((c c))
+                  (cons (format "~a @~a" (Ctx-name c) (Ctx-ip c))
+                        (cond [(Ctx-previous c) => pieces]
+                              [else '()]))))
                ","
                #:before-first "["
                #:after-last "]"))
@@ -218,11 +343,11 @@
 
 (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 body-code (gen-code c)) ;; imperative!
+  (define pic-infos (reverse (OuterCtx-pic-list-rev (Ctx-outer c))))
+  (define pic-infos-exp (gen-lit* (Ctx-litmap c) pic-infos))
   (define stable? (equal? (if old-picmap (list->set (hash-keys old-picmap)) 'unknown)
-                          (list->set (map pic-info-context pic-infos))))
+                          (list->set (map car pic-infos)))) ;; TODO too fine
   (when stable?
     (log-vm/jit/recompile-info "Compilation of ~a is now stable." (method-name method class)))
   (define inner-code
@@ -234,12 +359,13 @@
             (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))
+                   ,pic-infos-exp
                    ,stable?)))
           cmi]
-         [(vm k ,@(vector->list (compilation-argnames c)))
+         [(k ,@(map AbsVal-expr (vector->list (Ctx-arguments c))))
+          (log-vm/jit-debug "Entering ~a with ~a"
+                            ,(method-name method class)
+                            (list ,@(map AbsVal-expr (vector->list (Ctx-arguments 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)
@@ -247,27 +373,35 @@
             (recompile-something vm (k))
             ;; (set! call-counter 0)
             )
-          (let ((outer-k k)
-                (temporaries ,(gen-fresh-temps method)))
-            ,(gen-label-definitions c body-code))])))
+          ,(gen-fresh-temps c (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 (finish-compilation c vm inner-code)
+  (define litmap-list (hash->list (Ctx-litmap c)))
+  (define code
+    `(lambda (vm ,@(map cdr litmap-list))
+       ,inner-code))
+  (log-vm/jit/code-debug "Resulting code for ~a:\n~a" (Ctx-name c) (pretty-format code))
+  (apply (eval code ns)
+         vm
+         (map car litmap-list)))
+
+;; (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 ,@(map AbsVal-expr (vector->list (compilation-argabsvals 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 ()
@@ -276,308 +410,492 @@
     (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)))
+    (error 'block->thunk "Unimplemented")
+    ;; (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)
+(define (gen-build-jit-context c)
   `(build-jit-context vm
-                      (k)
-                      (vector ,@(vector->list (compilation-argnames c)))
-                      method
-                      ,ip
-                      temporaries
-                      (vector ,@(reverse stack))))
+                      ,(cond [(Ctx-previous c) => gen-build-jit-context]
+                             [else `k])
+                      (vector ,@(map AbsVal-expr (vector->list (Ctx-arguments c))))
+                      ,(AbsVal-expr (Ctx-lit c (Ctx-method c)))
+                      ,(Ctx-ip c)
+                      ,(Ctx-temporaries c)
+                      (vector ,@(map AbsVal-expr (reverse (Ctx-stack c))))))
 
-(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 (gen-fresh-temps c body-code)
+  `(let ((,(Ctx-temporaries c)
+          ,(match (slotAt (Ctx-method c) 4)
+             [0 `'#()]
+             [temp-count
+              `(make-vector ,temp-count ,(AbsVal-expr (Ctx-lit c (VM-nil (Ctx-vm c)))))])))
+     ,body-code))
 
 (define (bytecode-exceeding? method limit)
   (define bytecode (bv-bytes (slotAt method 1)))
+  (log-vm/jit/code-debug "Method ~v bytecode length ~a compared against limit ~a"
+                         (method-name method)
+                         (bytes-length bytecode)
+                         limit)
   (> (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)
+(define (gen-pic c extension)
+  (define p (if (null? extension)
+                (pic)
+                (apply extended-pic
+                       (flatten (take (append extension empty-pic-extension) pic-entry-count)))))
+  (set-OuterCtx-pic-list-rev! (Ctx-outer c) (cons (cons c p) (OuterCtx-pic-list-rev (Ctx-outer c))))
+  (gen-lit* (Ctx-litmap c) p))
 
 ;; 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 (gen-inline-send kc method arg-avs)
+  (define ic (inline-compilation kc method (list->vector arg-avs) #f 0 kc))
+  (log-vm/jit/code-info "Inlining send of ~a into method ~a" (Ctx-name ic) (Ctx-name kc))
+  (define body-code
+    `(begin
+       (log-vm/jit/code-debug "Entering inlined send of ~a returning to ~a with ~a"
+                              ,(method-name method)
+                              ,(format-Ctx kc)
+                              (list ,@(map AbsVal-expr arg-avs)))
+       ,(gen-fresh-temps ic (gen-label-definitions ic (gen-code ic)))))
+  ;; (log-vm/jit/code-debug "INLINED:\n~a" (pretty-format body-code))
+  body-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
+    (unwrap-cached-method (Ctx-vm c) (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 (tiny-method? bmethod) (not (bytecode-exceeding? bmethod 32)))
+(define (small-method? bmethod) (not (bytecode-exceeding? bmethod 40)))
+
+(define (Ctx->expr c)
+  (if c
+      (let ((result (gensym 'answer)))
+        `(case-lambda [() ,(gen-build-jit-context c)]
+                      [(,result)
+                       (log-vm/jit-debug "Continuing ~a with ~a" ,(format-Ctx c) ,result)
+                       ,(truncate-histories c (gen-code (Ctx-push c (AbsVal result (Unknown)))))]))
+      `k))
 
-(define (gen-block c argument-location ip)
-  (define temp-count (slotAt (compilation-method c) 4))
-  `(lambda (vm k . block-arguments)
+(define (gen-send c class-absval name-bytes selector-absval arg-avs kc)
+  (log-vm/jit-info "Send of ~a at ~a returning to ~a" name-bytes c kc)
+  (define vm (Ctx-vm c))
+  (define class-desc (AbsVal-desc class-absval))
+  ;; (log-vm/jit-info "class-absval is ~a" class-absval)
+  (log-vm/jit-info "arg-avs = ~a" arg-avs)
+  (if (Constant? class-desc)
+      (let* ((class (Constant-value class-desc))
+             (cm (lookup-method/cache vm class name-bytes))
+             (bmethod (or (cached-method-bytecode-method cm)
+                          (lookup-method vm class name-bytes)
+                          (error 'gen-send "DNU at compile time: ~a ~a" class name-bytes))))
+        (if (or (already-compiling? c class bmethod)
+                (not (tiny-method? bmethod))
+                (not (sufficiently-static? c arg-avs)))
+            `((unwrap-cached-method vm ,(AbsVal-expr (Ctx-lit c cm)))
+              ,(Ctx->expr kc) ,@(map AbsVal-expr arg-avs))
+            (gen-inline-send kc bmethod arg-avs)))
+      (let ()
+        (define old-picmap (OuterCtx-old-picmap (Ctx-outer c)))
+        (define old-entry (and old-picmap (hash-ref old-picmap c #f)))
+        (define previous-pic-entries (if old-entry (analyse-pic c old-entry) '()))
+        (define pic-m (gen-pic c previous-pic-entries))
+        `(let ((k-send ,(Ctx->expr kc)))
+           ,(let loop ((predictions previous-pic-entries) (counter pic-entry-count))
+              (match predictions
+                ['()
+                 `((lookup-message/jit vm ,pic-m ,(AbsVal-expr class-absval) ,(AbsVal-expr selector-absval))
+                   k-send ,@(map AbsVal-expr arg-avs))]
+                [(cons (list predicted-class predicted-cm) more-predictions)
+                 (define predicted-bmethod (cached-method-bytecode-method predicted-cm))
+                 (define final-arg-avs (augment-receiver-class c arg-avs predicted-class))
+                 `(if (eq? ,(AbsVal-expr class-absval) ,(AbsVal-expr (Ctx-lit c predicted-class)))
+                      (begin
+                        (pic-bump! ,pic-m ,counter)
+                        ,(if (or (already-compiling? c predicted-class predicted-bmethod)
+                                 (not (small-method? predicted-bmethod))
+                                 (not (sufficiently-static? c final-arg-avs)))
+                             `((unwrap-cached-method vm ,(AbsVal-expr (Ctx-lit c predicted-cm)))
+                               k-send ,@(map AbsVal-expr final-arg-avs))
+                             (gen-inline-send kc predicted-bmethod final-arg-avs)))
+                      ,(loop more-predictions (+ counter 1)))]))))))
+
+(define (sufficiently-static? c avs)
+  (or (andmap (lambda (av) (not (Unknown? (AbsVal-desc av)))) avs)
+      (< (Ctx-depth c) 3)))
+
+(define (augment-receiver-class c arg-avs class)
+  (match-define (cons (AbsVal expr _desc) rest) arg-avs)
+  (cons (AbsVal expr (Obj (Ctx-lit c class) #f)) rest))
+
+(define (gen-block c argument-location)
+  (define temp-count (slotAt (Ctx-method c) 4))
+  `(lambda (k . block-arguments)
+     (log-vm/jit-info "Entering block at ~a with ~a" ,(format-Ctx c) block-arguments)
      ,(let loop ((i argument-location))
         (if (>= i temp-count)
             `(void)
             `(when (pair? block-arguments)
-               (vector-set! temporaries ,i (car block-arguments))
+               (vector-set! ,(Ctx-temporaries c) ,i (car block-arguments))
                (let ((block-arguments (cdr block-arguments)))
                  ,(loop (+ i 1))))))
-     ,(gen-code c ip '())))
+     ,(let* ((c (struct-copy Ctx c [home (Ctx-previous c)])))
+        (truncate-histories c (gen-code c)))))
+
+(define (emit* c var purity absval)
+  (define param (OuterCtx-histories (Ctx-outer c)))
+  (match-define (cons era hs) (param))
+  (param (cons (cons (definition var purity absval) era) hs))
+  (AbsVal var (AbsVal-desc absval)))
 
-(define-syntax let@
+(define (historical-match c purity expr)
+  (define param (OuterCtx-histories (Ctx-outer c)))
+  (and (eq? purity 'pure)
+       (let search-hs ((hs (param)))
+         (match hs
+           ['() #f]
+           [(cons era hs)
+            (let search-era ((era era))
+              (match era
+                ['() (search-hs hs)]
+                [(cons (definition var 'pure (AbsVal (== expr) desc)) _) (AbsVal var desc)]
+                [(cons _ era) (search-era era)]))]))))
+
+(define-syntax emit
   (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))]))
+    [(_ c-expr [(var vargen) purity absval-expr] body-expr)
+     (let* ((c c-expr)
+            (absval absval-expr))
+       (let ((var (or (historical-match c 'purity (AbsVal-expr absval))
+                      (emit* c vargen 'purity absval))))
+         body-expr))]
+    [(_ c-expr [var purity absval-expr] body-expr)
+     (emit c-expr [(var (gensym 'var)) purity absval-expr] body-expr)]))
+
+(define-syntax-rule (residualize c code-expr)
+  (let ((param (OuterCtx-histories (Ctx-outer c))))
+    (parameterize ((param (cons '() (param))))
+      (define code code-expr)
+      (wrap-era (car (param)) code (free-names code)))))
+
+(define-syntax-rule (truncate-histories c-expr code-expr)
+  (let* ((c c-expr)
+         (param (OuterCtx-histories (Ctx-outer c))))
+    (parameterize ((param '()))
+      (residualize c code-expr))))
+
+(define (wrap-era era body outstanding)
+  (match era
+    ['() body]
+    [(cons (definition var purity (AbsVal expr _desc)) era)
+     (if (or (eq? purity 'effect) (set-member? outstanding var))
+         (wrap-era era
+                   (if (equal? body var) expr `(let ((,var ,expr)) ,body))
+                   (set-remove (set-union (free-names expr) outstanding) var))
+         (wrap-era era body (set-remove outstanding var)))]))
+
+(define (free-names expr)
+  (log-vm-warning "free-names is a hideous overapproximation")
+  (match expr
+    [(? symbol? n) (seteq n)]
+    [`(,exprs ...) (apply set-union (seteq) (map free-names exprs))]
+    [_ (seteq)]))
+
+(define (SlotAt c absval index)
+  (match (AbsVal-desc absval)
+    [(Obj _ (? vector? slot-absvals)) (vector-ref slot-absvals index)]
+    [_ (AbsVal `(slotAt ,(AbsVal-expr absval) ,index) (Unknown))]))
+
+(define (ObjClass vm absval)
+  (match (AbsVal-desc absval)
+    [(Obj cls _) cls]
+    [(Constant v) (AbsVal `(obj-class* vm ,(AbsVal-expr absval)) (Constant (obj-class* vm v)))]
+    [_ (AbsVal `(obj-class* vm ,(AbsVal-expr absval)) (Unknown))]))
+
+(define (read-opcode read-byte)
+  (define byte (read-byte))
+  (define low (bitwise-and byte #x0f))
+  (define high (bitwise-and (arithmetic-shift byte -4) #x0f))
+  (if (zero? high)
+      (values low (read-byte))
+      (values high low)))
 
-(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-code c)
+  (log-vm/jit-debug "gen-code for ~a, stack ~a" c (Ctx-stack c))
+  (residualize
+   c
+   (let translate ((c c))
+     (define vm (Ctx-vm c))
+     (define method (Ctx-method c))
+     (define bytecode (bv-bytes (slotAt method 1)))
+     (define literals (slotAt method 2))
+     (define c0 c)
+     (define stack (Ctx-stack c))
+     (define (next-byte!)
+       (let ((ip (Ctx-ip c)))
+         (begin0 (bytes-ref bytecode ip)
+           (set! c (Ctx-goto c (+ ip 1))))))
+     (define (decode!) (read-opcode next-byte!))
+     (define-values (opcode arg) (decode!))
+     (log-vm/jit-debug " ~a: ~a ~a" c0 opcode arg)
+     (match opcode
+       [1 (emit c [slotval pure (SlotAt c (Ctx-receiver c) arg)] (translate (Ctx-push c slotval)))]
+       [2 (translate (Ctx-push c (Ctx-arg c arg)))]
+       [3 (emit c [(n (gensym (format "temp~a-" arg)))
+                   pure
+                   (AbsVal `(vector-ref ,(Ctx-temporaries c) ,arg) (Unknown))]
+                (translate (Ctx-push c n)))]
+       [4 (translate (Ctx-push c (Ctx-lit c (slotAt literals arg))))]
+       [5 (translate (Ctx-push c (Ctx-lit c (match arg
+                                              [(or 0 1 2 3 4 5 6 7 8 9) arg]
+                                              [10 (VM-nil vm)]
+                                              [11 (VM-true vm)]
+                                              [12 (VM-false vm)]))))]
+       [6 (let ((self-expr (AbsVal-expr (Ctx-receiver c)))
+                (val-expr (AbsVal-expr (car stack))))
+            (emit c [ignored effect (AbsVal `(slotAtPut ,self-expr ,arg ,val-expr) (Unknown))]
+                  (truncate-histories c (translate c))))]
+       [7 (let ((val-expr (AbsVal-expr (car stack))))
+            (emit c [ignored effect (AbsVal `(vector-set! ,(Ctx-temporaries c) ,arg ,val-expr)
+                                            (Unknown))]
+                  (truncate-histories c (translate c))))]
+       [8 (let* ((arg-count arg)
+                 (args (reverse (take stack arg-count))))
+            (set! c (Ctx-drop c arg-count))
+            (define-values (selector-literal-index class-absval)
+              (match/values (decode!)
+                [(9 selector-literal-index)
+                 (emit c [cls pure (ObjClass vm (car args))]
+                       (values selector-literal-index cls))]
+                [(15 11)
+                 (define super (slotAt (slotAt method 5) 1))
+                 (values (next-byte!) (Ctx-lit c super))]))
+            (define selector (slotAt literals selector-literal-index))
+            (gen-send c0 class-absval (bv-bytes selector) (Ctx-lit c selector) args c))]
+       ;; 9 inlined in the processing of bytecode 8
+       [10 (match arg
+             [0 (emit c [isNil pure
+                               (if (equal? (Constant (VM-nil vm)) (AbsVal-desc (car stack)))
+                                   (Ctx-lit c (VM-true vm))
+                                   (AbsVal `(boolean->obj vm (eq? ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))
+                                                                  ,(AbsVal-expr (car stack))))
+                                           (Unknown)))]
+                      (translate (Ctx-push (Ctx-drop c 1) isNil)))]
+             [1 (emit c [notNil pure
+                                (if (equal? (Constant (VM-nil vm)) (AbsVal-desc (car stack)))
+                                    (Ctx-lit c (VM-false vm))
+                                    (AbsVal `(boolean->obj vm (not (eq? ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))
+                                                                        ,(AbsVal-expr (car stack)))))
+                                            (Unknown)))]
+                      (translate (Ctx-push (Ctx-drop c 1) notNil)))])]
+       [11 (match stack
+             [(list* jv iv _stack)
+              ;; TODO: Fix now-unwanted special-casing of these sends. REQUIRES
+              ;; IMAGE CHANGES, particularly in `addToSmallInt:`.
+              (set! c (Ctx-drop c 2))
+              (define i (AbsVal-expr iv))
+              (define j (AbsVal-expr jv))
+              `(if (and (number? ,i) (number? ,j))
+                   ,(residualize c
+                                 (emit c [opresult pure (AbsVal (match arg
+                                                                  [0 `(boolean->obj vm (< ,i ,j))]
+                                                                  [1 `(boolean->obj vm (<= ,i ,j))]
+                                                                  [2 `(+ ,i ,j)])
+                                                                (Unknown))]
+                                       (translate (Ctx-push c opresult))))
+                   ,(residualize c
+                                 (let ((name-bytes (match arg [0 #"<"] [1 #"<="] [2 #"+"])))
+                                   (gen-send c0
+                                             (ObjClass vm iv)
+                                             name-bytes
+                                             (AbsVal `(mkbv ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))
+                                                            ,name-bytes)
+                                                     (Bv (Ctx-lit c (VM-nil vm))
+                                                         (vector)
+                                                         name-bytes))
+                                             (list iv jv)
+                                             c))))])]
+       [12 (let ((target (next-byte!))
+                 (argument-location arg))
+             (emit c [block pure (AbsVal `(mkffiv ,(AbsVal-expr (Ctx-lit c (VM-Block vm)))
+                                                  ,(gen-block c argument-location))
+                                         (Ffiv (Ctx-lit c (VM-Block vm))
+                                               #f
+                                               (let ((c c))
+                                                 (lambda (kc arg-avs)
+                                                   (log-vm/jit-debug
+                                                    "Inlining block ~a returning to ~a"
+                                                    c
+                                                    kc)
+                                                   (define home (Ctx-previous c))
+                                                   (when (not home)
+                                                     (error 'inlining-block
+                                                            "Missing home context"))
+                                                   (define ic
+                                                     (inline-compilation kc
+                                                                         method
+                                                                         (Ctx-arguments c)
+                                                                         (Ctx-temporaries c)
+                                                                         (Ctx-ip c)
+                                                                         home))
+                                                   (for [(i (in-naturals argument-location))
+                                                         (arg arg-avs)]
+                                                     (define av
+                                                       (AbsVal
+                                                        `(vector-set! ,(Ctx-temporaries c) ,i ,arg)
+                                                        (Unknown)))
+                                                     (emit ic [blkarg effect av] (void)))
+                                                   (truncate-histories c (gen-code ic))))))]
+                   (translate (Ctx-push-and-goto c target block))))]
+       [13 (define primitive-number (next-byte!))
+           (define primitive-arg-count arg)
+           (define primitive-args (reverse (take stack primitive-arg-count)))
+           (set! c (Ctx-drop c arg))
+           (match primitive-number
+             [2 (emit c [primcls pure (ObjClass vm (car primitive-args))]
+                      (translate (Ctx-push c primcls)))]
+             [7 (match-define (list class count) primitive-args)
+                (emit c [(obj (gensym (class-temp-name class)))
+                         effect
+                         (AbsVal `(obj ,(AbsVal-expr class)
+                                       (make-vector ,(AbsVal-expr count)
+                                                    ,(AbsVal-expr (Ctx-lit c (VM-nil vm)))))
+                                 (Obj class #f))]
+                      (translate (Ctx-push c obj)))]
+             [8 (let ((v (gensym 'blockresult))
+                      (block (last primitive-args))
+                      (argc (- arg 1))
+                      (primitive-args (reverse (cdr (reverse primitive-args)))))
+                  (if (and (Ffiv? block)
+                           (equal? (Constant (VM-Block vm)) (AbsVal-desc (ObjClass vm block))))
+                      ;; NB relies on tail call effect of primitive 8 (!)
+                      ((Ffiv-value block) c primitive-args)
+                      `(match ,(AbsVal-expr block)
+                         [(unffiv block-proc)
+                          (block-proc
+                           ;; TODO vvv : use case-lambda to translate the context chain
+                           ,(Ctx->expr (Ctx-previous c)) ;; not ,(Ctx->expr c)
+                           ;; ^ reason being the image BUGGILY (?!?) relies on primitive 8
+                           ;; immediately returning to the surrounding context!!
+                           ,@(map AbsVal-expr primitive-args))]
+                         [(obj (== ,(AbsVal-expr (Ctx-lit c (VM-Block vm)))) _)
+                          (log-vm/jit-warning "Unoptimized block!")
+                          ,(let ((expr `((block->thunk vm
+                                                       ,(AbsVal-expr block)
+                                                       (list ,@(map AbsVal-expr primitive-args)))))
+                                 (caller (Ctx-previous c)))
+                             (if caller
+                                 (gen-code (Ctx-push caller (AbsVal expr (Unknown))))
+                                 `(k ,expr)))])))]
+             [34 (Ctx-lit c (VM-nil vm))]
+             [35 (emit c [ctxref pure (AbsVal (gen-build-jit-context c) (Unknown))]
+                       (translate (Ctx-push c ctxref)))]
+             [36 (emit c [arr effect (AbsVal `(mkobj ,(AbsVal-expr (Ctx-lit c (VM-Array vm)))
+                                                     ,@(map AbsVal-expr primitive-args))
+                                             (Obj (Ctx-lit c (VM-Array vm))
+                                                  (list->vector primitive-args)))]
+                       (translate (Ctx-push c arr)))]
+             [_ (let ((generator (hash-ref *primitive-code-snippets*
+                                           primitive-number
+                                           (lambda () (error 'gen-code
+                                                             "Unknown primitive: ~a"
+                                                             primitive-number)))))
+                  (emit c [primresult effect
+                                      (AbsVal (generator 'vm (map AbsVal-expr primitive-args))
+                                              (Unknown))]
+                        (translate (Ctx-push c primresult))))])]
+       [14 (emit c [clsvar pure (SlotAt c (ObjClass vm (Ctx-receiver c)) (+ arg 5))]
+                 (translate (Ctx-push c clsvar)))]
+       [15 (define (continue c av)
+             (if c
+                 (translate (Ctx-push c av))
+                 `(k ,(AbsVal-expr av))))
+           (match arg
+             [1 (continue (Ctx-previous c) (Ctx-receiver c))]
+             [2 (continue (Ctx-previous c) (car stack))]
+             [3 (translate (Ctx-push (Ctx-home c) (car stack)))]
+             [5 (translate (Ctx-drop c 1))]
+             [6 (gen-jump-to-label (Ctx-goto c (next-byte!)))]
+             [7 (let ((target (next-byte!))
+                      (disc (car stack)))
+                  (set! c (Ctx-drop c 1))
+                  (log-vm/jit-debug "if ~a true jump to ~a, else continue at ~a" disc target (Ctx-ip c))
+                  (if (equal? (Constant (VM-true vm)) (AbsVal-desc disc))
+                      (gen-code (Ctx-goto c target))
+                      `(if (eq? ,(AbsVal-expr disc) ,(AbsVal-expr (Ctx-lit c (VM-true vm))))
+                           ,(gen-jump-to-label (Ctx-goto c target))
+                           ,(gen-jump-to-label c))))]
+             [8 (let ((target (next-byte!))
+                      (disc (car stack)))
+                  (set! c (Ctx-drop c 1))
+                  (log-vm/jit-debug "if ~a false jump to ~a, else continue at ~a" disc target (Ctx-ip c))
+                  (if (equal? (Constant (VM-false vm)) (AbsVal-desc disc))
+                      (gen-code (Ctx-goto c target))
+                      `(if (eq? ,(AbsVal-expr disc) ,(AbsVal-expr (Ctx-lit c (VM-false vm))))
+                           ,(gen-jump-to-label (Ctx-goto c target))
+                           ,(gen-jump-to-label c))))]
+             ;; 11 inlined in the processing of bytecode 8
+             [_ (error 'gen-code "Unhandled do-special case ~v" arg)])]
+       [_ (error 'gen-code "~a - unhandled opcode ~v, arg ~v" (Ctx-name c) 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 (class-temp-name av)
+  (match (AbsVal-desc av)
+    [(Constant (obj _ (vector (? bv? name) _ ...)))
+     (string-append "new" (bv->string name))]
+    [_
+     "newobj"]))
+
+;; (define (dump-full-context c)
+;;   (log-vm/jit-debug "FULL CONTEXT:")
+;;   (let loop ((c c))
+;;     (log-vm/jit-debug "  ~a: stack ~a" c (Ctx-stack c))
+;;     (cond [(Ctx-previous c) => loop]
+;;           [else (void)]))
+;;   (log-vm/jit-debug "HISTORIES: ~a" ((OuterCtx-histories (Ctx-outer c)))))
+
+(define (gen-jump-to-label c)
+  (define labels (Ctx-labels c))
+  (define key (Ctx-ip c))
+  (when (not (hash-has-key? labels key))
+    (define var
+      (gensym (mksym "label-~a-~a-"
+                     (bv->string (slotAt (Ctx-method c) 0))
+                     (Ctx-ip c))))
+    (hash-set! labels key (cons 'placeholder var))
+    (define newstack (for/list [(i (length (Ctx-stack c)))] (AbsVal (mksym "stack~a" i) (Unknown))))
+    (log-vm/jit-debug "Producing label ~a" var)
+    (define expr (truncate-histories
+                  c
+                  (let* ((c c)
+                         (c (Ctx-update c (Ctx-ip c) (lambda (_s) newstack)))
+                         (c (struct-copy Ctx c [detail (let ((d (Ctx-detail c)))
+                                                         (if (InnerCtx? d)
+                                                             (struct-copy InnerCtx d [previous #f])
+                                                             d))])))
+                    ;; (dump-full-context c)
+                    (gen-code c))))
+    (log-vm/jit-debug "Produced label ~a" var)
+    (hash-set! labels key (cons `(lambda (k ,@(map AbsVal-expr newstack)) ,expr) var)))
+  `(,(cdr (hash-ref labels key))
+    ,(Ctx->expr (Ctx-previous c))
+    ,@(map AbsVal-expr (Ctx-stack c))))
 
 (define (gen-label-definitions c body-exp)
-  `(letrec (,@(for/list [((ip label) (in-hash (compilation-labels c)))]
-                `(,(mksym "label~a" ip) ,label)))
+  `(letrec (,@(for/list [(label-info (in-hash-values (Ctx-labels c)))]
+                (match-define (cons label-exp var) label-info)
+                (log-vm/jit-debug "Emitting label ~a" var)
+                `(,var ,label-exp)))
      ,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]))
@@ -605,7 +923,7 @@
                                                       (if stable? "stable" "not yet stable"))
                (define hotness
                  (for/sum [(entry pics)]
-                   (match-define (cons pi pic) entry)
+                   (match-define (cons c pic) entry)
                    (for/sum [(i (in-range (pic-size pic)))]
                      (match (pic@ pic i 0)
                        [#f 0]
@@ -617,9 +935,8 @@
                         (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)
+                         "      context ~a class ~a count ~a length ~a weight ~a"
+                         c
                          (bv->string (slotAt slot-class 0))
                          slot-count
                          bytecode-count
@@ -638,12 +955,11 @@
   (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)))
+      (values (car entry) (cdr 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)))
+    (for [((c p) (in-hash old-picmap))]
+      (log-vm/jit/recompile-info "   ~a --> ~v" (format-Ctx c) 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))
@@ -662,7 +978,7 @@
   (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))))
+  (apply f (outermost-k vm) (vector->list (obj-slots args))))
 
 (define-primitive vm [116]
   (let ((image-bytes (serialize-image vm)))
@@ -680,5 +996,5 @@
               (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))
+                (compiled-method (outermost-k vm) source))
               (current-command-line-arguments)))