--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/experiments/little-smalltalk/jit-SmallWorld-2015.rkt Sat Jul 14 23:35:48 2018 +0100
@@ -0,0 +1,1013 @@
+#lang racket/gui
+;; Loader for images (version 1 format) from Russell Allen's 2015
+;; variant of SmallWorld, a Tim Budd-authored Little Smalltalk
+;; descendant.
+
+(require racket/struct)
+(require racket/bytes)
+(require (only-in sha bytes->hex-string))
+(require "oneshot.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-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))))))
+
+ (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))
+
+(define (mkarray vm count [init (VM-nil vm)])
+ (obj (VM-Array vm) (make-vector count init)))
+
+(define (build-context vm previous-context args method)
+ (define temp-count (slotAt method 4))
+ (define max-stack (slotAt method 3))
+ (mkobj (VM-Context vm)
+ method
+ args
+ (mkarray vm temp-count)
+ (mkarray vm max-stack)
+ 0 ;; IP
+ 0 ;; stack top
+ previous-context))
+
+(define (build-jit-context vm previous-context args method ip stack-top temporaries stack)
+ (define max-stack (slotAt method 3))
+ (mkobj (VM-Context vm)
+ method
+ (obj (VM-Array vm) args)
+ (obj (VM-Array vm) temporaries)
+ (obj (VM-Array vm) (vector-append stack (make-vector (- max-stack (vector-length stack))
+ (VM-nil vm))))
+ ip
+ stack-top
+ previous-context))
+
+(define (clone-array a [start 0] [count (- (slotCount a) start)])
+ (define b (obj (obj-class a) (make-vector count)))
+ (for [(i (in-range count))]
+ (slotAtPut b i (slotAt a (+ i start))))
+ b)
+
+(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)]
+ [(char-alphabetic? (string-ref str 0)) 1]
+ [else 2])) ;; assume binary operator
+
+(define-namespace-anchor ns-anchor)
+(define ns (namespace-anchor->namespace ns-anchor))
+
+(define (compile-native-proc compile-time-vm method)
+ (define selector (slotAt method 0))
+ (define arity (selector-string-arity (bv->string selector)))
+ (define bytecode (bv-bytes (slotAt method 1)))
+ (define literals (slotAt method 2))
+ (define max-stack (slotAt method 3))
+ (define temp-count (slotAt method 4))
+ (define defining-class (slotAt method 5))
+ (define method-source (slotAt method 6))
+
+ (log-vm/jit-info
+ "Compiling ~v defined in ~v, arity ~a, literals ~a, bytecode ~a, text:\n----\n~a\n----"
+ (bv->string selector)
+ defining-class
+ arity
+ literals
+ (bytes->hex-string bytecode)
+ (bv->string method-source))
+
+ (define (mksym fmt . args) (string->symbol (apply format fmt args)))
+
+ (define litnames (for/vector [(i (slotCount literals))]
+ (define lit (slotAt literals i))
+ (if (bv? lit)
+ (mksym "lit~a-~a" i (bv->string lit))
+ (mksym "lit~a" i))))
+ (define tmpnames (for/vector [(i temp-count)] (mksym "tmp~a" i)))
+ (define argnames (for/vector [(i arity)] (if (zero? i) 'self (mksym "arg~a" (- i 1)))))
+
+ (define (build-jit-context-exp ip stack)
+ `(build-jit-context vm
+ (k)
+ (vector ,@(vector->list argnames))
+ method
+ ,ip
+ ,(length stack)
+ (vector ,@(vector->list tmpnames))
+ (vector ,@(reverse stack))))
+
+ (define-syntax-rule (let@ [n n-exp n-code-exp] body-code-exp)
+ (let ((n n-exp))
+ `(let ((,n ,n-code-exp))
+ ,body-code-exp)))
+
+ (define labels (make-hash))
+
+ (define (jump-to-label ip stack)
+ (when (not (hash-has-key? labels ip))
+ (hash-set! labels ip 'placeholder)
+ (define actual-label
+ (let ((newstack (for/list [(i (length stack))] (mksym "stack~a" i))))
+ `(lambda (k ,@newstack) ,(translate ip newstack))))
+ (hash-set! labels ip actual-label))
+ `(,(mksym "label~a" ip) k ,@stack))
+
+ (define (translate ip stack)
+ (define (next-byte!)
+ (begin0 (bytes-ref bytecode ip)
+ (set! ip (+ ip 1))))
+ (define (decode!)
+ (define byte (next-byte!))
+ (define low (bitwise-and byte #x0f))
+ (define high (bitwise-and (arithmetic-shift byte -4) #x0f))
+ (if (zero? high)
+ (values low (next-byte!))
+ (values high low)))
+ (define ip0 ip)
+ (define-values (opcode arg) (decode!))
+ (log-vm/jit-debug " ~a: ~a ~a" ip0 opcode arg)
+ (match opcode
+ [1 (let@ [n (mksym "slot~a" arg) `(vector-ref (obj-slots self) ,arg)]
+ (translate ip (cons n stack)))]
+ [2 (translate ip (cons (vector-ref argnames arg) stack))]
+ [3 (let@ [n (gensym 'tmpcopy) (vector-ref tmpnames arg)]
+ (translate ip (cons n stack)))]
+ [4 (translate ip (cons (vector-ref litnames arg) stack))]
+ [5 (match arg
+ [(or 0 1 2 3 4 5 6 7 8 9) (translate ip (cons arg stack))]
+ [10 (translate ip (cons `NIL stack))]
+ [11 (translate ip (cons `TRUE stack))]
+ [12 (translate ip (cons `FALSE stack))])]
+ [6 `(begin (slotAtPut self ,arg ,(car stack)) ,(translate ip stack))]
+ [7 `(begin (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)))]
+ [10 (match arg
+ [0 (let@ [n (gensym 'isNil) `(boolean->obj vm (eq? NIL ,(car stack)))]
+ (translate ip (cons n (cdr stack))))]
+ [1 (let@ [n (gensym 'notNil) `(boolean->obj vm (not (eq? NIL ,(car stack))))]
+ (translate ip (cons n (cdr stack))))])]
+ [11 (match stack
+ [(list* j i stack)
+ (let@ [binop-k (gensym 'binop-k)
+ (let ((binop-result (gensym 'binop-result)))
+ `(case-lambda
+ [() ,(build-jit-context-exp ip stack)]
+ [(,binop-result) ,(translate ip (cons binop-result stack))]))]
+ `(if (and (number? ,i) (number? ,j))
+ ,(match arg
+ [0 `(,binop-k (boolean->obj vm (< ,i ,j)))]
+ [1 `(,binop-k (boolean->obj vm (<= ,i ,j)))]
+ [2 `(,binop-k (+ ,i ,j))])
+ (send-message vm
+ ,binop-k
+ (mkobj ARRAY ,i ,j)
+ (mkbv NIL ,(match arg
+ [0 #"<"]
+ [1 #"<="]
+ [2 #"+"])))))])]
+ [12 (let ((target (next-byte!)))
+ (let@ [block (gensym 'block)
+ `(mkffiv BLOCK
+ (lambda (_vm k . block-arguments)
+ ,(let loop ((i arg))
+ (if (>= i temp-count)
+ `(void)
+ `(when (pair? block-arguments)
+ (set! ,(vector-ref tmpnames i) (car block-arguments))
+ (let ((block-arguments (cdr block-arguments)))
+ ,(loop (+ i 1))))))
+ ,(translate ip '())))]
+ (translate target (cons block stack))))]
+ [13 (define primitive-number (next-byte!))
+ (match primitive-number
+ [8 (let ((v (gensym 'blockresult))
+ (block (car stack))
+ (argc (- arg 1))
+ (stack (cdr stack)))
+ `(match ,block
+ [(unffiv block-proc)
+ (block-proc vm
+ ;; TODO vvv : use case-lambda to translate the context chain
+ k ;; not (lambda (,v) ,(translate ip (cons v (drop stack argc))))
+ ;; ^ reason being the image BUGGILY relies on primitive 8
+ ;; immediately returning to the surrounding context!!
+ ,@(reverse (take stack argc)))]))]
+ [34 'NIL]
+ [35 (let@ [n (gensym 'ctx) (build-jit-context-exp ip stack)]
+ (translate ip (cons n stack)))]
+ [_ (let@ [v (gensym 'primresult)
+ `(perform-primitive vm
+ ,primitive-number
+ (mkobj ARRAY ,@(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)))]
+ [15 (match arg
+ [1 `(resume-jit-context method k self)]
+ [2 `(resume-jit-context method k ,(car stack))]
+ [3 `(resume-jit-context method outer-k ,(car stack))]
+ [5 (translate ip (cdr stack))]
+ [6 (jump-to-label (next-byte!) stack)]
+ [7 (let ((target (next-byte!)))
+ (log-vm/jit-debug "if ~a true jump to ~a, else continue at ~a" (car stack) target ip)
+ `(if (eq? ,(car stack) TRUE)
+ ,(jump-to-label target (cdr stack))
+ ,(jump-to-label ip (cdr stack))))]
+ [8 (let ((target (next-byte!)))
+ (log-vm/jit-debug "if ~a false jump to ~a, else continue at ~a" (car stack) target ip)
+ `(if (eq? ,(car stack) FALSE)
+ ,(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)))]
+ [_ (error 'compile-native-proc "Unhandled do-special case ~v" arg)])]
+ [_ (error 'compile-native-proc "Method ~v - unhandled opcode ~v, arg ~v"
+ selector
+ opcode
+ arg)]))
+
+ (define code
+ (let ((inner (jump-to-label 0 '())))
+ `(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(vector->list litnames))
+ (lambda (vm k ,@(vector->list argnames))
+ (let ((outer-k k)
+ ,@(for/list [(t tmpnames)] `(,t NIL)))
+ (letrec (,@(for/list [((ip label) (in-hash labels))]
+ `(,(mksym "label~a" ip)
+ ,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 (install-native-proc! vm class selector native-proc)
+ (define name-bytes (bv-bytes selector))
+ (define class-cache (hash-ref! (VM-cache vm) class make-weak-hash))
+ (hash-set! class-cache name-bytes native-proc)
+ native-proc)
+
+(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))
+ (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))))))
+
+(define (store-registers! ctx ip stack-top)
+ (slotAtPut ctx 4 ip)
+ (slotAtPut ctx 5 stack-top))
+
+(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)))]))
+
+(define (apply-method class selector method vm ctx arglist)
+ (define native-proc
+ (if (procedure? method)
+ method
+ (install-native-proc! vm class selector (compile-native-proc vm method))))
+ (apply native-proc
+ vm
+ (if (procedure? ctx)
+ ctx
+ (case-lambda
+ [() ctx]
+ [(result) (resume-context vm ctx result)]))
+ arglist))
+
+(define (obj-class* vm o)
+ (if (number? o)
+ (VM-Integer vm)
+ (obj-class o)))
+
+(define (send-message vm ctx arguments selector)
+ (log-vm-debug "sending: ~a ~a" selector arguments)
+ (send-message* vm ctx arguments (obj-class* vm (slotAt arguments 0)) selector))
+
+(define (block-callback vm block)
+ ;; Runs block in a new thread
+ (lambda args
+ (match block
+ [(unffiv block-proc)
+ (apply block-proc vm (case-lambda [() (VM-nil vm)] [(result) (void)]) 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-jit-context method k result)
+ (log-vm-debug "resuming (jit, from method ~v): ~a"
+ (bv->string (slotAt method 0))
+ result)
+ (k result))
+
+(define (resume-context vm ctx result)
+ (if (eq? (VM-nil vm) ctx)
+ result
+ (let ((stack-top (slotAt ctx 5)))
+ (slotAtPut (slotAt ctx 3) stack-top result)
+ (slotAtPut ctx 5 (+ stack-top 1))
+ (log-vm-debug "resuming: ~a" result)
+ (execute vm ctx))))
+
+(define (execute vm ctx)
+ (define method (slotAt ctx 0))
+ (define arguments (slotAt ctx 1))
+ (define temporaries (slotAt ctx 2))
+ (define stack (slotAt ctx 3))
+ (define ip (slotAt ctx 4))
+ (define stack-top (slotAt ctx 5))
+ (define previous-ctx (slotAt ctx 6))
+
+ (define receiver (slotAt arguments 0))
+
+ (define bytecode (bv-bytes (slotAt method 1)))
+ (define literals (slotAt method 2))
+
+ (log-vm-info "Interpreter bytecode, ctx slotcount ~a, method name ~a: ~a"
+ (slotCount ctx)
+ (bv->string (slotAt method 0))
+ (bytes->hex-string bytecode))
+
+ (define (push! v)
+ (slotAtPut stack stack-top v)
+ (set! stack-top (+ stack-top 1)))
+ (define (pop!)
+ (set! stack-top (- stack-top 1))
+ (slotAt stack stack-top))
+ (define (peek)
+ (slotAt stack (- stack-top 1)))
+
+ (define (pop-multiple! count)
+ (set! stack-top (- stack-top count))
+ (clone-array stack stack-top count))
+
+ (define (continue-from next-ip)
+ (set! ip next-ip)
+ (interpret))
+
+ (define (push-and-go next-ip v)
+ (push! v)
+ (continue-from next-ip))
+
+ (define (push-and-continue v)
+ (push! v)
+ (interpret))
+
+ (define (next-byte!)
+ (begin0 (bytes-ref bytecode ip)
+ (set! ip (+ ip 1))))
+
+ (define (decode!)
+ (define byte (next-byte!))
+ (define low (bitwise-and byte #x0f))
+ (define high (bitwise-and (arithmetic-shift byte -4) #x0f))
+ (if (zero? high)
+ (values low (next-byte!))
+ (values high low)))
+
+ (define (interpret)
+ (define-values (high low) (decode!))
+ (log-vm-debug "> ~a ~a ~a" high low (vector-copy (obj-slots stack) 0 stack-top))
+ (match high
+ [1 (push-and-continue (slotAt receiver low))] ;; PushInstance
+ [2 (push-and-continue (slotAt arguments low))] ;; PushArgument
+ [3 (push-and-continue (slotAt temporaries low))] ;; PushTemporary
+ [4 (push-and-continue (slotAt literals low))] ;; PushLiteral
+ [5 (match low
+ [(or 0 1 2 3 4 5 6 7 8 9) (push-and-continue low)]
+ [10 (push-and-continue (VM-nil vm))]
+ [11 (push-and-continue (VM-true vm))]
+ [12 (push-and-continue (VM-false vm))])]
+ [6 (slotAtPut receiver low (peek)) (interpret)] ;; AssignInstance
+ [7 (slotAtPut temporaries low (peek)) (interpret)] ;; AssignTemporary
+ [8 (push-and-continue (pop-multiple! low))] ;; MarkArguments
+ [9 ;; SendMessage
+ (define new-arguments (pop!))
+ (store-registers! ctx ip stack-top)
+ (send-message vm ctx new-arguments (slotAt literals low))]
+
+ [10 (match low
+ [0 (push-and-continue (boolean->obj vm (eq? (VM-nil vm) (pop!))))] ;; isNil
+ [1 (push-and-continue (boolean->obj vm (not (eq? (VM-nil vm) (pop!)))))])] ;; notNil
+
+ [11 ;; SendBinary
+ (define j (pop!))
+ (define i (pop!))
+ (if (and (number? i) (number? j))
+ (match low
+ [0 (push-and-continue (boolean->obj vm (< i j)))]
+ [1 (push-and-continue (boolean->obj vm (<= i j)))]
+ [2 (push-and-continue (+ i j))]) ;; TODO: overflow to bignum arithmetic
+ (let ((new-arguments (mkobj (VM-Array vm) i j))
+ (selector (match low
+ [0 (mkbv (VM-nil vm) #"<")]
+ [1 (mkbv (VM-nil vm) #"<=")]
+ [2 (mkbv (VM-nil vm) #"+")])))
+ (store-registers! ctx ip stack-top)
+ (send-message vm ctx new-arguments selector)))]
+
+ [12 ;; PushBlock
+ (define target (next-byte!))
+ (log-vm-debug "pushblock; temporaries = ~a" temporaries)
+ (push-and-go target
+ (mkobj (VM-Block vm) method arguments temporaries stack ip 0 previous-ctx low ctx ip))]
+
+ [13 ;; Primitive; low = arg count; next byte = primitive number
+ (define primitive-number (next-byte!))
+ (log-vm-debug "primitive ~a (arg count = ~a)" primitive-number low)
+ (match primitive-number
+ [8 ;; block invocation
+ (define block (pop!))
+ (define argument-location (slotAt block 7))
+ (define argument-count (- low 1)) ;; one of the primitive args is the block itself
+ (for [(i argument-count)]
+ (slotAtPut (slotAt block 2)
+ (+ argument-location i)
+ (slotAt stack (+ (- stack-top argument-count) i))))
+ (set! stack-top (- stack-top argument-count))
+ (store-registers! ctx ip stack-top)
+ (execute vm (mkobj (VM-Context vm)
+ (slotAt block 0)
+ (slotAt block 1)
+ (slotAt block 2)
+ (mkarray vm (slotCount (slotAt block 3))) ;; new stack (!)
+ (slotAt block 9) ;; starting IP
+ 0 ;; stack top
+ (slotAt ctx 6) ;; previous context
+ (slotAt block 7)
+ (slotAt block 8)
+ (slotAt block 9)))]
+ [34 (VM-nil vm)] ;; "thread kill"
+ [35 (push-and-continue ctx)]
+
+ [_ (define args (pop-multiple! low))
+ (push-and-continue (perform-primitive vm primitive-number args))])]
+
+ [14 (push-and-continue (slotAt (obj-class* vm receiver) (+ low 5)))] ;; PushClassVariable
+ [15 ;; Do Special
+ (match low
+ [1 (resume-context vm previous-ctx receiver)]
+ [2 (resume-context vm previous-ctx (pop!))]
+ [3 (resume-context vm (slotAt (slotAt ctx 8) 6) (pop!))]
+ [4 (push-and-continue (peek))]
+ [5 (pop!) (interpret)]
+ [6 (continue-from (next-byte!))]
+ [7 ;; branch if true
+ (define target (next-byte!))
+ (if (eq? (pop!) (VM-true vm))
+ (continue-from target)
+ (interpret))]
+ [8 ;; branch if false
+ (define target (next-byte!))
+ (if (eq? (pop!) (VM-false vm))
+ (continue-from target)
+ (interpret))]
+ [11 ;; send to super
+ (define selector (slotAt literals (next-byte!)))
+ (define new-arguments (pop!))
+ (define defining-class (slotAt method 5)) ;; method's defining class
+ (define super (slotAt defining-class 1)) ;; defining class's superclass
+ (store-registers! ctx ip stack-top)
+ (send-message* vm ctx new-arguments super selector)])]))
+
+ (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
+ ;;---------------------------------------------------------------------------
+
+ [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)]
+
+ ;;---------------------------------------------------------------------------
+ ;; END GUI
+ ;;---------------------------------------------------------------------------
+
+ [119 (primitive-action [] (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
+ (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))
+ (send-message vm (VM-nil vm) args (mkbv (VM-nil vm) #"doIt")))
+
+(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: