Now working, up to recompilation
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Sun, 29 Jul 2018 18:06:07 +0100
changeset 426 930c499509be
parent 425 a7f739fa4dee
child 427 2971b9971cf0
Now working, up to recompilation
experiments/little-smalltalk/jit-SmallWorld-2015.rkt
experiments/little-smalltalk/object-memory.rkt
experiments/little-smalltalk/pe-SmallWorld-2015.rkt
experiments/little-smalltalk/primitives.rkt
experiments/little-smalltalk/run-SmallWorld-2015.rkt
--- a/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Sun Jul 29 16:20:03 2018 +0100
+++ b/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Sun Jul 29 18:06:07 2018 +0100
@@ -664,9 +664,7 @@
   (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)))
+(define-primitive vm [116] (save-image-to-file vm (jit-VM-image-filename vm)))
 
 ;;===========================================================================
 ;; Entry point
--- a/experiments/little-smalltalk/object-memory.rkt	Sun Jul 29 16:20:03 2018 +0100
+++ b/experiments/little-smalltalk/object-memory.rkt	Sun Jul 29 18:06:07 2018 +0100
@@ -31,6 +31,7 @@
 
          read-image
          serialize-image
+         save-image-to-file
 
          boot-image)
 
@@ -230,6 +231,10 @@
 
   (bytes-append* (reverse output-rev)))
 
