Proper direct sends (and MICs); inline primitive definitions
authorTony Garnock-Jones <tonygarnockjones@gmail.com>
Sun, 15 Jul 2018 01:32:17 +0100
changeset 379 e5e063ac93ef
parent 378 2a35e7fcba59
child 380 b3c00fbcea0a
Proper direct sends (and MICs); inline primitive definitions
experiments/little-smalltalk/jit-SmallWorld-2015.rkt
--- a/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Sun Jul 15 01:30:37 2018 +0100
+++ b/experiments/little-smalltalk/jit-SmallWorld-2015.rkt	Sun Jul 15 01:32:17 2018 +0100
@@ -288,6 +288,11 @@
       (hash-set! labels ip actual-label))
     `(,(mksym "label~a" ip) k ,@stack))
 
+  (define mic-count 0)
+  (define (next-mic!)
+    (begin0 mic-count
+      (set! mic-count (+ mic-count 1))))
+
   (define (translate ip stack)
     (define (next-byte!)
       (begin0 (bytes-ref bytecode ip)
@@ -316,17 +321,38 @@
            [12 (translate ip (cons `FALSE stack))])]
       [6 `(begin (slotAtPut self ,arg ,(car stack)) ,(translate ip stack))]
       [7 `(begin (set! ,(vector-ref tmpnames arg) ,(car stack)) ,(translate ip stack))]
