Factor out object-memory.rkt and primitives.rkt
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Sat, 21 Jul 2018 18:11:55 +0100
changeset 403 5e81df1d79c4
parent 402 dc1bd2065cd1
child 404 158def14bb15
Factor out object-memory.rkt and primitives.rkt
experiments/little-smalltalk/jit-SmallWorld-2015.rkt
experiments/little-smalltalk/object-memory.rkt
experiments/little-smalltalk/oneshot.rkt
experiments/little-smalltalk/primitives.rkt
experiments/little-smalltalk/run-SmallWorld-2015.rkt
--- a/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Sat Jul 21 17:13:31 2018 +0100
+++ b/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Sat Jul 21 18:11:55 2018 +0100
@@ -3,196 +3,29 @@
 ;; variant of SmallWorld, a Tim Budd-authored Little Smalltalk
 ;; descendant.
 
-(require racket/struct)
 (require racket/bytes)
 (require (only-in sha bytes->hex-string))
-(require "oneshot.rkt")
+(require "object-memory.rkt")
+(require "primitives.rkt")
 
 (define-logger vm)
-(define-logger vm/gui)
 (define-logger vm/jit)
 
-(struct obj ([class #:mutable] slots)
-  #:methods gen:custom-write
-  [(define write-proc
-     (make-constructor-style-printer (lambda (o) (format "obj:~a" (obj-class-name o)))
-                                     (lambda (o)
-                                       (match (obj-class-name o)
-                                         [#"Array" (list (vector->list (obj-slots o)))]
-                                         [#"Class" (list (slotAt o 0))]
-                                         [_ '()]))))])
-
-(struct bv obj (bytes)
-  #:methods gen:custom-write
-  [(define write-proc
-     (make-constructor-style-printer (lambda (o) (format "bv:~a" (obj-class-name o)))
-                                     (lambda (o) (list (bv-bytes o)))))])
-
-(struct ffiv obj (value)
-  #:methods gen:custom-write
-  [(define write-proc
-     (make-constructor-style-printer (lambda (o) (format "ffiv:~a" (obj-class-name o)))
-                                     (lambda (o) (list (ffiv-value o)))))])
-
 (define pic-entry-count 3)
 (define (pic) (vector #f #f #f #f #f #f)) ;; pic-entry-count times two - one each for class & method
 
-(define-match-expander unbv
-  (syntax-rules () [(_ bytes-pat) (bv _ _ bytes-pat)]))
-(define-match-expander unbv*
-  (syntax-rules () [(_ this-pat bytes-pat) (and this-pat (bv _ _ bytes-pat))]))
-(define-match-expander unstr
-  (syntax-rules () [(_ str-pat) (bv _ _ (app bytes->string/utf-8 str-pat))]))
-(define-match-expander unffiv
-  (syntax-rules () [(_ val-pat) (ffiv _ _ val-pat)]))
-(define-match-expander unffiv*
-  (syntax-rules () [(_ this-pat val-pat) (and this-pat (ffiv _ _ val-pat))]))
-
-(define (bv->string b)
-  (bytes->string/utf-8 (bv-bytes b)))
-
-(define (obj-class-name o)
-  (define c (obj-class o))
-  (if (and (positive? (slotCount c))
-           (bv? (slotAt c 0)))
-      (bv-bytes (slotAt c 0))
-      #"???"))
-
-(struct VM (nil true false Array Block Context Integer cache image-filename))
-
-(define (read-image image-filename fh)
-
-  (define (next-int #:signed? [signed? #t] #:eof-ok? [eof-ok? #f])
-    (define bs (read-bytes 4 fh))
-    (if (eof-object? bs)
-        (if eof-ok? bs (error 'read-image "Early EOF"))
-        (integer-bytes->integer bs signed? #t)))
-
-  (let ((image-version (next-int))
-        (expected-version 1))
-    (when (not (= image-version expected-version))
-      (error 'read-image "Wrong image version: got ~a, expected ~a"
-             image-version
-             expected-version)))
-
-  (define object-table
-    (let loop ((acc '()))
-      (define (emit x) (loop (cons x acc)))
-      (match (next-int #:eof-ok? #t)
-        [(? eof-object?) (list->vector (reverse acc))]
-        [obj-length
-         (define type-code (next-int))
-         (define class-index (next-int))
-         (define slot-count (next-int))
-         (match type-code
-           [0 ;; SmallInt
-            (when (not (= obj-length 5))
-              (error 'read-image "Strange SmallInt obj-length: ~a" obj-length))
-            (when (not (zero? slot-count))
-              (error 'read-image "Strange SmallInt with ~a slots" slot-count))
-            (emit (next-int))]
-           [1 ;; SmallByteArray
-            (define byte-count (- obj-length slot-count 4))
-            (emit (bv class-index
-                      (for/vector [(i slot-count)] (next-int))
-                      (read-bytes byte-count fh)))]
-           [2 ;; SmallObject
-            (emit (obj class-index
-                       (for/vector [(i slot-count)] (next-int))))])])))
-
-  (for [(x object-table)]
-    (when (obj? x)
-      (set-obj-class! x (vector-ref object-table (obj-class x)))
-      (for [(i (vector-length (obj-slots x)))]
-        (vector-set! (obj-slots x) i (vector-ref object-table (vector-ref (obj-slots x) i))))))
+(struct jit-VM VM (cache image-filename)
+  #:methods gen:vm-callback
+  [(define (vm-block-callback vm action)
+     ;; Runs action in a new thread
+     (lambda args
+       (thread (match action
+                 [(unffiv block-proc)
+                  (lambda () (apply block-proc vm (outermost-k vm) args))]
+                 [_
+                  (block->thunk vm action args)]))))])
 
-  (VM (vector-ref object-table 0)
-      (vector-ref object-table 1)
-      (vector-ref object-table 2)
-      (vector-ref object-table 3)
-      (vector-ref object-table 4)
-      (vector-ref object-table 5)
-      (vector-ref object-table 6)
-      (make-weak-hasheq)
-      image-filename))
-
-(define (serialize-image vm)
-  (define indices (make-hasheq))
-  (define output-rev '())
-  (define worklist-rev '())
-  (define next-index 0)
-
-  (define (push-bytes! item) (set! output-rev (cons item output-rev)))
-  (define (push-int! n) (push-bytes! (integer->integer-bytes n 4 #t #t)))
-
-  (define (object->index o)
-    (if (ffiv? o)
-        (object->index (VM-nil vm))
-        (hash-ref! indices o (lambda ()
-                               (begin0 next-index
-                                 (set! next-index (+ next-index 1))
-                                 (set! worklist-rev (cons o worklist-rev)))))))
-
-  (push-int! 1) ;; version number
-  (object->index (VM-nil vm))
-  (object->index (VM-true vm))
-  (object->index (VM-false vm))
-  (object->index (VM-Array vm))
-  (object->index (VM-Block vm))
-  (object->index (VM-Context vm))
-  (object->index (VM-Integer vm))
-  (for [(i 10)] (object->index i))
-
-  (let loop ()
-    (define worklist (reverse worklist-rev))
-    (set! worklist-rev '())
-    (when (pair? worklist)
-      (for [(o worklist)]
-        (match o
-          [(? number?)
-           (push-int! 5)
-           (push-int! 0)
-           (push-int! (object->index (VM-Integer vm)))
-           (push-int! 0)
-           (push-int! o)]
-          [(bv class slots bytes)
-           (push-int! (+ (bytes-length bytes) (vector-length slots) 4)) ;; weird
-           (push-int! 1)
-           (push-int! (object->index class))
-           (push-int! (vector-length slots))
-           (for [(s slots)] (push-int! (object->index s)))
-           (push-bytes! bytes)]
-          [(obj class slots)
-           (push-int! (+ (vector-length slots) 4))
-           (push-int! 2)
-           (push-int! (object->index class))
-           (push-int! (vector-length slots))
-           (for [(s slots)] (push-int! (object->index s)))]))
-      (loop)))
-
-  (bytes-append* (reverse output-rev)))
-
-(define (slotCount o) (vector-length (obj-slots o)))
-(define (slotAt o i) (vector-ref (obj-slots o) i))
-(define (slotAtPut o i v) (vector-set! (obj-slots o) i v))
-
-(define (search-class-method-dictionary c name-bytes)
-  (define methods (slotAt c 2))
-  (for/first [(m (obj-slots methods))
-              #:when (equal? name-bytes (bv-bytes (slotAt m 0)))]
-    m))
-
-(define (mkobj cls . fields)
-  (obj cls (list->vector fields)))
-
-(define (mkbv cls bs . fields)
-  (bv cls (list->vector fields) bs))
-
-(define (mkffiv cls value)
-  (ffiv cls '#() value))
-
-(define (mkarray vm count [init (VM-nil vm)])
-  (obj (VM-Array vm) (make-vector count init)))
+(struct compilation (method litnames argnames labels [pic-count #:mutable]))
 
 (define (build-jit-context vm previous-context args method ip stack-top temporaries stack)
   (define max-stack (slotAt method 3))
@@ -206,9 +39,6 @@
          stack-top
          previous-context))
 
-(define (boolean->obj vm b)
-  (if b (VM-true vm) (VM-false vm)))
-
 (define (selector-string-arity str)
   (define colon-count (for/sum [(c str)] (if (eqv? c #\:) 1 0)))
   (cond [(positive? colon-count) (+ colon-count 1)]
@@ -229,8 +59,6 @@
        `(let ((,n ,n-code-exp))
           ,body-code-exp))]))
 
-(struct compilation (method litnames argnames labels [pic-count #:mutable]))
-
 (define (new-compilation method)
   (define selector (slotAt method 0))
   (define arity (selector-string-arity (bv->string selector)))
@@ -430,24 +258,20 @@
        ,@(for/list [(i (compilation-pic-count c))] `(define ,(mksym "pic~a" i) (pic)))
        ,inner-code))
 
-  (log-vm/jit-info "Resulting code:\n~a" (pretty-format code))
+  (log-vm/jit-debug "Resulting code:\n~a" (pretty-format code))
 
   (define literals (slotAt (compilation-method c) 2))
   (define defining-class (slotAt (compilation-method c) 5))
 
-  (define final-proc
-    (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)
-           (vector->list (obj-slots literals))))
-
-  (log-vm/jit-info "Final proc: ~a" final-proc)
-  final-proc)
+  (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)
+         (vector->list (obj-slots literals))))
 
 (define (compile-block-proc compile-time-vm
                             method
@@ -481,19 +305,13 @@
   (finish-compilation c compile-time-vm inner-code))
 
 (define (lookup-method/cache vm class name-bytes)
-  (define class-cache (hash-ref! (VM-cache vm) class make-weak-hash))
+  (define class-cache (hash-ref! (jit-VM-cache vm) class make-weak-hash))
   (hash-ref! class-cache
              name-bytes
              (lambda ()
                (define m (lookup-method vm class name-bytes))
                (and m (compile-method-proc vm m)))))
 
-(define (lookup-method vm class name-bytes)
-  (let search ((class class))
-    (and (not (eq? class (VM-nil vm)))
-         (or (search-class-method-dictionary class name-bytes)
-             (search (slotAt class 1))))))
-
 (define (lookup-message/jit vm pic class selector)
   (let search-pic ((slot-index 0))
     (define this-class (vector-ref pic (* slot-index 2)))
@@ -519,15 +337,7 @@
     [#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))]))
-
-
-(define (obj-class* vm o)
-  (if (number? o)
-      (VM-Integer vm)
-      (obj-class o)))
+     (dnu-method vm ctx (slotAt arguments 0) (mkobj (VM-Array vm) selector arguments))]))
 
 (define (block->thunk vm block args) ;; Expects a real bytecode block, not an ffiv one
   (lambda ()
@@ -536,317 +346,34 @@
     (define temporaries (obj-slots (slotAt block 2)))
     (define argument-location (slotAt block 7))
     (define block-ip (slotAt block 9))
-    (apply (compile-block-proc vm method outer-args temporaries argument-location block-ip)
-           vm
-           (outermost-k vm)
-           args)))
+    (define f (compile-block-proc vm method outer-args temporaries argument-location block-ip))
+    (apply f vm (outermost-k vm) args)))
 
 (define (outermost-k vm)
   (case-lambda [() (VM-nil vm)]
                [(result) result]))
 
-(define (block-callback vm block)
-  ;; Runs block in a new thread
-  (lambda args
-    (thread
-     (match block
-       [(unffiv block-proc)
-        (lambda () (apply block-proc vm (outermost-k vm) args))]
-       [_
-        (block->thunk vm block args)]))))
-
-(define *primitive-handlers* (make-hash))
-(define *primitive-code-snippets* (make-hash))
-
-(define-syntax-rule (define-primitive vm [n arg-pat ...] body ...)
-  (begin (hash-set! *primitive-handlers*
-                    n
-                    (lambda (vm args)
-                      (match (obj-slots args) [(vector arg-pat ...) (let () body ...)])))
-         (hash-set! *primitive-code-snippets*
-                    n
-                    (lambda (vm-exp arg-exps)
-                      `(match* [,vm-exp ,@arg-exps]
-                         [[vm arg-pat ...] (let () body ...)])))))
-
 ;;===========================================================================
 
-(define-primitive vm [1 b a] (boolean->obj vm (eq? a b)))
-(define-primitive vm [2 x] (obj-class* vm x))
-(define-primitive vm [4 o] (cond [(bv? o) (bytes-length (bv-bytes o))]
-                                 [(obj? o) (slotCount o)]
-                                 [(number? o) 0]
-                                 [else (error 'execute "Primitive 4 failed")]))
-(define-primitive vm [5 value target index]
-  (slotAtPut target (- index 1) value)
-  target)
 (define-primitive vm [6 inner-ctx] ;; "new context execute"
-  (when (not (zero? (slotAt inner-ctx 5)))
-    (error 'execute "Cannot execute from nonempty stack"))
-  (when (not (zero? (slotAt inner-ctx 4)))
-    (error 'execute "Cannot execute from nonzero IP"))
+  (when (not (zero? (slotAt inner-ctx 5))) (error 'execute "Cannot execute from nonempty stack"))
+  (when (not (zero? (slotAt inner-ctx 4))) (error 'execute "Cannot execute from nonzero IP"))
   (apply (compile-method-proc vm (slotAt inner-ctx 0))
          vm
          (outermost-k vm)
          (vector->list (obj-slots (slotAt inner-ctx 1)))))
-(define-primitive vm [7 class count]
-  (obj class (make-vector count (VM-nil vm))))
 
-(define-primitive vm [10 b a] (+ a b)) ;; TODO: overflow
-(define-primitive vm [11 n d] (quotient n d))
-(define-primitive vm [12 n d] (modulo n d))
-(define-primitive vm [14 b a] (boolean->obj vm (= a b)))
-(define-primitive vm [15 b a] (* a b))
-(define-primitive vm [16 a b] (- a b)) ;; NB. ordering
-
-(define-primitive vm [18 v] (log-vm-info "DEBUG: value ~v class ~v" v (obj-class* vm v)))
-
-(define-primitive vm [20 class count] (mkbv class (make-bytes count)))
-(define-primitive vm [21 source index] (bytes-ref (bv-bytes source) (- index 1)))
-(define-primitive vm [22 value target index]
-  (bytes-set! (bv-bytes target) (- index 1) value)
-  target)
-(define-primitive vm [24 (unbv b) (unbv* av a)] (mkbv (obj-class av) (bytes-append a b)))
-(define-primitive vm [26 (unbv a) (unbv b)] ;; NB. ordering
-  (cond [(bytes<? a b) -1]
-        [(bytes=? a b) 0]
-        [(bytes>? a b) 1]))
-
-(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))))
-
-(define-primitive vm [41 class (unstr filename)]
-  (mkffiv class (open-output-file filename #:exists 'replace)))
-(define-primitive vm [42 class (unstr filename)]
-  (mkffiv class (open-input-file filename)))
-(define-primitive vm [44 class (unffiv fh)]
-  (match (read-bytes-line fh)
-    [(? eof-object?) (VM-nil vm)]
-    [bs (mkbv class bs)]))
-
-;;---------------------------------------------------------------------------
-;; GUI
-;;---------------------------------------------------------------------------
-
-(define smalltalk-frame%
-  (class frame%
-    (field [close-handler void])
-    (define/public (set-close-handler new-handler)
-      (set! close-handler new-handler))
-    (define/augment (on-close)
-      (close-handler this))
-    (super-new)))
-
-(define-primitive vm [60 class] ;; make window
-  (log-vm/gui-debug "Creating window")
-  (mkffiv class (new smalltalk-frame% [label "Racket SmallWorld"])))
-(define-primitive vm [61 (unffiv window) flag] ;; show/hide text window
-  (log-vm/gui-debug "Show/hide window ~a" (eq? flag (VM-true vm)))
-  (send window show (eq? flag (VM-true vm)))
-  flag)
-(define-primitive vm [62 (unffiv* wv window) (unffiv (list _item factory))] ;; set content pane
-  (log-vm/gui-debug "Set content pane")
-  (factory window)
-  wv)
-(define-primitive vm [63 (unffiv* wv window) height width] ;; set size
-  (log-vm/gui-debug "Window resize ~ax~a" width height)
-  (send window resize width height)
-  wv)
-(define-primitive vm [64 (unffiv* wv window) (unffiv (list _queue-item add-menu-bar-to))]
-  ;; add menu to window
-  (define mb (or (send window get-menu-bar)
-                 (new menu-bar% [parent window])))
-  (log-vm/gui-debug "Add menu to window")
-  (add-menu-bar-to mb)
-  wv)
-(define-primitive vm [65 (unffiv* wv window) (unstr text)] ;; set title
-  (log-vm/gui-debug "Set window title ~v" text)
-  (send window set-label text)
-  wv)
-(define-primitive vm [66 window] ;; repaint window
-  ;; nothing needed
-  window)
-(define-primitive vm [70 class (unstr label)] ;; new label panel
-  (log-vm/gui-debug "Schedule label panel ~v" label)
-  (define (create-label-in parent)
-    (log-vm/gui-debug "Create label panel ~v" label)
-    (new message% [parent parent] [label label]))
-  (mkffiv class (list 'label create-label-in)))
-(define-primitive vm [71 class (unstr label) action] ;; new button
-  (define callback (block-callback vm action))
-  (log-vm/gui-debug "Schedule button ~v" label)
-  (define (create-button-in parent)
-    (log-vm/gui-debug "Create button ~v" label)
-    (new button%
-         [label label]
-         [parent parent]
-         [callback (lambda args (queue-callback callback))]))
-  (mkffiv class (list 'button create-button-in)))
-(define-primitive vm [72 class] ;; new text line
-  (log-vm/gui-debug "Schedule textfield")
-  (define textfield-editor #f)
-  (define (add-textfield-to parent)
-    (set! textfield-editor (send (new text-field% [label #f] [parent parent]) get-editor))
-    textfield-editor)
-  (mkffiv class (list (lambda () textfield-editor) add-textfield-to)))
-(define-primitive vm [73 class] ;; new text area
-  (log-vm/gui-debug "Schedule textarea")
-  (define editor (new text%))
-  (define (add-editor-to frame)
-    (log-vm/gui-debug "Create textarea")
-    (new editor-canvas% [parent frame] [editor editor]))
-  (mkffiv class (list (lambda () editor) add-editor-to)))
-(define-primitive vm [74 class width height data] ;; new grid panel
-  (log-vm/gui-debug "Schedule grid panel ~ax~a ~a" width height data)
-  (define (create-grid-in parent)
-    (log-vm/gui-debug "Create grid panel ~ax~a ~a" width height data)
-    (define vp (new vertical-pane% [parent parent]))
-    (for [(row height)]
-      (define hp (new horizontal-pane% [parent vp]))
-      (for [(col width)]
-        (define i (+ col (* row width)))
-        (when (< i (slotCount data))
-          (match (slotAt data i)
-            [(unffiv (list _ factory)) (factory hp)]))))
-    vp)
-  (mkffiv class (list 'grid create-grid-in)))
-(define-primitive vm [75 class data action] ;; new list panel
-  (define callback (block-callback vm action))
-  (log-vm/gui-debug "Schedule listpanel ~a" data)
-  (define lb #f)
-  (define old-selection #f)
-  (define (create-list-panel-in parent)
-    (log-vm/gui-debug "Create listpanel ~a" data)
-    (set! lb (new list-box%
-                  [label #f]
-                  [parent parent]
-                  [choices (for/list [(c (obj-slots data))] (bv->string c))]
-                  [callback (lambda _args
-                              (log-vm/gui-debug "_args: ~v for listpanel ~a"
-                                                _args
-                                                (eq-hash-code lb))
-                              (define selection (send lb get-selection))
-                              (when (not (equal? old-selection selection))
-                                (set! old-selection selection)
-                                (queue-callback
-                                 (lambda ()
-                                   (log-vm/gui-debug "Item selected ~v" selection)
-                                   (callback (if selection (+ selection 1) 0))))))]))
-    (log-vm/gui-debug "The result is ~a" (eq-hash-code lb))
-    lb)
-  (mkffiv class (list (lambda () lb) create-list-panel-in)))
-(define-primitive vm [76 class north south east west center] ;; new border panel
-  (log-vm/gui-debug "Schedule borderpanel")
-  (define (add-w w p)
-    (when (not (eq? (VM-nil vm) w))
-      (match w [(unffiv (list _ factory)) (factory p)])))
-  (define (create-border-panel-in parent)
-    (log-vm/gui-debug "Create borderpanel")
-    (define vp (new vertical-pane% [parent parent]))
-    (add-w north vp)
-    (when (for/or [(w (list west center east))] (not (eq? (VM-nil vm) w)))
-      (define hp (new horizontal-pane% [parent vp]))
-      (add-w west hp)
-      (add-w center hp)
-      (add-w east hp))
-    (add-w south vp)
-    vp)
-  (mkffiv class (list 'border-panel create-border-panel-in)))
-(define-primitive vm [80 class (unffiv (list get-textarea _factory))] ;; content of text area
-  (mkbv class (string->bytes/utf-8 (send (get-textarea) get-text))))
-(define-primitive vm [81 class (unffiv (list get-textarea _factory))] ;; content of selected text area
-  (define start (box 0))
-  (define end (box 0))
-  (send (get-textarea) get-position start end)
-  (define has-selection (not (= (unbox start) (unbox end))))
-  (mkbv class
-        (string->bytes/utf-8 (send (get-textarea) get-text
-                                   (if has-selection (unbox start) 0)
-                                   (if has-selection (unbox end) 'eof)))))
-(define-primitive vm [82 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set text area
-  (log-vm/gui-debug "Update textarea ~v" text)
-  (send (get-textarea) erase)
-  (send (get-textarea) insert text)
-  textv)
-(define-primitive vm [83 (unffiv (list get-lb _factory))] ;; get selected index
-  (log-vm/gui-debug "Get selected index")
-  (define lb (get-lb))
-  (define s (send lb get-selection))
-  (if s (+ s 1) 0))
-(define-primitive vm [84 (unffiv* lbv (list get-lb _factory)) data] ;; set list data
-  (define lb (get-lb))
-  (log-vm/gui-debug "Update list ~a data ~v" (eq-hash-code lb) data)
-  (send lb set (for/list [(c (obj-slots data))] (bv->string c)))
-  lbv)
-(define-primitive vm [89 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set selected text area
-  (define start (box 0))
-  (define end (box 0))
-  (send (get-textarea) get-position start end)
-  (define has-selection (not (= (unbox start) (unbox end))))
-  (if has-selection
-      (send (get-textarea) insert text (unbox start) (unbox end))
-      (begin (send (get-textarea) erase)
-             (send (get-textarea) insert text)))
-  textv)
-(define-primitive vm [90 class (unstr title)] ;; new menu
-  (define pending-items '())
-  (define (queue-item i)
-    (set! pending-items (cons i pending-items)))
-  (define (add-menu-bar-to frame)
-    (define m (new menu% [parent frame] [label title]))
-    (for [(i (reverse pending-items))] (i m))
-    m)
-  (mkffiv class (list queue-item add-menu-bar-to)))
-(define-primitive vm [91 (unffiv* menu (list queue-item _add-menu-bar-to)) (unstr title) action] ;; new menu item
-  (define callback (block-callback vm action))
-  (queue-item (lambda (m)
-                (new menu-item%
-                     [label title]
-                     [parent m]
-                     [callback (lambda args (queue-callback callback))])))
-  menu)
-(define-primitive vm [100 class] (mkffiv class (oneshot)))
-(define-primitive vm [101 (unffiv o)] (oneshot-ref o))
-(define-primitive vm [102 (unffiv o) v]
-  (oneshot-set! o v)
-  v)
 (define-primitive vm [116]
   (let ((image-bytes (serialize-image vm)))
-    (display-to-file image-bytes (VM-image-filename vm) #:exists 'replace)))
-(define-primitive vm [117 _self] (exit))
-(define-primitive vm [118 (unffiv* wv window) action] ;; "onWindow close b"
-  (define callback (block-callback vm action))
-  (send window set-close-handler (lambda (_frame) (queue-callback callback) (sleep 0.2)))
-  wv)
-
-;;---------------------------------------------------------------------------
-;; END GUI
-;;---------------------------------------------------------------------------
-
-(define-primitive vm [119] (inexact->exact (round (current-inexact-milliseconds))))
+    (display-to-file image-bytes (jit-VM-image-filename vm) #:exists 'replace)))
 
 ;;===========================================================================
 
-(define (doIt vm task)
-  (define true-class (obj-class (VM-true vm))) ;; class True
-  (define name (slotAt true-class 0)) ;; "a known string", namely the name of class True
-  (define string-class (obj-class name)) ;; class String
-  (define source (mkbv string-class (string->bytes/utf-8 task)))
-  (define args (mkobj (VM-Array vm) source))
-  ((lookup-method/cache vm string-class #"doIt") vm (outermost-k vm) source))
-
 (let* ((image-filename "SmallWorld/src/image")
-       (vm (call-with-input-file image-filename (lambda (fh) (read-image image-filename fh)))))
-  (log-vm-info "Sending 'SmallWorld startUp'...")
-  (thread-wait (thread (lambda ()
-                         (define result (doIt vm "SmallWorld startUp"))
-                         (log-vm-info "Final startUp result: ~a" result)
-                         (for [(a (current-command-line-arguments))]
-                           (log-vm-info "Filing in ~a" a)
-                           (doIt vm (format "(File openRead: '~a') fileIn" a)))
-                         (yield))))
-  (log-vm-info "... terminating."))
-
-;;; Local Variables:
-;;; eval: (put 'primitive-action 'scheme-indent-function 1)
-;;; End:
+       (vm (call-with-input-file image-filename
+             (lambda (fh)
+               (read-image fh jit-VM (list (make-weak-hasheq) image-filename))))))
+  (boot-image vm
+              (lambda (vm source)
+                ((lookup-method/cache vm (obj-class source) #"doIt") vm (outermost-k vm) source))
+              (current-command-line-arguments)))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/little-smalltalk/object-memory.rkt	Sat Jul 21 18:11:55 2018 +0100
@@ -0,0 +1,242 @@
+#lang racket
+
+(provide (struct-out obj)
+         (struct-out bv)
+         (struct-out ffiv)
+         (struct-out VM)
+
+         obj-class*
+
+         mkobj
+         mkbv
+         mkffiv
+
+         boolean->obj
+
+         slotCount
+         slotAt
+         slotAtPut
+
+         unbv
+         unbv*
+         unstr
+         unffiv
+         unffiv*
+
+         bv->string
+         obj-class-name
+         search-class-method-dictionary
+         lookup-method
+
+         read-image
+         serialize-image
+
+         boot-image)
+
+(define-logger vm)
+
+(require racket/struct)
+
+(struct obj ([class #:mutable] slots)
+  #:methods gen:custom-write
+  [(define write-proc
+     (make-constructor-style-printer (lambda (o) (format "obj:~a" (obj-class-name o)))
+                                     (lambda (o)
+                                       (match (obj-class-name o)
+                                         [#"Array" (list (vector->list (obj-slots o)))]
+                                         [#"Class" (list (slotAt o 0))]
+                                         [_ '()]))))])
+
+(struct bv obj (bytes)
+  #:methods gen:custom-write
+  [(define write-proc
+     (make-constructor-style-printer (lambda (o) (format "bv:~a" (obj-class-name o)))
+                                     (lambda (o) (list (bv-bytes o)))))])
+
+(struct ffiv obj (value)
+  #:methods gen:custom-write
+  [(define write-proc
+     (make-constructor-style-printer (lambda (o) (format "ffiv:~a" (obj-class-name o)))
+                                     (lambda (o) (list (ffiv-value o)))))])
+
+(struct VM (nil true false Array Block Context Integer))
+
+(define (obj-class* vm o)
+  (if (number? o)
+      (VM-Integer vm)
+      (obj-class o)))
+
+(define (mkobj cls . fields) (obj cls (list->vector fields)))
+(define (mkbv cls bs . fields) (bv cls (list->vector fields) bs))
+(define (mkffiv cls value) (ffiv cls '#() value))
+
+(define (boolean->obj vm b)
+  (if b (VM-true vm) (VM-false vm)))
+
+(define (slotCount o) (vector-length (obj-slots o)))
+(define (slotAt o i) (vector-ref (obj-slots o) i))
+(define (slotAtPut o i v) (vector-set! (obj-slots o) i v))
+
+(define-match-expander unbv
+  (syntax-rules () [(_ bytes-pat) (bv _ _ bytes-pat)]))
+(define-match-expander unbv*
+  (syntax-rules () [(_ this-pat bytes-pat) (and this-pat (bv _ _ bytes-pat))]))
+(define-match-expander unstr
+  (syntax-rules () [(_ str-pat) (bv _ _ (app bytes->string/utf-8 str-pat))]))
+(define-match-expander unffiv
+  (syntax-rules () [(_ val-pat) (ffiv _ _ val-pat)]))
+(define-match-expander unffiv*
+  (syntax-rules () [(_ this-pat val-pat) (and this-pat (ffiv _ _ val-pat))]))
+
+(define (bv->string b)
+  (bytes->string/utf-8 (bv-bytes b)))
+
+(define (obj-class-name o)
+  (define c (obj-class o))
+  (if (and (positive? (slotCount c))
+           (bv? (slotAt c 0)))
+      (bv-bytes (slotAt c 0))
+      #"???"))
+
+(define (search-class-method-dictionary c name-bytes)
+  (define methods (slotAt c 2))
+  (for/first [(m (obj-slots methods))
+              #:when (equal? name-bytes (bv-bytes (slotAt m 0)))]
+    m))
+
+(define (lookup-method vm class name-bytes)
+  (let search ((class class))
+    (and (not (eq? class (VM-nil vm)))
+         (or (search-class-method-dictionary class name-bytes)
+             (search (slotAt class 1))))))
+
+(define (read-image fh make-vm extra-make-vm-args)
+
+  (define (next-int #:signed? [signed? #t] #:eof-ok? [eof-ok? #f])
+    (define bs (read-bytes 4 fh))
+    (if (eof-object? bs)
+        (if eof-ok? bs (error 'read-image "Early EOF"))
+        (integer-bytes->integer bs signed? #t)))
+
+  (let ((image-version (next-int))
+        (expected-version 1))
+    (when (not (= image-version expected-version))
+      (error 'read-image "Wrong image version: got ~a, expected ~a"
+             image-version
+             expected-version)))
+
+  (define object-table
+    (let loop ((acc '()))
+      (define (emit x) (loop (cons x acc)))
+      (match (next-int #:eof-ok? #t)
+        [(? eof-object?) (list->vector (reverse acc))]
+        [obj-length
+         (define type-code (next-int))
+         (define class-index (next-int))
+         (define slot-count (next-int))
+         (match type-code
+           [0 ;; SmallInt
+            (when (not (= obj-length 5))
+              (error 'read-image "Strange SmallInt obj-length: ~a" obj-length))
+            (when (not (zero? slot-count))
+              (error 'read-image "Strange SmallInt with ~a slots" slot-count))
+            (emit (next-int))]
+           [1 ;; SmallByteArray
+            (define byte-count (- obj-length slot-count 4))
+            (emit (bv class-index
+                      (for/vector [(i slot-count)] (next-int))
+                      (read-bytes byte-count fh)))]
+           [2 ;; SmallObject
+            (emit (obj class-index
+                       (for/vector [(i slot-count)] (next-int))))])])))
+
+  (for [(x object-table)]
+    (when (obj? x)
+      (set-obj-class! x (vector-ref object-table (obj-class x)))
+      (for [(i (vector-length (obj-slots x)))]
+        (vector-set! (obj-slots x) i (vector-ref object-table (vector-ref (obj-slots x) i))))))
+
+  (apply make-vm
+         (vector-ref object-table 0)
+         (vector-ref object-table 1)
+         (vector-ref object-table 2)
+         (vector-ref object-table 3)
+         (vector-ref object-table 4)
+         (vector-ref object-table 5)
+         (vector-ref object-table 6)
+         extra-make-vm-args))
+
+(define (serialize-image vm)
+  (define indices (make-hasheq))
+  (define output-rev '())
+  (define worklist-rev '())
+  (define next-index 0)
+
+  (define (push-bytes! item) (set! output-rev (cons item output-rev)))
+  (define (push-int! n) (push-bytes! (integer->integer-bytes n 4 #t #t)))
+
+  (define (object->index o)
+    (if (ffiv? o)
+        (object->index (VM-nil vm))
+        (hash-ref! indices o (lambda ()
+                               (begin0 next-index
+                                 (set! next-index (+ next-index 1))
+                                 (set! worklist-rev (cons o worklist-rev)))))))
+
+  (push-int! 1) ;; version number
+  (object->index (VM-nil vm))
+  (object->index (VM-true vm))
+  (object->index (VM-false vm))
+  (object->index (VM-Array vm))
+  (object->index (VM-Block vm))
+  (object->index (VM-Context vm))
+  (object->index (VM-Integer vm))
+  (for [(i 10)] (object->index i))
+
+  (let loop ()
+    (define worklist (reverse worklist-rev))
+    (set! worklist-rev '())
+    (when (pair? worklist)
+      (for [(o worklist)]
+        (match o
+          [(? number?)
+           (push-int! 5)
+           (push-int! 0)
+           (push-int! (object->index (VM-Integer vm)))
+           (push-int! 0)
+           (push-int! o)]
+          [(bv class slots bytes)
+           (push-int! (+ (bytes-length bytes) (vector-length slots) 4)) ;; weird
+           (push-int! 1)
+           (push-int! (object->index class))
+           (push-int! (vector-length slots))
+           (for [(s slots)] (push-int! (object->index s)))
+           (push-bytes! bytes)]
+          [(obj class slots)
+           (push-int! (+ (vector-length slots) 4))
+           (push-int! 2)
+           (push-int! (object->index class))
+           (push-int! (vector-length slots))
+           (for [(s slots)] (push-int! (object->index s)))]))
+      (loop)))
+
+  (bytes-append* (reverse output-rev)))
+
+(define (boot-image vm evaluator files-to-file-in)
+  (define (doIt task)
+    (define true-class (obj-class (VM-true vm))) ;; class True
+    (define name (slotAt true-class 0)) ;; "a known string", namely the name of class True
+    (define string-class (obj-class name)) ;; class String
+    (define source (mkbv string-class (string->bytes/utf-8 task)))
+    (evaluator vm source))
+
+  (log-vm-info "Sending 'SmallWorld startUp'...")
+  (thread-wait (thread (lambda ()
+                         (define result (doIt "SmallWorld startUp"))
+                         (log-vm-info "Final startUp result: ~a" result)
+                         (for [(a files-to-file-in)]
+                           (log-vm-info "Filing in ~a" a)
+                           (doIt (format "(File openRead: '~a') fileIn" a)))
+                         ;; (yield)
+                         )))
+  (log-vm-info "... boot-image complete."))
--- a/experiments/little-smalltalk/oneshot.rkt	Sat Jul 21 17:13:31 2018 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-#lang racket
-
-(provide oneshot oneshot-set! oneshot-ref)
-
-(define (oneshot)
-  (thread (lambda ()
-            (define (no-value waiters)
-              (match (thread-receive)
-                [(list 'get ch) (no-value (cons ch waiters))]
-                [(list 'set v)
-                 (for [(ch waiters)] (channel-put ch v))
-                 (value v)]))
-            (define (value v)
-              (match (thread-receive)
-                [(list 'get ch)
-                 (channel-put ch v)
-                 (value v)]
-                [(list 'set v)
-                 (value v)]))
-            (no-value '()))))
-
-(define (oneshot-set! o v)
-  (thread-send o (list 'set v)))
-
-(define (oneshot-ref o)
-  (define ch (make-channel))
-  (thread-send o (list 'get ch))
-  (channel-get ch))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/little-smalltalk/primitives.rkt	Sat Jul 21 18:11:55 2018 +0100
@@ -0,0 +1,313 @@
+#lang racket/gui
+
+(provide *primitive-handlers*
+         *primitive-code-snippets*
+         define-primitive
+         gen:vm-callback
+
+         ;; These are referred to by spliced-in S-expression code
+         ;; fragments, indirectly via the eval namespace used to
+         ;; instantiate compiled code.
+         ;;
+         vm-block-callback
+         smalltalk-frame%
+         log-vm/gui-debug
+         log-vm/gui-info
+         log-vm/gui-warning
+         log-vm/gui-error)
+
+(require racket/generic)
+(require "object-memory.rkt")
+
+(define-logger vm)
+(define-logger vm/gui)
+
+(define *primitive-handlers* (make-hash))
+(define *primitive-code-snippets* (make-hash))
+
+(define-syntax-rule (define-primitive vm [n arg-pat ...] body ...)
+  (begin (hash-set! *primitive-handlers*
+                    n
+                    (lambda (vm args)
+                      (match (obj-slots args) [(vector arg-pat ...) (let () body ...)])))
+         (hash-set! *primitive-code-snippets*
+                    n
+                    (lambda (vm-exp arg-exps)
+                      `(match* [,vm-exp ,@arg-exps]
+                         [[vm arg-pat ...] (let () body ...)])))))
+
+(define-generics vm-callback
+  (vm-block-callback vm-callback action))
+
+;;===========================================================================
+
+(define (oneshot)
+  (thread (lambda ()
+            (define (no-value waiters)
+              (match (thread-receive)
+                [(list 'get ch) (no-value (cons ch waiters))]
+                [(list 'set v)
+                 (for [(ch waiters)] (channel-put ch v))
+                 (value v)]))
+            (define (value v)
+              (match (thread-receive)
+                [(list 'get ch)
+                 (channel-put ch v)
+                 (value v)]
+                [(list 'set v)
+                 (value v)]))
+            (no-value '()))))
+
+(define (oneshot-set! o v)
+  (thread-send o (list 'set v)))
+
+(define (oneshot-ref o)
+  (define ch (make-channel))
+  (thread-send o (list 'get ch))
+  (channel-get ch))
+
+;;===========================================================================
+
+(define-primitive vm [1 b a] (boolean->obj vm (eq? a b)))
+(define-primitive vm [2 x] (obj-class* vm x))
+(define-primitive vm [4 o] (cond [(bv? o) (bytes-length (bv-bytes o))]
+                                 [(obj? o) (slotCount o)]
+                                 [(number? o) 0]
+                                 [else (error 'execute "Primitive 4 failed")]))
+(define-primitive vm [5 value target index]
+  (slotAtPut target (- index 1) value)
+  target)
+;; 6 - "new context execute"
+(define-primitive vm [7 class count]
+  (obj class (make-vector count (VM-nil vm))))
+
+(define-primitive vm [10 b a] (+ a b)) ;; TODO: overflow
+(define-primitive vm [11 n d] (quotient n d))
+(define-primitive vm [12 n d] (modulo n d))
+(define-primitive vm [14 b a] (boolean->obj vm (= a b)))
+(define-primitive vm [15 b a] (* a b))
+(define-primitive vm [16 a b] (- a b)) ;; NB. ordering
+
+(define-primitive vm [18 v] (log-vm-info "DEBUG: value ~v class ~v" v (obj-class* vm v)))
+
+(define-primitive vm [20 class count] (mkbv class (make-bytes count)))
+(define-primitive vm [21 source index] (bytes-ref (bv-bytes source) (- index 1)))
+(define-primitive vm [22 value target index]
+  (bytes-set! (bv-bytes target) (- index 1) value)
+  target)
+(define-primitive vm [24 (unbv b) (unbv* av a)] (mkbv (obj-class av) (bytes-append a b)))
+(define-primitive vm [26 (unbv a) (unbv b)] ;; NB. ordering
+  (cond [(bytes<? a b) -1]
+        [(bytes=? a b) 0]
+        [(bytes>? a b) 1]))
+
+(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))))
+
+(define-primitive vm [41 class (unstr filename)]
+  (mkffiv class (open-output-file filename #:exists 'replace)))
+(define-primitive vm [42 class (unstr filename)]
+  (mkffiv class (open-input-file filename)))
+(define-primitive vm [44 class (unffiv fh)]
+  (match (read-bytes-line fh)
+    [(? eof-object?) (VM-nil vm)]
+    [bs (mkbv class bs)]))
+
+;;---------------------------------------------------------------------------
+;; GUI
+;;---------------------------------------------------------------------------
+
+(define smalltalk-frame%
+  (class frame%
+    (field [close-handler void])
+    (define/public (set-close-handler new-handler)
+      (set! close-handler new-handler))
+    (define/augment (on-close)
+      (close-handler this))
+    (super-new)))
+
+(define-primitive vm [60 class] ;; make window
+  (log-vm/gui-debug "Creating window")
+  (mkffiv class (new smalltalk-frame% [label "Racket SmallWorld"])))
+(define-primitive vm [61 (unffiv window) flag] ;; show/hide text window
+  (log-vm/gui-debug "Show/hide window ~a" (eq? flag (VM-true vm)))
+  (send window show (eq? flag (VM-true vm)))
+  flag)
+(define-primitive vm [62 (unffiv* wv window) (unffiv (list _item factory))] ;; set content pane
+  (log-vm/gui-debug "Set content pane")
+  (factory window)
+  wv)
+(define-primitive vm [63 (unffiv* wv window) height width] ;; set size
+  (log-vm/gui-debug "Window resize ~ax~a" width height)
+  (send window resize width height)
+  wv)
+(define-primitive vm [64 (unffiv* wv window) (unffiv (list _queue-item add-menu-bar-to))]
+  ;; add menu to window
+  (define mb (or (send window get-menu-bar)
+                 (new menu-bar% [parent window])))
+  (log-vm/gui-debug "Add menu to window")
+  (add-menu-bar-to mb)
+  wv)
+(define-primitive vm [65 (unffiv* wv window) (unstr text)] ;; set title
+  (log-vm/gui-debug "Set window title ~v" text)
+  (send window set-label text)
+  wv)
+(define-primitive vm [66 window] ;; repaint window
+  ;; nothing needed
+  window)
+(define-primitive vm [70 class (unstr label)] ;; new label panel
+  (log-vm/gui-debug "Schedule label panel ~v" label)
+  (define (create-label-in parent)
+    (log-vm/gui-debug "Create label panel ~v" label)
+    (new message% [parent parent] [label label]))
+  (mkffiv class (list 'label create-label-in)))
+(define-primitive vm [71 class (unstr label) action] ;; new button
+  (define callback (vm-block-callback vm action))
+  (log-vm/gui-debug "Schedule button ~v" label)
+  (define (create-button-in parent)
+    (log-vm/gui-debug "Create button ~v" label)
+    (new button%
+         [label label]
+         [parent parent]
+         [callback (lambda args (queue-callback callback))]))
+  (mkffiv class (list 'button create-button-in)))
+(define-primitive vm [72 class] ;; new text line
+  (log-vm/gui-debug "Schedule textfield")
+  (define textfield-editor #f)
+  (define (add-textfield-to parent)
+    (set! textfield-editor (send (new text-field% [label #f] [parent parent]) get-editor))
+    textfield-editor)
+  (mkffiv class (list (lambda () textfield-editor) add-textfield-to)))
+(define-primitive vm [73 class] ;; new text area
+  (log-vm/gui-debug "Schedule textarea")
+  (define editor (new text%))
+  (define (add-editor-to frame)
+    (log-vm/gui-debug "Create textarea")
+    (new editor-canvas% [parent frame] [editor editor]))
+  (mkffiv class (list (lambda () editor) add-editor-to)))
+(define-primitive vm [74 class width height data] ;; new grid panel
+  (log-vm/gui-debug "Schedule grid panel ~ax~a ~a" width height data)
+  (define (create-grid-in parent)
+    (log-vm/gui-debug "Create grid panel ~ax~a ~a" width height data)
+    (define vp (new vertical-pane% [parent parent]))
+    (for [(row height)]
+      (define hp (new horizontal-pane% [parent vp]))
+      (for [(col width)]
+        (define i (+ col (* row width)))
+        (when (< i (slotCount data))
+          (match (slotAt data i)
+            [(unffiv (list _ factory)) (factory hp)]))))
+    vp)
+  (mkffiv class (list 'grid create-grid-in)))
+(define-primitive vm [75 class data action] ;; new list panel
+  (define callback (vm-block-callback vm action))
+  (log-vm/gui-debug "Schedule listpanel ~a" data)
+  (define lb #f)
+  (define old-selection #f)
+  (define (create-list-panel-in parent)
+    (log-vm/gui-debug "Create listpanel ~a" data)
+    (set! lb (new list-box%
+                  [label #f]
+                  [parent parent]
+                  [choices (for/list [(c (obj-slots data))] (bv->string c))]
+                  [callback (lambda _args
+                              (log-vm/gui-debug "_args: ~v for listpanel ~a"
+                                                _args
+                                                (eq-hash-code lb))
+                              (define selection (send lb get-selection))
+                              (when (not (equal? old-selection selection))
+                                (set! old-selection selection)
+                                (queue-callback
+                                 (lambda ()
+                                   (log-vm/gui-debug "Item selected ~v" selection)
+                                   (callback (if selection (+ selection 1) 0))))))]))
+    (log-vm/gui-debug "The result is ~a" (eq-hash-code lb))
+    lb)
+  (mkffiv class (list (lambda () lb) create-list-panel-in)))
+(define-primitive vm [76 class north south east west center] ;; new border panel
+  (log-vm/gui-debug "Schedule borderpanel")
+  (define (add-w w p)
+    (when (not (eq? (VM-nil vm) w))
+      (match w [(unffiv (list _ factory)) (factory p)])))
+  (define (create-border-panel-in parent)
+    (log-vm/gui-debug "Create borderpanel")
+    (define vp (new vertical-pane% [parent parent]))
+    (add-w north vp)
+    (when (for/or [(w (list west center east))] (not (eq? (VM-nil vm) w)))
+      (define hp (new horizontal-pane% [parent vp]))
+      (add-w west hp)
+      (add-w center hp)
+      (add-w east hp))
+    (add-w south vp)
+    vp)
+  (mkffiv class (list 'border-panel create-border-panel-in)))
+(define-primitive vm [80 class (unffiv (list get-textarea _factory))] ;; content of text area
+  (mkbv class (string->bytes/utf-8 (send (get-textarea) get-text))))
+(define-primitive vm [81 class (unffiv (list get-textarea _factory))] ;; content of selected text area
+  (define start (box 0))
+  (define end (box 0))
+  (send (get-textarea) get-position start end)
+  (define has-selection (not (= (unbox start) (unbox end))))
+  (mkbv class
+        (string->bytes/utf-8 (send (get-textarea) get-text
+                                   (if has-selection (unbox start) 0)
+                                   (if has-selection (unbox end) 'eof)))))
+(define-primitive vm [82 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set text area
+  (log-vm/gui-debug "Update textarea ~v" text)
+  (send (get-textarea) erase)
+  (send (get-textarea) insert text)
+  textv)
+(define-primitive vm [83 (unffiv (list get-lb _factory))] ;; get selected index
+  (log-vm/gui-debug "Get selected index")
+  (define lb (get-lb))
+  (define s (send lb get-selection))
+  (if s (+ s 1) 0))
+(define-primitive vm [84 (unffiv* lbv (list get-lb _factory)) data] ;; set list data
+  (define lb (get-lb))
+  (log-vm/gui-debug "Update list ~a data ~v" (eq-hash-code lb) data)
+  (send lb set (for/list [(c (obj-slots data))] (bv->string c)))
+  lbv)
+(define-primitive vm [89 (unffiv (list get-textarea _factory)) (and textv (unstr text))] ;; set selected text area
+  (define start (box 0))
+  (define end (box 0))
+  (send (get-textarea) get-position start end)
+  (define has-selection (not (= (unbox start) (unbox end))))
+  (if has-selection
+      (send (get-textarea) insert text (unbox start) (unbox end))
+      (begin (send (get-textarea) erase)
+             (send (get-textarea) insert text)))
+  textv)
+(define-primitive vm [90 class (unstr title)] ;; new menu
+  (define pending-items '())
+  (define (queue-item i)
+    (set! pending-items (cons i pending-items)))
+  (define (add-menu-bar-to frame)
+    (define m (new menu% [parent frame] [label title]))
+    (for [(i (reverse pending-items))] (i m))
+    m)
+  (mkffiv class (list queue-item add-menu-bar-to)))
+(define-primitive vm [91 (unffiv* menu (list queue-item _add-menu-bar-to)) (unstr title) action] ;; new menu item
+  (define callback (vm-block-callback vm action))
+  (queue-item (lambda (m)
+                (new menu-item%
+                     [label title]
+                     [parent m]
+                     [callback (lambda args (queue-callback callback))])))
+  menu)
+(define-primitive vm [100 class] (mkffiv class (oneshot)))
+(define-primitive vm [101 (unffiv o)] (oneshot-ref o))
+(define-primitive vm [102 (unffiv o) v]
+  (oneshot-set! o v)
+  v)
+;; 116 - save image to preset filename
+(define-primitive vm [117 _self] (exit))
+(define-primitive vm [118 (unffiv* wv window) action] ;; "onWindow close b"
+  (define callback (vm-block-callback vm action))
+  (send window set-close-handler (lambda (_frame) (queue-callback callback) (sleep 0.2)))
+  wv)
+
+;;---------------------------------------------------------------------------
+;; END GUI
+;;---------------------------------------------------------------------------
+
+(define-primitive vm [119] (inexact->exact (round (current-inexact-milliseconds))))
--- a/experiments/little-smalltalk/run-SmallWorld-2015.rkt	Sat Jul 21 17:13:31 2018 +0100
+++ b/experiments/little-smalltalk/run-SmallWorld-2015.rkt	Sat Jul 21 18:11:55 2018 +0100
@@ -5,180 +5,25 @@
 
 (require racket/struct)
 (require racket/bytes)
-(require "oneshot.rkt")
+(require "object-memory.rkt")
+(require "primitives.rkt")
 
 (define-logger vm)
-(define-logger vm/gui)
 
-(struct obj ([class #:mutable] slots)
-  #:methods gen:custom-write
-  [(define write-proc
-     (make-constructor-style-printer (lambda (o) (format "obj:~a" (obj-class-name o)))
-                                     (lambda (o) (if (equal? #"Array" (obj-class-name o))
-                                                     (list (vector->list (obj-slots o)))
-                                                     '()))))])
-(struct bv obj (bytes)
-  #:methods gen:custom-write
-  [(define write-proc
-     (make-constructor-style-printer (lambda (o) (format "bv:~a" (obj-class-name o)))
-                                     (lambda (o) (list (bv-bytes o)))))])
-
-(struct ffiv obj (value)
-  #:methods gen:custom-write
-  [(define write-proc
-     (make-constructor-style-printer (lambda (o) (format "ffiv:~a" (obj-class-name o)))
-                                     (lambda (o) (list (ffiv-value o)))))])
-
-(define-match-expander unbv
-  (syntax-rules () [(_ bytes-pat) (bv _ _ bytes-pat)]))
-(define-match-expander unbv*
-  (syntax-rules () [(_ this-pat bytes-pat) (and this-pat (bv _ _ bytes-pat))]))
-(define-match-expander unstr
-  (syntax-rules () [(_ str-pat) (bv _ _ (app bytes->string/utf-8 str-pat))]))
-(define-match-expander unffiv
-  (syntax-rules () [(_ val-pat) (ffiv _ _ val-pat)]))
-(define-match-expander unffiv*
-  (syntax-rules () [(_ this-pat val-pat) (and this-pat (ffiv _ _ val-pat))]))
-
-(define (obj-class-name o)
-  (define c (obj-class o))
-  (if (and (positive? (slotCount c))
-           (bv? (slotAt c 0)))
-      (bv-bytes (slotAt c 0))
-      #"???"))
-
-(struct VM (nil true false Array Block Context Integer cache image-filename))
-
-(define (read-image image-filename fh)
-
-  (define (next-int #:signed? [signed? #t] #:eof-ok? [eof-ok? #f])
-    (define bs (read-bytes 4 fh))
-    (if (eof-object? bs)
-        (if eof-ok? bs (error 'read-image "Early EOF"))
-        (integer-bytes->integer bs signed? #t)))
-
-  (let ((image-version (next-int))
-        (expected-version 1))
-    (when (not (= image-version expected-version))
-      (error 'read-image "Wrong image version: got ~a, expected ~a"
-             image-version
-             expected-version)))
-
-  (define object-table
-    (let loop ((acc '()))
-      (define (emit x) (loop (cons x acc)))
-      (match (next-int #:eof-ok? #t)
-        [(? eof-object?) (list->vector (reverse acc))]
-        [obj-length
-         (define type-code (next-int))
-         (define class-index (next-int))
-         (define slot-count (next-int))
-         (match type-code
-           [0 ;; SmallInt
-            (when (not (= obj-length 5))
-              (error 'read-image "Strange SmallInt obj-length: ~a" obj-length))
-            (when (not (zero? slot-count))
-              (error 'read-image "Strange SmallInt with ~a slots" slot-count))
-            (emit (next-int))]
-           [1 ;; SmallByteArray
-            (define byte-count (- obj-length slot-count 4))
-            (emit (bv class-index
-                      (for/vector [(i slot-count)] (next-int))
-                      (read-bytes byte-count fh)))]
-           [2 ;; SmallObject
-            (emit (obj class-index
-                       (for/vector [(i slot-count)] (next-int))))])])))
-
-  (for [(x object-table)]
-    (when (obj? x)
-      (set-obj-class! x (vector-ref object-table (obj-class x)))
-      (for [(i (vector-length (obj-slots x)))]
-        (vector-set! (obj-slots x) i (vector-ref object-table (vector-ref (obj-slots x) i))))))
-
-  (VM (vector-ref object-table 0)
-      (vector-ref object-table 1)
-      (vector-ref object-table 2)
-      (vector-ref object-table 3)
-      (vector-ref object-table 4)
-      (vector-ref object-table 5)
-      (vector-ref object-table 6)
-      (make-weak-hasheq)
-      image-filename))
-
-(define (serialize-image vm)
-  (define indices (make-hasheq))
-  (define output-rev '())
-  (define worklist-rev '())
-  (define next-index 0)
-
-  (define (push-bytes! item) (set! output-rev (cons item output-rev)))
-  (define (push-int! n) (push-bytes! (integer->integer-bytes n 4 #t #t)))
-
-  (define (object->index o)
-    (if (ffiv? o)
-        (object->index (VM-nil vm))
-        (hash-ref! indices o (lambda ()
-                               (begin0 next-index
-                                 (set! next-index (+ next-index 1))
-                                 (set! worklist-rev (cons o worklist-rev)))))))
-
-  (push-int! 1) ;; version number
-  (object->index (VM-nil vm))
-  (object->index (VM-true vm))
-  (object->index (VM-false vm))
-  (object->index (VM-Array vm))
-  (object->index (VM-Block vm))
-  (object->index (VM-Context vm))
-  (object->index (VM-Integer vm))
-  (for [(i 10)] (object->index i))
-
-  (let loop ()
-    (define worklist (reverse worklist-rev))
-    (set! worklist-rev '())
-    (when (pair? worklist)
-      (for [(o worklist)]
-        (match o
-          [(? number?)
-           (push-int! 5)
-           (push-int! 0)
-           (push-int! (object->index (VM-Integer vm)))
-           (push-int! 0)
-           (push-int! o)]
-          [(bv class slots bytes)
-           (push-int! (+ (bytes-length bytes) (vector-length slots) 4)) ;; weird
-           (push-int! 1)
-           (push-int! (object->index class))
-           (push-int! (vector-length slots))
-           (for [(s slots)] (push-int! (object->index s)))
-           (push-bytes! bytes)]
-          [(obj class slots)
-           (push-int! (+ (vector-length slots) 4)) ;; weird
-           (push-int! 2)
-           (push-int! (object->index class))
-           (push-int! (vector-length slots))
-           (for [(s slots)] (push-int! (object->index s)))]))
-      (loop)))
-
-  (bytes-append* (reverse output-rev)))
-
-(define (slotCount o) (vector-length (obj-slots o)))
-(define (slotAt o i) (vector-ref (obj-slots o) i))
-(define (slotAtPut o i v) (vector-set! (obj-slots o) i v))
-
-(define (search-class-method-dictionary c name-bytes)
-  (define methods (slotAt c 2))
-  (for/first [(m (obj-slots methods))
-              #:when (equal? name-bytes (bv-bytes (slotAt m 0)))]
-    m))
-
-(define (mkobj cls . fields)
-  (obj cls (list->vector fields)))
-
-(define (mkbv cls bs . fields)
-  (bv cls (list->vector fields) bs))
-
-(define (mkffiv cls value)
-  (ffiv cls '#() value))
+(struct int-VM VM (cache image-filename)
+  #:methods gen:vm-callback
+  [(define (vm-block-callback vm block)
+     ;; Runs block in a new thread
+     (lambda args
+       (let ((ctx (clone-array block)))
+         (define argument-location (slotAt ctx 7))
+         (for [(i (in-naturals argument-location)) (arg (in-list args))]
+           (slotAtPut (slotAt ctx 2) i arg))
+         (slotAtPut ctx 3 (mkarray vm (slotCount (slotAt ctx 3))))
+         (slotAtPut ctx 4 (slotAt ctx 9)) ;; reset IP to correct block offset
+         (slotAtPut ctx 5 0) ;; zero stack-top
+         (slotAtPut ctx 6 (VM-nil vm)) ;; no previous context
+         (thread (lambda () (execute vm ctx))))))])
 
 (define (mkarray vm count [init (VM-nil vm)])
   (obj (VM-Array vm) (make-vector count init)))
@@ -201,23 +46,13 @@
     (slotAtPut b i (slotAt a (+ i start))))
   b)
 
-(define (boolean->obj vm b)
-  (if b (VM-true vm) (VM-false vm)))
-
 (define (lookup-method/cache vm class selector)
   (define name-bytes (bv-bytes selector))
-  (define class-cache (hash-ref! (VM-cache vm) class make-weak-hash))
+  (define class-cache (hash-ref! (int-VM-cache vm) class make-weak-hash))
   (hash-ref! class-cache
              name-bytes
              (lambda ()
-               (lookup-method vm class selector))))
-
-(define (lookup-method vm class selector)
-  (define name-bytes (bv-bytes selector))
-  (let search ((class class))
-    (and (not (eq? class (VM-nil vm)))
-         (or (search-class-method-dictionary class name-bytes)
-             (search (slotAt class 1))))))
+               (lookup-method vm class (bv-bytes selector)))))
 
 (define (store-registers! ctx ip stack-top)
   (slotAtPut ctx 4 ip)
@@ -243,37 +78,10 @@
     [new-method
      (execute vm (build-context vm ctx arguments new-method))]))
 
-(define (obj-class* vm o)
-  (if (number? o)
-      (VM-Integer vm)
-      (obj-class o)))
-
 (define (send-message vm ctx ip stack-top arguments selector)
   (log-vm-debug "sending: ~a ~a" selector arguments)
   (send-message* vm ctx ip stack-top arguments (obj-class* vm (slotAt arguments 0)) selector))
 
-(define (block-callback vm block)
-  ;; Runs block in a new thread
-  (lambda args
-    (let ((ctx (clone-array block)))
-      (define argument-location (slotAt ctx 7))
-      (for [(i (in-naturals argument-location)) (arg (in-list args))]
-        (slotAtPut (slotAt ctx 2) i arg))
-      (slotAtPut ctx 3 (mkarray vm (slotCount (slotAt ctx 3))))
-      (slotAtPut ctx 4 (slotAt ctx 9)) ;; reset IP to correct block offset
-      (slotAtPut ctx 5 0) ;; zero stack-top
-      (slotAtPut ctx 6 (VM-nil vm)) ;; no previous context
-      (thread (lambda () (execute vm ctx))))))
-
-(define smalltalk-frame%
-  (class frame%
-    (field [close-handler void])
-    (define/public (set-close-handler new-handler)
-      (set! close-handler new-handler))
-    (define/augment (on-close)
-      (close-handler this))
-    (super-new)))
-
 (define (resume-context vm ctx result)
   (if (eq? (VM-nil vm) ctx)
       result
@@ -408,7 +216,8 @@
          [35 (push-and-continue ctx)]
 
          [_ (define args (pop-multiple! low))
-            (push-and-continue (perform-primitive vm primitive-number args))])]
+            (define handler (hash-ref *primitive-handlers* primitive-number))
+            (push-and-continue (handler vm args))])]
 
       [14 (push-and-continue (slotAt (obj-class* vm receiver) (+ low 5)))] ;; PushClassVariable
       [15 ;; Do Special
@@ -438,302 +247,25 @@
 
   (interpret))
 
-(define (perform-primitive vm primitive-number args)
-  (define-syntax-rule (primitive-action [arg-pat ...] body ...)
-    (match (obj-slots args) [(vector arg-pat ...) (let () body ...)]))
-
-  (match primitive-number
-    [1 (primitive-action [b a] (boolean->obj vm (eq? a b)))]
-    [2 (primitive-action [x] (obj-class* vm x))]
-    [4 (primitive-action [o] (cond [(bv? o) (bytes-length (bv-bytes o))]
-                                   [(obj? o) (slotCount o)]
-                                   [(number? o) 0]
-                                   [else (error 'execute "Primitive 4 failed")]))]
-    [5 (primitive-action [value target index]
-         (slotAtPut target (- index 1) value)
-         target)]
-    [6 (primitive-action [inner-ctx] ;; "new context execute"
-         (execute vm inner-ctx))]
-    [7 (primitive-action [class count]
-         (obj class (make-vector count (VM-nil vm))))]
-
-    [10 (primitive-action [b a] (+ a b))] ;; TODO: overflow
-    [11 (primitive-action [n d] (quotient n d))]
-    [12 (primitive-action [n d] (modulo n d))]
-    [14 (primitive-action [b a] (boolean->obj vm (= a b)))]
-    [15 (primitive-action [b a] (* a b))]
-    [16 (primitive-action [a b] (- a b))] ;; NB. ordering
-
-    [18 (primitive-action [v] (log-vm-info "DEBUG: value ~v class ~v" v (obj-class* vm v)))]
+;;===========================================================================
 
-    [20 (primitive-action [class count] (mkbv class (make-bytes count)))]
-    [21 (primitive-action [source index] (bytes-ref (bv-bytes source) (- index 1)))]
-    [22 (primitive-action [value target index]
-          (bytes-set! (bv-bytes target) (- index 1) value)
-          target)]
-    [24 (primitive-action [(unbv b) (unbv* av a)] (mkbv (obj-class av) (bytes-append a b)))]
-    [26 (primitive-action [(unbv a) (unbv b)] ;; NB. ordering
-          (cond [(bytes<? a b) -1]
-                [(bytes=? a b) 0]
-                [(bytes>? a b) 1]))]
-
-    [30 (primitive-action [source index] (slotAt source (- index 1)))]
-    [31 (primitive-action [v o] (obj (obj-class o) (vector-append (obj-slots o) (vector v))))]
-    [36 args] ;; "fast array creation"
-
-    [41 (primitive-action [class (unstr filename)]
-          (mkffiv class (open-output-file filename #:exists 'replace)))]
-    [42 (primitive-action [class (unstr filename)]
-          (mkffiv class (open-input-file filename)))]
-    [44 (primitive-action [class (unffiv fh)]
-          (match (read-bytes-line fh)
-            [(? eof-object?) (VM-nil vm)]
-            [bs (mkbv class bs)]))]
-
-    ;;---------------------------------------------------------------------------
-    ;; GUI
-    ;;---------------------------------------------------------------------------
+(define-primitive vm [6 inner-ctx] ;; "new context execute"
+  (execute vm inner-ctx))
 
-    [60 ;; make window
-     (primitive-action [class]
-       (log-vm/gui-debug "Creating window")
-       (mkffiv class (new smalltalk-frame% [label "Racket SmallWorld"])))]
-    [61 ;; show/hide text window
-     (primitive-action [(unffiv window) flag]
-       (log-vm/gui-debug "Show/hide window ~a" (eq? flag (VM-true vm)))
-       (send window show (eq? flag (VM-true vm)))
-       flag)]
-    [62 ;; set content pane
-     (primitive-action [(unffiv* wv window) (unffiv (list _item factory))]
-       (log-vm/gui-debug "Set content pane")
-       (factory window)
-       wv)]
-    [63 ;; set size
-     (primitive-action [(unffiv* wv window) height width]
-       (log-vm/gui-debug "Window resize ~ax~a" width height)
-       (send window resize width height)
-       wv)]
-    [64 ;; add menu to window
-     (primitive-action [(unffiv* wv window) (unffiv (list _queue-item add-menu-bar-to))]
-       (define mb (or (send window get-menu-bar)
-                      (new menu-bar% [parent window])))
-       (log-vm/gui-debug "Add menu to window")
-       (add-menu-bar-to mb)
-       wv)]
-    [65 ;; set title
-     (primitive-action [(unffiv* wv window) (unstr text)]
-       (log-vm/gui-debug "Set window title ~v" text)
-       (send window set-label text)
-       wv)]
-    [66 ;; repaint window
-     (primitive-action [window]
-       ;; nothing needed
-       window)]
-    [70 ;; new label panel
-     (primitive-action [class (unstr label)]
-       (log-vm/gui-debug "Schedule label panel ~v" label)
-       (define (create-label-in parent)
-         (log-vm/gui-debug "Create label panel ~v" label)
-         (new message% [parent parent] [label label]))
-       (mkffiv class (list 'label create-label-in)))]
-    [71 ;; new button
-     (primitive-action [class (unstr label) action]
-       (define callback (block-callback vm action))
-       (log-vm/gui-debug "Schedule button ~v" label)
-       (define (create-button-in parent)
-         (log-vm/gui-debug "Create button ~v" label)
-         (new button%
-              [label label]
-              [parent parent]
-              [callback (lambda args (queue-callback callback))]))
-       (mkffiv class (list 'button create-button-in)))]
-    [72 ;; new text line
-     (primitive-action [class]
-       (log-vm/gui-debug "Schedule textfield")
-       (define textfield-editor #f)
-       (define (add-textfield-to parent)
-         (set! textfield-editor (send (new text-field% [label #f] [parent parent]) get-editor))
-         textfield-editor)
-       (mkffiv class (list (lambda () textfield-editor) add-textfield-to)))]
-    [73 ;; new text area
-     (primitive-action [class]
-       (log-vm/gui-debug "Schedule textarea")
-       (define editor (new text%))
-       (define (add-editor-to frame)
-         (log-vm/gui-debug "Create textarea")
-         (new editor-canvas% [parent frame] [editor editor]))
-       (mkffiv class (list (lambda () editor) add-editor-to)))]
-    [74 ;; new grid panel
-     (primitive-action [class width height data]
-       (log-vm/gui-debug "Schedule grid panel ~ax~a ~a" width height data)
-       (define (create-grid-in parent)
-         (log-vm/gui-debug "Create grid panel ~ax~a ~a" width height data)
-         (define vp (new vertical-pane% [parent parent]))
-         (for [(row height)]
-           (define hp (new horizontal-pane% [parent vp]))
-           (for [(col width)]
-             (define i (+ col (* row width)))
-             (when (< i (slotCount data))
-               (match (slotAt data i)
-                 [(unffiv (list _ factory)) (factory hp)]))))
-         vp)
-       (mkffiv class (list 'grid create-grid-in)))]
-    [75 ;; new list panel
-     (primitive-action [class data action]
-       (define callback (block-callback vm action))
-       (log-vm/gui-debug "Schedule listpanel ~a" data)
-       (define lb #f)
-       (define old-selection #f)
-       (define (create-list-panel-in parent)
-         (log-vm/gui-debug "Create listpanel ~a" data)
-         (set! lb (new list-box%
-                       [label #f]
-                       [parent parent]
-                       [choices (for/list [(c (obj-slots data))] (match-define (unstr t) c) t)]
-                       [callback (lambda _args
-                                   (log-vm/gui-debug "_args: ~v for listpanel ~a"
-                                                     _args
-                                                     (eq-hash-code lb))
-                                   (define selection (send lb get-selection))
-                                   (when (not (equal? old-selection selection))
-                                     (set! old-selection selection)
-                                     (queue-callback
-                                      (lambda ()
-                                        (log-vm/gui-debug "Item selected ~v" selection)
-                                        (callback (if selection (+ selection 1) 0))))))]))
-         (log-vm/gui-debug "The result is ~a" (eq-hash-code lb))
-         lb)
-       (mkffiv class (list (lambda () lb) create-list-panel-in)))]
-    [76 ;; new border panel
-     (primitive-action [class north south east west center]
-       (log-vm/gui-debug "Schedule borderpanel")
-       (define (add-w w p)
-         (when (not (eq? (VM-nil vm) w))
-           (match w [(unffiv (list _ factory)) (factory p)])))
-       (define (create-border-panel-in parent)
-         (log-vm/gui-debug "Create borderpanel")
-         (define vp (new vertical-pane% [parent parent]))
-         (add-w north vp)
-         (when (for/or [(w (list west center east))] (not (eq? (VM-nil vm) w)))
-           (define hp (new horizontal-pane% [parent vp]))
-           (add-w west hp)
-           (add-w center hp)
-           (add-w east hp))
-         (add-w south vp)
-         vp)
-       (mkffiv class (list 'border-panel create-border-panel-in)))]
-    [80 ;; content of text area
-     (primitive-action [class (unffiv (list get-textarea _factory))]
-       (mkbv class (string->bytes/utf-8 (send (get-textarea) get-text))))]
-    [81 ;; content of selected text area
-     (primitive-action [class (unffiv (list get-textarea _factory))]
-       (define start (box 0))
-       (define end (box 0))
-       (send (get-textarea) get-position start end)
-       (define has-selection (not (= (unbox start) (unbox end))))
-       (mkbv class
-             (string->bytes/utf-8 (send (get-textarea) get-text
-                                        (if has-selection (unbox start) 0)
-                                        (if has-selection (unbox end) 'eof)))))]
-    [82 ;; set text area
-     (primitive-action [(unffiv (list get-textarea _factory)) (and textv (unstr text))]
-       (log-vm/gui-debug "Update textarea ~v" text)
-       (send (get-textarea) erase)
-       (send (get-textarea) insert text)
-       textv)]
-    [83 ;; get selected index
-     (primitive-action [(unffiv (list get-lb _factory))]
-       (log-vm/gui-debug "Get selected index")
-       (define lb (get-lb))
-       (define s (send lb get-selection))
-       (if s (+ s 1) 0))]
-    [84 ;; set list data
-     (primitive-action [(unffiv* lbv (list get-lb _factory)) data]
-       (define lb (get-lb))
-       (log-vm/gui-debug "Update list ~a data ~v" (eq-hash-code lb) data)
-       (send lb set (for/list [(c (obj-slots data))] (match-define (unstr t) c) t))
-       lbv)]
-    [89 ;; set selected text area
-     (primitive-action [(unffiv (list get-textarea _factory)) (and textv (unstr text))]
-       (define start (box 0))
-       (define end (box 0))
-       (send (get-textarea) get-position start end)
-       (define has-selection (not (= (unbox start) (unbox end))))
-       (if has-selection
-           (send (get-textarea) insert text (unbox start) (unbox end))
-           (begin (send (get-textarea) erase)
-                  (send (get-textarea) insert text)))
-       textv)]
-    [90 ;; new menu
-     (primitive-action [class (unstr title)]
-       (define pending-items '())
-       (define (queue-item i)
-         (set! pending-items (cons i pending-items)))
-       (define (add-menu-bar-to frame)
-         (define m (new menu% [parent frame] [label title]))
-         (for [(i (reverse pending-items))] (i m))
-         m)
-       (mkffiv class (list queue-item add-menu-bar-to)))]
-    [91 ;; new menu item
-     (primitive-action [(unffiv* menu (list queue-item _add-menu-bar-to)) (unstr title) action]
-       (define callback (block-callback vm action))
-       (queue-item (lambda (m)
-                     (new menu-item%
-                          [label title]
-                          [parent m]
-                          [callback (lambda args (queue-callback callback))])))
-       menu)]
-    [100 (primitive-action [class]
-           (mkffiv class (oneshot)))]
-    [101 (primitive-action [(unffiv o)]
-           (oneshot-ref o))]
-    [102 (primitive-action [(unffiv o) v]
-           (oneshot-set! o v)
-           v)]
-    [116 (primitive-action []
-           (let ((image-bytes (serialize-image vm)))
-             (display-to-file image-bytes (VM-image-filename vm) #:exists 'replace)))]
-    [117 (primitive-action [] (exit))]
-    [118 ;; "onWindow close b"
-     (primitive-action [(unffiv* wv window) action]
-       (define callback (block-callback vm action))
-       (send window set-close-handler (lambda (_frame) (queue-callback callback) (sleep 0.2)))
-       wv)]
+(define-primitive vm [116]
+  (let ((image-bytes (serialize-image vm)))
+    (display-to-file image-bytes (int-VM-image-filename vm) #:exists 'replace)))
 
-    ;;---------------------------------------------------------------------------
-    ;; END GUI
-    ;;---------------------------------------------------------------------------
-
-    [119 (primitive-action [] (inexact->exact (round (current-inexact-milliseconds))))]
-
-    [_ (error 'execute "Unimplemented primitive: ~a args: ~a"
-              primitive-number
-              (obj-slots args))]))
-
-(define (doIt vm task)
-  (define true-class (obj-class (VM-true vm))) ;; class True
-  (define name (slotAt true-class 0)) ;; "a known string", namely the name of class True
-  (define string-class (obj-class name)) ;; class String
-  (define doIt-method (search-class-method-dictionary string-class #"doIt"))
-  (when (not doIt-method)
-    (error 'doIt "Can't find doIt method via class True etc"))
-  (define source (mkbv string-class (string->bytes/utf-8 task)))
-  (define args (mkobj (VM-Array vm) source))
-  (define ctx (build-context vm (VM-nil vm) args doIt-method))
-  (execute vm ctx))
+;;===========================================================================
 
 (let* ((image-filename "SmallWorld/src/image")
-       (vm (call-with-input-file image-filename (lambda (fh) (read-image image-filename fh)))))
-  (printf "Sending 'SmallWorld startUp'...\n")
-  (thread-wait (thread (lambda ()
-                         (define result (doIt vm "SmallWorld startUp"))
-                         (log-vm-info "Final startUp result: ~a" result)
-                         (for [(a (current-command-line-arguments))]
-                           (log-vm-info "Filing in ~a" a)
-                           (doIt vm (format "(File openRead: '~a') fileIn" a)))
-                         (yield))))
-  (printf "... terminating.\n"))
-
-;;; Local Variables:
-;;; eval: (put 'primitive-action 'scheme-indent-function 1)
-;;; End:
+       (vm (call-with-input-file image-filename
+             (lambda (fh)
+               (read-image fh int-VM (list (make-weak-hasheq) image-filename))))))
+  (boot-image vm
+              (lambda (vm source)
+                (define args (mkobj (VM-Array vm) source))
+                (define doIt-method (search-class-method-dictionary (obj-class source) #"doIt"))
+                (when (not doIt-method) (error 'doIt "Can't find doIt method via class True etc"))
+                (execute vm (build-context vm (VM-nil vm) args doIt-method)))
+              (current-command-line-arguments)))