+(define (save-image-to-file vm filename)
+  (let ((image-bytes (serialize-image vm)))
+    (display-to-file image-bytes filename #:exists 'replace)))
+
 (define (boot-image vm evaluator files-to-file-in)
   (define (doIt task)
     (define true-class (obj-class (VM-true vm))) ;; class True
--- a/experiments/little-smalltalk/pe-SmallWorld-2015.rkt	Sun Jul 29 16:20:03 2018 +0100
+++ b/experiments/little-smalltalk/pe-SmallWorld-2015.rkt	Sun Jul 29 18:06:07 2018 +0100
@@ -22,7 +22,7 @@
 ;;===========================================================================
 ;; Structures
 
-(struct jit-VM VM (cache image-filename)
+(struct pe-VM VM (cache image-filename)
   #:methods gen:vm-callback
   [(define (vm-block-callback vm action)
      ;; Runs action in a new thread
@@ -37,15 +37,9 @@
 ;; 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.
+;; Each context includes accumulator registers shared among all
+;; contexts inlined into the top-level method being compiled, as well
+;; as registers particular to itself.
 ;;
 ;; Runtime contexts include these registers:
 ;;   - method, the bytecoded method being interpreted
@@ -60,7 +54,7 @@
 ;; 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:
+;; Each context includes:
 ;;   - vm, the compile-time vm
 ;;   - method, a concrete value
 ;;   - arguments, a Racket vector of abstract-values
@@ -68,9 +62,11 @@
 ;;   - 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
+;;   - previous, the next context in the chain
+;;   - home, #f for non-blocks, otherwise the home context of a block
+;;   - state, accumulator registers
 ;;
-;; Outer contexts will include these fields alongside the common fields:
+;; The accumulator registers are:
 ;;   - 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
@@ -80,18 +76,13 @@
 ;;   - 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
+(struct DynamicCtx (var) #:transparent)
+(struct Ctx (vm method arguments temporaries stack ip labels previous home state) #: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 State (litmap [pic-list-rev #:mutable] old-picmap histories) #:transparent)
 
 (struct compiled-method-info (bytecode-method pics stable?))
 
@@ -151,7 +142,7 @@
 ;; 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))
+  (define class-cache (hash-ref! (pe-VM-cache vm) class make-weak-hash))
   (hash-ref! class-cache
              name-bytes
              (lambda () (cached-method class name-bytes #f #f))))
@@ -210,7 +201,7 @@
 ;;===========================================================================
 ;; Compilation State
 
-(define (top-compilation vm receiver-class method old-picmap)
+(define (top-compilation vm receiver-class method old-picmap top-k)
   (define litmap (make-hasheq))
   (Ctx-log 'top-compilation
            (Ctx vm
@@ -223,11 +214,12 @@
                 '()
                 0
                 (make-hash)
+                (DynamicCtx top-k)
                 #f
-                (OuterCtx litmap
-                          '()
-                          old-picmap
-                          (make-parameter '())))))
+                (State litmap
+                       '()
+                       old-picmap
+                       (make-parameter '())))))
 
 (define (selector-string-arity str)
   (define colon-count (for/sum [(c str)] (if (eqv? c #\:) 1 0)))
@@ -238,42 +230,34 @@
 (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)))
+  (log-vm/jit/code-debug "~a ~a ~adefined in ~v (depth ~a)"
+                         who
+                         (Ctx-name c)
+                         (if (Ctx-home c) "(BLOCK) " "")
+                         (slotAt (Ctx-method c) 5)
+                         (Ctx-depth c))
+  (log-vm/jit/code-debug "  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 (inline-compilation previous method actual-avs temporaries ip home)
+(define (inline-compilation vm method actual-avs temporaries ip previous home state)
   (Ctx-log 'inline-compilation
-           (Ctx (Ctx-vm previous)
+           (Ctx vm
                 method
                 actual-avs
                 (or temporaries (gensym (format "temps~a" (method-name method))))
                 '()
                 ip
                 (make-hash)
+                previous
                 home
-                (InnerCtx previous
-                          (Ctx-outer previous)))))
-
-(define (Ctx-previous c)
-  (define d (Ctx-detail c))
-  (and (InnerCtx? d) (InnerCtx-previous d)))
+                state)))
 
 (define (Ctx-depth c)
-  (+ 1 (cond [(Ctx-previous c) => Ctx-depth]
-             [else 0])))
+  (if (DynamicCtx? c)
+      0
+      (+ 1 (Ctx-depth (Ctx-previous c)))))
 
 (define (Ctx-arg c n)
   (vector-ref (Ctx-arguments c) n))
@@ -289,9 +273,9 @@
 
 (define (already-compiling? c class method)
   (let check ((c c))
-    (cond [(and (eq? (Ctx-receiver-class c) class) (eq? (Ctx-method c) method)) #t]
-          [(Ctx-previous c) => check]
-          [else #f])))
+    (cond [(DynamicCtx? c) #f]
+          [(and (eq? (Ctx-receiver-class c) class) (eq? (Ctx-method c) method)) #t]
+          [else (check (Ctx-previous c))])))
 
 (define (gen-lit* litmap lit)
   (if (number? lit)
@@ -308,7 +292,7 @@
   (AbsVal (gen-lit* litmap lit) (Constant lit)))
 
 (define (Ctx-litmap c)
-  (OuterCtx-litmap (Ctx-outer c)))
+  (State-litmap (Ctx-state c)))
 
 (define (Ctx-lit c literal)
   (gen-lit (Ctx-litmap c) literal))
@@ -331,9 +315,10 @@
 (define (format-Ctx c)
   (string-join (reverse
                 (let pieces ((c c))
-                  (cons (format "~a @~a" (Ctx-name c) (Ctx-ip c))
-                        (cond [(Ctx-previous c) => pieces]
-                              [else '()]))))
+                  (if (DynamicCtx? c)
+                      '()
+                      (cons (format "~a @~a" (Ctx-name c) (Ctx-ip c))
+                            (pieces (Ctx-previous c))))))
                ","
                #:before-first "["
                #:after-last "]"))
@@ -342,12 +327,16 @@
 ;; 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 top-k (gensym 'top-k))
+  (define c (top-compilation compile-time-vm class method old-picmap top-k))
   (define body-code (gen-code c)) ;; imperative!
-  (define pic-infos (reverse (OuterCtx-pic-list-rev (Ctx-outer c))))
+  (define pic-infos (reverse (State-pic-list-rev (Ctx-state 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 car pic-infos)))) ;; TODO too fine
+                          (list->set (map car pic-infos))))
+  (log-vm/jit/recompile-debug "Evaluating stability of ~a:" (Ctx-name c))
+  (log-vm/jit/recompile-debug "  old-picmap --> ~a" (if old-picmap (list->set (hash-keys old-picmap)) 'unknown))
+  (log-vm/jit/recompile-debug "  pic-infos  --> ~a" (list->set (map car pic-infos)))
   (when stable?
     (log-vm/jit/recompile-info "Compilation of ~a is now stable." (method-name method class)))
   (define inner-code
@@ -358,19 +347,19 @@
           (when (not cmi)
             (set! cmi
                   (compiled-method-info
-                   method
+                   ,(AbsVal-expr (Ctx-lit c method))
                    ,pic-infos-exp
                    ,stable?)))
           cmi]
-         [(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)))))
+         [(,top-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)
             (log-vm/jit/recompile-debug "Method ~a is hot" ,(method-name method class))
-            (recompile-something vm (k))
+            (recompile-something vm (,top-k))
             ;; (set! call-counter 0)
             )
           ,(gen-fresh-temps c (gen-label-definitions c body-code))])))
@@ -378,13 +367,9 @@
 
 (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))
+  (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)))
+  (apply (eval code ns) vm (map car litmap-list)))
 
 ;; (define (compile-block-proc compile-time-vm
 ;;                             method
@@ -416,14 +401,15 @@
     ))
 
 (define (gen-build-jit-context c)
-  `(build-jit-context vm
-                      ,(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))))))
+  (if (DynamicCtx? c)
+      `(,(DynamicCtx-var c))
+      `(build-jit-context vm
+                          ,(gen-build-jit-context (Ctx-previous c))
+                          (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-fresh-temps c body-code)
   `(let ((,(Ctx-temporaries c)
@@ -441,12 +427,12 @@
                          limit)
   (> (bytes-length bytecode) limit))
 
-(define (gen-pic c extension)
+(define (gen-pic c name-bytes 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))))
+  (set-State-pic-list-rev! (Ctx-state c) (cons (list c name-bytes p) (State-pic-list-rev (Ctx-state c))))
   (gen-lit* (Ctx-litmap c) p))
 
 ;; TODO: record dependency links properly, so that if a method is
@@ -454,16 +440,20 @@
 ;; discarded.
 
 (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 ic
+    (inline-compilation (Ctx-vm kc) method (list->vector arg-avs) #f 0 kc #f (Ctx-state kc)))
+  (log-vm/jit/code-debug "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)))
+       ;; (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))
+  (log-vm/jit/code-debug "INLINED for send of ~a into method ~a:\n~a"
+                         (Ctx-name ic)
+                         (Ctx-name kc)
+                         (pretty-format body-code))
   body-code)
 
 (define (analyse-pic c pic)
@@ -477,21 +467,34 @@
 (define (tiny-method? bmethod) (not (bytecode-exceeding? bmethod 32)))
 (define (small-method? bmethod) (not (bytecode-exceeding? bmethod 40)))
 
+(define (remaining-basic-block-size-tiny? c)
+  (define method (Ctx-method c))
+  (define bytecode (bv-bytes (slotAt method 1)))
+  (define ip (Ctx-ip c))
+  (define remaining-bytes (- (bytes-length bytecode) ip)) ;; TODO: actually figure this out properly
+  (log-vm/jit-debug "Evaluating continuation size: ~a bytes left in ~a" remaining-bytes c)
+  (not (> remaining-bytes 6)))
+
 (define (Ctx->expr c)
-  (if c
-      (let ((result (gensym 'answer)))
+  (if (DynamicCtx? c)
+      (DynamicCtx-var c)
+      (let ((ans (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))
+                      [(,ans)
+                       ;; (log-vm/jit-debug "Continuing ~a with ~a" ,(format-Ctx c) ,ans)
+                       ,(truncate-histories c (gen-continuation (Ctx-push c (AbsVal ans (Unknown)))))]))))
+
+(define (gen-continuation c)
+  (if (remaining-basic-block-size-tiny? c)
+      (gen-code c)
+      (gen-jump-to-label c)))
 
 (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)
+  (log-vm/jit-debug "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)
+  ;; (log-vm/jit-debug "class-absval is ~a" class-absval)
+  (log-vm/jit-debug "arg-avs = ~a" arg-avs)
   (if (Constant? class-desc)
       (let* ((class (Constant-value class-desc))
              (cm (lookup-method/cache vm class name-bytes))
@@ -505,10 +508,10 @@
               ,(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-picmap (State-old-picmap (Ctx-state 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))
+        (define previous-pic-entries (if old-entry (analyse-pic c (cadr old-entry)) '()))
+        (define pic-m (gen-pic c name-bytes previous-pic-entries))
         `(let ((k-send ,(Ctx->expr kc)))
            ,(let loop ((predictions previous-pic-entries) (counter pic-entry-count))
               (match predictions
@@ -539,8 +542,17 @@
 
 (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)
+  (define block-k (gensym 'block-k))
+  (define bc (inline-compilation (Ctx-vm c)
+                                 (Ctx-method c)
+                                 (Ctx-arguments c)
+                                 (Ctx-temporaries c)
+                                 (Ctx-ip c)
+                                 (DynamicCtx block-k)
+                                 (or (Ctx-home c) (Ctx-previous c)) ;; ??
+                                 (Ctx-state c)))
+  `(lambda (,block-k . block-arguments)
+     ;; (log-vm/jit-debug "Entering block at ~a with ~a" ,(format-Ctx bc) block-arguments)
      ,(let loop ((i argument-location))
         (if (>= i temp-count)
             `(void)
@@ -548,17 +560,16 @@
                (vector-set! ,(Ctx-temporaries c) ,i (car block-arguments))
                (let ((block-arguments (cdr block-arguments)))
                  ,(loop (+ i 1))))))
-     ,(let* ((c (struct-copy Ctx c [home (Ctx-previous c)])))
-        (truncate-histories c (gen-code c)))))
+     ,(truncate-histories bc (gen-label-definitions bc (gen-code bc)))))
 
 (define (emit* c var purity absval)
-  (define param (OuterCtx-histories (Ctx-outer c)))
+  (define param (State-histories (Ctx-state c)))
   (match-define (cons era hs) (param))
   (param (cons (cons (definition var purity absval) era) hs))
   (AbsVal var (AbsVal-desc absval)))
 
 (define (historical-match c purity expr)
-  (define param (OuterCtx-histories (Ctx-outer c)))
+  (define param (State-histories (Ctx-state c)))
   (and (eq? purity 'pure)
        (let search-hs ((hs (param)))
          (match hs
@@ -582,14 +593,14 @@
      (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))))
+  (let ((param (State-histories (Ctx-state 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))))
+         (param (State-histories (Ctx-state c))))
     (parameterize ((param '()))
       (residualize c code-expr))))
 
@@ -604,7 +615,7 @@
          (wrap-era era body (set-remove outstanding var)))]))
 
 (define (free-names expr)
-  (log-vm-warning "free-names is a hideous overapproximation")
+  (log-vm-debug "free-names is a hideous overapproximation")
   (match expr
     [(? symbol? n) (seteq n)]
     [`(,exprs ...) (apply set-union (seteq) (map free-names exprs))]
@@ -726,35 +737,34 @@
                                              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))))))]
+             (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 bc
+                                         (inline-compilation vm
+                                                             method
+                                                             (Ctx-arguments c)
+                                                             (Ctx-temporaries c)
+                                                             (Ctx-ip c)
+                                                             kc
+                                                             (or (Ctx-home c) (Ctx-previous c)) ;; ??
+                                                             (Ctx-state c)))
+                                       (for [(i (in-naturals argument-location)) (arg arg-avs)]
+                                         (define av
+                                           (AbsVal `(vector-set! ,(Ctx-temporaries c)
+                                                                 ,i
+                                                                 ,(AbsVal-expr arg))
+                                                   (Unknown)))
+                                         (emit bc [blkarg effect av] (void)))
+                                       (truncate-histories
+                                        bc
+                                        (gen-label-definitions bc (gen-code bc)))))))]
                    (translate (Ctx-push-and-goto c target block))))]
        [13 (define primitive-number (next-byte!))
            (define primitive-arg-count arg)
@@ -775,10 +785,11 @@
                       (block (last primitive-args))
                       (argc (- arg 1))
                       (primitive-args (reverse (cdr (reverse primitive-args)))))
-                  (if (and (Ffiv? block)
+                  (log-vm/jit-debug "Attempt to invoke block ~a" block)
+                  (if (and (Ffiv? (AbsVal-desc 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)
+                      ((Ffiv-value (AbsVal-desc block)) (Ctx-previous c) primitive-args)
                       `(match ,(AbsVal-expr block)
                          [(unffiv block-proc)
                           (block-proc
@@ -791,11 +802,12 @@
                           (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)))])))]
+                                                       (list ,@(map AbsVal-expr primitive-args))))))
+                             (match (Ctx-previous c)
+                               [(DynamicCtx dk)
+                                `(,dk ,expr)]
+                               [caller
+                                (gen-code (Ctx-push caller (AbsVal expr (Unknown))))]))])))]
              [34 (Ctx-lit c (VM-nil vm))]
              [35 (emit c [ctxref pure (AbsVal (gen-build-jit-context c) (Unknown))]
                        (translate (Ctx-push c ctxref)))]
@@ -816,13 +828,13 @@
        [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 c
+               [(DynamicCtx dk) `(,dk ,(AbsVal-expr av))]
+               [_ (translate (Ctx-push c 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)))]
+             [3 (continue (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!))
@@ -832,8 +844,8 @@
                   (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))))]
+                           ,(gen-continuation (Ctx-goto c target))
+                           ,(gen-continuation c))))]
              [8 (let ((target (next-byte!))
                       (disc (car stack)))
                   (set! c (Ctx-drop c 1))
@@ -841,8 +853,8 @@
                   (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))))]
+                           ,(gen-continuation (Ctx-goto c target))
+                           ,(gen-continuation 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)]))))
@@ -860,7 +872,7 @@
 ;;     (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)))))
+;;   (log-vm/jit-debug "HISTORIES: ~a" ((State-histories (Ctx-state c)))))
 
 (define (gen-jump-to-label c)
   (define labels (Ctx-labels c))
@@ -873,18 +885,15 @@
     (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 bb-k (gensym 'bb-k))
     (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))])))
+                  (let* ((c (Ctx-update c (Ctx-ip c) (lambda (_s) newstack)))
+                         (c (struct-copy Ctx c [previous (DynamicCtx bb-k)])))
                     ;; (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)))
+    (hash-set! labels key (cons `(lambda (,bb-k ,@(map AbsVal-expr newstack)) ,expr) var)))
   `(,(cdr (hash-ref labels key))
     ,(Ctx->expr (Ctx-previous c))
     ,@(map AbsVal-expr (Ctx-stack c))))
@@ -923,7 +932,7 @@
                                                       (if stable? "stable" "not yet stable"))
                (define hotness
                  (for/sum [(entry pics)]
-                   (match-define (cons c pic) entry)
+                   (match-define (list c _name-bytes pic) entry)
                    (for/sum [(i (in-range (pic-size pic)))]
                      (match (pic@ pic i 0)
                        [#f 0]
@@ -980,9 +989,7 @@
   (define f (compile-method-proc vm (obj-class* vm (slotAt args 0)) (slotAt inner-ctx 0) #f))
   (apply f (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)))
+(define-primitive vm [116] (save-image-to-file vm (pe-VM-image-filename vm)))
 
 ;;===========================================================================
 ;; Entry point
@@ -991,7 +998,7 @@
 (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))))))
+               (read-image fh pe-VM (list (make-weak-hasheq) image-filename))))))
   (boot-image vm
               (lambda (vm source)
                 (define compiled-method
--- a/experiments/little-smalltalk/primitives.rkt	Sun Jul 29 16:20:03 2018 +0100
+++ b/experiments/little-smalltalk/primitives.rkt	Sun Jul 29 18:06:07 2018 +0100
@@ -105,6 +105,8 @@
         [(bytes=? a b) 0]
         [(bytes>? a b) 1]))
 
+(define-primitive vm [29 filename] (save-image-to-file vm (bv->string filename)))
+
 (define-primitive vm [30 source index] (slotAt source (- index 1)))
 (define-primitive vm [31 v o] (obj (obj-class o) (vector-append (obj-slots o) (vector v))))
 
--- a/experiments/little-smalltalk/run-SmallWorld-2015.rkt	Sun Jul 29 16:20:03 2018 +0100
+++ b/experiments/little-smalltalk/run-SmallWorld-2015.rkt	Sun Jul 29 18:06:07 2018 +0100
@@ -252,9 +252,7 @@
 (define-primitive vm [6 inner-ctx] ;; "new context execute"
   (execute vm inner-ctx))
 
-(define-primitive vm [116]
-  (let ((image-bytes (serialize-image vm)))
-    (display-to-file image-bytes (int-VM-image-filename vm) #:exists 'replace)))
+(define-primitive vm [116] (save-image-to-file vm (int-VM-image-filename vm)))
 
 ;;===========================================================================