equal
deleted
inserted
replaced
31 (struct ffiv obj (value) |
31 (struct ffiv obj (value) |
32 #:methods gen:custom-write |
32 #:methods gen:custom-write |
33 [(define write-proc |
33 [(define write-proc |
34 (make-constructor-style-printer (lambda (o) (format "ffiv:~a" (obj-class-name o))) |
34 (make-constructor-style-printer (lambda (o) (format "ffiv:~a" (obj-class-name o))) |
35 (lambda (o) (list (ffiv-value o)))))]) |
35 (lambda (o) (list (ffiv-value o)))))]) |
|
36 |
|
37 (struct mic ([class #:mutable] [method #:mutable])) |
36 |
38 |
37 (define-match-expander unbv |
39 (define-match-expander unbv |
38 (syntax-rules () [(_ bytes-pat) (bv _ _ bytes-pat)])) |
40 (syntax-rules () [(_ bytes-pat) (bv _ _ bytes-pat)])) |
39 (define-match-expander unbv* |
41 (define-match-expander unbv* |
40 (syntax-rules () [(_ this-pat bytes-pat) (and this-pat (bv _ _ bytes-pat))])) |
42 (syntax-rules () [(_ this-pat bytes-pat) (and this-pat (bv _ _ bytes-pat))])) |
302 `(case-lambda [() ,(build-jit-context-exp ip stack)] |
304 `(case-lambda [() ,(build-jit-context-exp ip stack)] |
303 [(,result) ,(translate ip (cons result stack))])) |
305 [(,result) ,(translate ip (cons result stack))])) |
304 |
306 |
305 (define (gen-send class-exp selector-exp k-exp arg-exps) |
307 (define (gen-send class-exp selector-exp k-exp arg-exps) |
306 (define mic-index (next-mic!)) |
308 (define mic-index (next-mic!)) |
307 (define mc (mksym "mic~a-class" mic-index)) |
309 (define m (mksym "mic~a" mic-index)) |
308 (define mm (mksym "mic~a-method" mic-index)) |
310 `((lookup-message/jit vm ,m ,class-exp ,selector-exp) vm ,k-exp ,@arg-exps)) |
309 `((lookup-message/jit vm ,mc ,mm ,class-exp ,selector-exp) vm ,k-exp ,@arg-exps)) |
|
310 |
311 |
311 (define (translate ip stack) |
312 (define (translate ip stack) |
312 (define (next-byte!) |
313 (define (next-byte!) |
313 (begin0 (bytes-ref bytecode ip) |
314 (begin0 (bytes-ref bytecode ip) |
314 (set! ip (+ ip 1)))) |
315 (set! ip (+ ip 1)))) |
431 arg)])) |
432 arg)])) |
432 |
433 |
433 (define code |
434 (define code |
434 (let ((inner (jump-to-label 0 '()))) |
435 (let ((inner (jump-to-label 0 '()))) |
435 `(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(vector->list litnames)) |
436 `(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(vector->list litnames)) |
436 ,@(for/list [(i mic-count)] `(define ,(mksym "mic~a-class" i) (box NIL))) |
437 ,@(for/list [(i mic-count)] `(define ,(mksym "mic~a" i) (mic NIL NIL))) |
437 ,@(for/list [(i mic-count)] `(define ,(mksym "mic~a-method" i) (box NIL))) |
|
438 (lambda (vm k ,@(vector->list argnames)) |
438 (lambda (vm k ,@(vector->list argnames)) |
439 (let ((outer-k k) |
439 (let ((outer-k k) |
440 ,@(for/list [(t tmpnames)] `(,t NIL))) |
440 ,@(for/list [(t tmpnames)] `(,t NIL))) |
441 (letrec (,@(for/list [((ip label) (in-hash labels))] |
441 (letrec (,@(for/list [((ip label) (in-hash labels))] |
442 `(,(mksym "label~a" ip) |
442 `(,(mksym "label~a" ip) |
474 |
474 |
475 (define (store-registers! ctx ip stack-top) |
475 (define (store-registers! ctx ip stack-top) |
476 (slotAtPut ctx 4 ip) |
476 (slotAtPut ctx 4 ip) |
477 (slotAtPut ctx 5 stack-top)) |
477 (slotAtPut ctx 5 stack-top)) |
478 |
478 |
479 (define (lookup-message/jit vm mic-class mic-method class selector) |
479 (define (lookup-message/jit vm mic class selector) |
480 (define method (unbox mic-method)) |
480 (define method (mic-method mic)) |
481 (when (or (not (eq? (unbox mic-class) class)) |
481 (when (or (not (eq? (mic-class mic) class)) |
482 (not method)) |
482 (not method)) |
483 (set-box! mic-class class) |
483 (set-mic-class! mic class) |
484 (set! method (lookup-method/cache vm class (bv-bytes selector))) |
484 (set! method (lookup-method/cache vm class (bv-bytes selector))) |
485 (when (and method (not (procedure? method))) |
485 (when (and method (not (procedure? method))) |
486 (set! method (install-native-proc! vm class (bv-bytes selector) method))) |
486 (set! method (install-native-proc! vm class (bv-bytes selector) method))) |
487 (set-box! mic-method method)) |
487 (set-mic-method! mic method)) |
488 (or method |
488 (or method |
489 (lambda (vm ctx . args) |
489 (lambda (vm ctx . args) |
490 (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector)))) |
490 (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector)))) |
491 |
491 |
492 (define (send-dnu vm ctx arguments class selector) |
492 (define (send-dnu vm ctx arguments class selector) |