-      [8 (let@ [n (gensym 'args) `(list ,@(reverse (take stack arg)))]
-               (translate ip (cons n (drop stack arg))))]
-      [9 (let ((args (car stack))
-               (result (gensym 'result)))
-           (log-vm/jit-debug "send of ~a" (slotAt literals arg))
-           `(send-message vm
-                          (case-lambda
-                            [() ,(build-jit-context-exp ip (cdr stack))]
-                            [(,result) ,(translate ip (cons result (cdr stack)))])
-                          (obj ARRAY (list->vector ,args))
-                          ,(vector-ref litnames arg)))]
+      [8 (let* ((arg-count arg)
+                (args (reverse (take stack arg-count)))
+                (stack (drop stack arg-count))
+                (mic-index (next-mic!))
+                (result (gensym 'result)))
+           (define-values (selector-literal-index class-exp)
+             (match/values (decode!)
+               [(9 selector-literal-index)
+                (values selector-literal-index `(obj-class* vm ,(car args)))]
+               [(15 11)
+                (values (next-byte!) `super)]))
+           `((lookup-message/jit vm
+                                 ,(mksym "mic~a-class" mic-index)
+                                 ,(mksym "mic~a-method" mic-index)
+                                 ,class-exp
+                                 ,(vector-ref litnames selector-literal-index))
+             vm
+             (case-lambda
+               [() ,(build-jit-context-exp ip stack)]
+               [(,result) ,(translate ip (cons result stack))])
+             ,@args))]
+
+      ;; [9 (let ((args (car stack))
+      ;;          (result (gensym 'result)))
+      ;;      (log-vm/jit-debug "send of ~a" (slotAt literals arg))
+      ;;      `(send-message vm
+      ;;                     (case-lambda
+      ;;                       [() ,(build-jit-context-exp ip (cdr stack))]
+      ;;                       [(,result) ,(translate ip (cons result (cdr stack)))])
+      ;;                     (obj ARRAY (list->vector ,args))
+      ;;                     ,(vector-ref litnames arg)))]
+
       [10 (match arg
             [0 (let@ [n (gensym 'isNil) `(boolean->obj vm (eq? NIL ,(car stack)))]
                      (translate ip (cons n (cdr stack))))]
@@ -383,10 +409,16 @@
             [34 'NIL]
             [35 (let@ [n (gensym 'ctx) (build-jit-context-exp ip stack)]
                       (translate ip (cons n stack)))]
+            [36 (let@ [n (gensym 'arr) `(mkobj ARRAY ,@(reverse (take stack arg)))]
+                      (translate ip (cons n (drop stack arg))))]
             [_ (let@ [v (gensym 'primresult)
-                        `(perform-primitive vm
-                                            ,primitive-number
-                                            (mkobj ARRAY ,@(reverse (take stack arg))))]
+                        (let ((generator (hash-ref *primitive-code-snippets*
+                                                   primitive-number
+                                                   (lambda ()
+                                                     (error 'compile-native-proc
+                                                            "Unknown primitive: ~a"
+                                                            primitive-number)))))
+                          (generator 'vm (reverse (take stack arg))))]
                      (translate ip (cons v (drop stack arg))))])]
       [14 (let@ [n (gensym 'clsvar) `(slotAt (obj-class* vm self) ,(+ arg 5))]
                 (translate ip (cons n stack)))]
@@ -406,16 +438,16 @@
                  `(if (eq? ,(car stack) FALSE)
                       ,(jump-to-label target (cdr stack))
                       ,(jump-to-label ip (cdr stack))))]
-            [11 (let ((args (car stack))
-                      (result (gensym 'result))
-                      (selector-literal (next-byte!)))
-                  `(send-message* vm
-                                  (case-lambda
-                                    [() ,(build-jit-context-exp ip (cdr stack))]
-                                    [(,result) ,(translate ip (cons result (cdr stack)))])
-                                  (obj ARRAY (list->vector ,args))
-                                  super
-                                  ,(vector-ref litnames selector-literal)))]
+            ;; [11 (let ((args (car stack))
+            ;;           (result (gensym 'result))
+            ;;           (selector-literal (next-byte!)))
+            ;;       `(send-message* vm
+            ;;                       (case-lambda
+            ;;                         [() ,(build-jit-context-exp ip (cdr stack))]
+            ;;                         [(,result) ,(translate ip (cons result (cdr stack)))])
+            ;;                       (obj ARRAY (list->vector ,args))
+            ;;                       super
+            ;;                       ,(vector-ref litnames selector-literal)))]
             [_ (error 'compile-native-proc "Unhandled do-special case ~v" arg)])]
       [_ (error 'compile-native-proc "Method ~v - unhandled opcode ~v, arg ~v"
                 selector
@@ -425,6 +457,8 @@
   (define code
     (let ((inner (jump-to-label 0 '())))
       `(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(vector->list litnames))
+         ,@(for/list [(i mic-count)] `(define ,(mksym "mic~a-class" i) (box NIL)))
+         ,@(for/list [(i mic-count)] `(define ,(mksym "mic~a-method" i) (box NIL)))
          (lambda (vm k ,@(vector->list argnames))
            (let ((outer-k k)
                  ,@(for/list [(t tmpnames)] `(,t NIL)))
@@ -433,15 +467,18 @@
                             ,label)))
                ,inner))))))
   (log-vm/jit-info "Resulting code:\n~a" (pretty-format code))
-  (apply (eval code ns)
-         method
-         (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 final-proc
+    (apply (eval code ns)
+           method
+           (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)
 
 (define (install-native-proc! vm class selector native-proc)
   (define name-bytes (bv-bytes selector))
@@ -465,31 +502,62 @@
   (slotAtPut ctx 4 ip)
   (slotAtPut ctx 5 stack-top))
 
+;; (define (lookup-message/jit vm mic-class mic-method class selector)
+;;   (when (not (eq? (unbox mic-class) class))
+;;     (set-box! mic-class class)
+;;     (set-box! mic-method #f))
+;;   (when (not (unbox mic-method))
+;;     (set-box! mic-method (lookup-method/cache vm class selector))
+;;     (when (not (procedure? (unbox mic-method)))
+;;       (set-box! mic-method (install-native-proc! vm
+;;                                                  class
+;;                                                  selector
+;;                                                  (compile-native-proc vm (unbox mic-method))))))
+;;   (or (unbox mic-method)
+;;       (lambda (vm ctx . args)
+;;         (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector))))
+
+(define (lookup-message/jit vm mic-class mic-method class selector)
+  (define method (unbox mic-method))
+  (when (or (not (eq? (unbox mic-class) class))
+            (not method))
+    (set-box! mic-class class)
+    (set! method (lookup-method/cache vm class selector))
+    (when (and method (not (procedure? method)))
+      (set! method (install-native-proc! vm
+                                         class
+                                         selector
+                                         (compile-native-proc vm method))))
+    (set-box! mic-method method))
+  (or method
+      (lambda (vm ctx . args)
+        (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector))))
+
+(define (send-dnu vm ctx arguments class selector)
+  (define dnu-selector (mkbv (obj-class selector) #"doesNotUnderstand:"))
+  (match (lookup-method/cache vm class dnu-selector)
+    [#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)
+     (apply-method class
+                   dnu-selector
+                   dnu-method
+                   vm
+                   ctx
+                   (list (slotAt arguments 0)
+                         (mkobj (VM-Array vm)
+                                selector
+                                (clone-array arguments))))]))
+
 (define (send-message* vm ctx arguments class selector)
   (match (lookup-method/cache vm class selector)
-    [#f
-     (define dnu-selector (mkbv (obj-class selector) #"doesNotUnderstand:"))
-     (match (lookup-method/cache vm class dnu-selector)
-       [#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)
-        (apply-method class
-                      dnu-selector
-                      dnu-method
-                      vm
-                      ctx
-                      (list (slotAt arguments 0)
-                            (mkobj (VM-Array vm)
-                                   selector
-                                   (clone-array arguments))))])]
-    [new-method
-     (apply-method class
-                   selector
-                   new-method
-                   vm
-                   ctx
-                   (vector->list (obj-slots arguments)))]))
+    [#f (send-dnu vm ctx arguments class selector)]
+    [new-method (apply-method class
+                              selector
+                              new-method
+                              vm
+                              ctx
+                              (vector->list (obj-slots arguments)))]))
 
 (define (apply-method class selector method vm ctx arglist)
   (define native-proc
@@ -685,6 +753,7 @@
                              (slotAt block 9)))]
          [34 (VM-nil vm)] ;; "thread kill"
          [35 (push-and-continue ctx)]
+         [36 (push-and-continue (pop-multiple! low))] ;; "fast array creation"
 
          [_ (define args (pop-multiple! low))
             (push-and-continue (perform-primitive vm primitive-number args))])]
@@ -718,277 +787,269 @@
 
   (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 ...)]))
+(define *primitive-handlers* (make-hash))
+(define *primitive-code-snippets* (make-hash))
 
-  (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))))]
+(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 ...)])))))
 
-    [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
+(define (perform-primitive vm primitive-number args)
+  ((hash-ref *primitive-handlers*
+             primitive-number
+             (lambda () (error 'perform-primitive "Unimplemented primitive: ~a args: ~a"
+                               primitive-number
+                               (obj-slots args))))
+   vm args))
 
-    [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]))]
+(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"
+  (execute vm inner-ctx))
+(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)))
 
-    [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"
+(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]))
 
-    [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)]))]
+(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))))
 
-    ;;---------------------------------------------------------------------------
-    ;; GUI
-    ;;---------------------------------------------------------------------------
+(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
+;;---------------------------------------------------------------------------
 
-    [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))] (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)))]
-    [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))] (bv->string c)))
-       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 [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] (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
-    ;;---------------------------------------------------------------------------
+;;---------------------------------------------------------------------------
+;; END GUI
+;;---------------------------------------------------------------------------
 
-    [119 (primitive-action [] (inexact->exact (round (current-inexact-milliseconds))))]
+(define-primitive vm [119] (inexact->exact (round (current-inexact-milliseconds))))
 
-    [_ (error 'perform-primitive "Unimplemented primitive: ~a args: ~a"
-              primitive-number
-              (obj-slots args))]))
+;;===========================================================================
 
 (define (doIt vm task)
   (define true-class (obj-class (VM-true vm))) ;; class True