--- 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)))