365 (define receiver-class (obj-class* vm receiver)) |
365 (define receiver-class (obj-class* vm receiver)) |
366 (define next-ctx (slotAt ctx 6)) |
366 (define next-ctx (slotAt ctx 6)) |
367 (log-vm/jit/recompile-info " ~a >> ~a" |
367 (log-vm/jit/recompile-info " ~a >> ~a" |
368 (bv->string (slotAt receiver-class 0)) |
368 (bv->string (slotAt receiver-class 0)) |
369 (bv->string selector)) |
369 (bv->string selector)) |
370 (define compiled-method (lookup-method/cache vm receiver-class (bv-bytes selector))) |
370 (define cached-method (lookup-method/cache vm receiver-class (bv-bytes selector))) |
|
371 (define compiled-method (unwrap-cached-method vm cached-method)) |
371 (when compiled-method |
372 (when compiled-method |
372 (match-define (compiled-method-info bytecode-method pics) (compiled-method)) |
373 (match-define (compiled-method-info bytecode-method pics) (compiled-method)) |
373 (log-vm/jit/recompile-info " has ~a bytes of bytecode" |
374 (log-vm/jit/recompile-info " has ~a bytes of bytecode" |
374 (bytes-length (bv-bytes (slotAt bytecode-method 1)))) |
375 (bytes-length (bv-bytes (slotAt bytecode-method 1)))) |
375 (for [(pic pics)] |
376 (for [(pic pics)] |
416 (let ((outer-k k) |
417 (let ((outer-k k) |
417 (temporaries ,(gen-fresh-temps method))) |
418 (temporaries ,(gen-fresh-temps method))) |
418 ,(gen-label-definitions c body-code))]))) |
419 ,(gen-label-definitions c body-code))]))) |
419 (finish-compilation c compile-time-vm inner-code)) |
420 (finish-compilation c compile-time-vm inner-code)) |
420 |
421 |
|
422 (struct cached-method (class name-bytes [bytecode-method #:mutable] [proc #:mutable])) |
|
423 |
|
424 (define (unwrap-cached-method vm cm) |
|
425 (or (cached-method-proc cm) |
|
426 (match cm |
|
427 [(cached-method class name-bytes _bcm _proc) |
|
428 (define bcm (lookup-method vm class name-bytes)) |
|
429 (define proc (and bcm (compile-method-proc vm class bcm))) |
|
430 (set-cached-method-bytecode-method! cm bcm) |
|
431 (set-cached-method-proc! cm proc) |
|
432 proc]))) |
|
433 |
421 (define (lookup-method/cache vm class name-bytes) |
434 (define (lookup-method/cache vm class name-bytes) |
422 (define class-cache (hash-ref! (jit-VM-cache vm) class make-weak-hash)) |
435 (define class-cache (hash-ref! (jit-VM-cache vm) class make-weak-hash)) |
423 (hash-ref! class-cache |
436 (hash-ref! class-cache |
424 name-bytes |
437 name-bytes |
425 (lambda () |
438 (lambda () (cached-method class name-bytes #f #f)))) |
426 (define m (lookup-method vm class name-bytes)) |
|
427 (and m (compile-method-proc vm class m))))) |
|
428 |
439 |
429 (define (lookup-message/jit vm pic class selector) |
440 (define (lookup-message/jit vm pic class selector) |
430 (define reserved 2) |
441 (define reserved 2) |
431 (define (@ i o) (vector-ref pic (+ reserved o (* i 3)))) |
442 (define (@ i o) (vector-ref pic (+ reserved o (* i 3)))) |
432 (define (@! i o v) (vector-set! pic (+ reserved o (* i 3)) v)) |
443 (define (@! i o v) (vector-set! pic (+ reserved o (* i 3)) v)) |
437 (@ slot-index 1)) |
448 (@ slot-index 1)) |
438 (let* ((next-slot-index (+ slot-index 1)) |
449 (let* ((next-slot-index (+ slot-index 1)) |
439 (more-slots-to-check? (and this-class (< next-slot-index pic-entry-count)))) |
450 (more-slots-to-check? (and this-class (< next-slot-index pic-entry-count)))) |
440 (if more-slots-to-check? |
451 (if more-slots-to-check? |
441 (search-pic next-slot-index) |
452 (search-pic next-slot-index) |
442 (let ((method (lookup-method/cache vm class (bv-bytes selector)))) |
453 (let ((method |
|
454 (unwrap-cached-method vm (lookup-method/cache vm class (bv-bytes selector))))) |
443 (if (not method) |
455 (if (not method) |
444 (lambda (vm ctx . args) |
456 (lambda (vm ctx . args) |
445 (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector)) |
457 (send-dnu vm ctx (obj (VM-Array vm) (list->vector args)) class selector)) |
446 (let ((slot-empty? (not this-class))) |
458 (let ((slot-empty? (not this-class))) |
447 (when slot-empty? |
459 (when slot-empty? |
450 (@! slot-index 2 1)) |
462 (@! slot-index 2 1)) |
451 method)))))))) |
463 method)))))))) |
452 |
464 |
453 (define (send-dnu vm ctx arguments class selector) |
465 (define (send-dnu vm ctx arguments class selector) |
454 (define dnu-name-bytes #"doesNotUnderstand:") |
466 (define dnu-name-bytes #"doesNotUnderstand:") |
455 (match (lookup-method/cache vm class dnu-name-bytes) |
467 (match (unwrap-cached-method vm (lookup-method/cache vm class dnu-name-bytes)) |
456 [#f (error 'send-message* "Unhandled selector ~a at class ~a" selector class)] |
468 [#f (error 'send-message* "Unhandled selector ~a at class ~a" selector class)] |
457 [dnu-method |
469 [dnu-method |
458 (log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector) |
470 (log-vm-warning "DNU -- arguments ~a class ~a selector ~a" arguments class selector) |
459 (dnu-method vm ctx (slotAt arguments 0) (mkobj (VM-Array vm) selector arguments))])) |
471 (dnu-method vm ctx (slotAt arguments 0) (mkobj (VM-Array vm) selector arguments))])) |
460 |
472 |
491 (vm (call-with-input-file image-filename |
503 (vm (call-with-input-file image-filename |
492 (lambda (fh) |
504 (lambda (fh) |
493 (read-image fh jit-VM (list (make-weak-hasheq) image-filename)))))) |
505 (read-image fh jit-VM (list (make-weak-hasheq) image-filename)))))) |
494 (boot-image vm |
506 (boot-image vm |
495 (lambda (vm source) |
507 (lambda (vm source) |
496 ((lookup-method/cache vm (obj-class source) #"doIt") vm (outermost-k vm) source)) |
508 (define compiled-method |
|
509 (unwrap-cached-method vm (lookup-method/cache vm (obj-class source) #"doIt"))) |
|
510 (compiled-method vm (outermost-k vm) source)) |
497 (current-command-line-arguments))) |
511 (current-command-line-arguments))) |