270 ,ip |
270 ,ip |
271 ,(length stack) |
271 ,(length stack) |
272 (vector ,@(vector->list tmpnames)) |
272 (vector ,@(vector->list tmpnames)) |
273 (vector ,@(reverse stack)))) |
273 (vector ,@(reverse stack)))) |
274 |
274 |
275 (define-syntax-rule (let@ [n n-exp n-code-exp] body-code-exp) |
275 (define-syntax let@ |
276 (let ((n n-exp)) |
276 (syntax-rules () |
277 `(let ((,n ,n-code-exp)) |
277 [(_ [n n-code-exp] body-code-exp) |
278 ,body-code-exp))) |
278 (let@ [n (gensym 'n) n-code-exp] body-code-exp)] |
|
279 [(_ [n n-exp n-code-exp] body-code-exp) |
|
280 (let ((n (gensym n-exp))) |
|
281 `(let ((,n ,n-code-exp)) |
|
282 ,body-code-exp))])) |
279 |
283 |
280 (define labels (make-hash)) |
284 (define labels (make-hash)) |
281 |
285 |
282 (define (jump-to-label ip stack) |
286 (define (jump-to-label ip stack) |
283 (when (not (hash-has-key? labels ip)) |
287 (when (not (hash-has-key? labels ip)) |
306 (values high low))) |
310 (values high low))) |
307 (define ip0 ip) |
311 (define ip0 ip) |
308 (define-values (opcode arg) (decode!)) |
312 (define-values (opcode arg) (decode!)) |
309 (log-vm/jit-debug " ~a: ~a ~a" ip0 opcode arg) |
313 (log-vm/jit-debug " ~a: ~a ~a" ip0 opcode arg) |
310 (match opcode |
314 (match opcode |
311 [1 (let@ [n (mksym "slot~a" arg) `(vector-ref (obj-slots self) ,arg)] |
315 [1 (let@ [n (mksym "slot~a_" arg) `(vector-ref (obj-slots self) ,arg)] |
312 (translate ip (cons n stack)))] |
316 (translate ip (cons n stack)))] |
313 [2 (translate ip (cons (vector-ref argnames arg) stack))] |
317 [2 (translate ip (cons (vector-ref argnames arg) stack))] |
314 [3 (let@ [n (gensym 'tmpcopy) (vector-ref tmpnames arg)] |
318 [3 (let@ [n (mksym "tmp~a_" arg) (vector-ref tmpnames arg)] |
315 (translate ip (cons n stack)))] |
319 (translate ip (cons n stack)))] |
316 [4 (translate ip (cons (vector-ref litnames arg) stack))] |
320 [4 (translate ip (cons (vector-ref litnames arg) stack))] |
317 [5 (match arg |
321 [5 (match arg |
318 [(or 0 1 2 3 4 5 6 7 8 9) (translate ip (cons arg stack))] |
322 [(or 0 1 2 3 4 5 6 7 8 9) (translate ip (cons arg stack))] |
319 [10 (translate ip (cons `NIL stack))] |
323 [10 (translate ip (cons `NIL stack))] |
352 ;; [(,result) ,(translate ip (cons result (cdr stack)))]) |
356 ;; [(,result) ,(translate ip (cons result (cdr stack)))]) |
353 ;; (obj ARRAY (list->vector ,args)) |
357 ;; (obj ARRAY (list->vector ,args)) |
354 ;; ,(vector-ref litnames arg)))] |
358 ;; ,(vector-ref litnames arg)))] |
355 |
359 |
356 [10 (match arg |
360 [10 (match arg |
357 [0 (let@ [n (gensym 'isNil) `(boolean->obj vm (eq? NIL ,(car stack)))] |
361 [0 (let@ [isNil `(boolean->obj vm (eq? NIL ,(car stack)))] |
358 (translate ip (cons n (cdr stack))))] |
362 (translate ip (cons isNil (cdr stack))))] |
359 [1 (let@ [n (gensym 'notNil) `(boolean->obj vm (not (eq? NIL ,(car stack))))] |
363 [1 (let@ [notNil `(boolean->obj vm (not (eq? NIL ,(car stack))))] |
360 (translate ip (cons n (cdr stack))))])] |
364 (translate ip (cons notNil (cdr stack))))])] |
361 [11 (match stack |
365 [11 (match stack |
362 [(list* j i stack) |
366 [(list* j i stack) |
363 (let@ [binop-k (gensym 'binop-k) |
367 (let@ [binop-k (let ((binop-result (gensym 'binop-result))) |
364 (let ((binop-result (gensym 'binop-result))) |
|
365 `(case-lambda |
368 `(case-lambda |
366 [() ,(build-jit-context-exp ip stack)] |
369 [() ,(build-jit-context-exp ip stack)] |
367 [(,binop-result) ,(translate ip (cons binop-result stack))]))] |
370 [(,binop-result) ,(translate ip (cons binop-result stack))]))] |
368 `(if (and (number? ,i) (number? ,j)) |
371 `(if (and (number? ,i) (number? ,j)) |
369 ,(match arg |
372 ,(match arg |
376 (mkbv NIL ,(match arg |
379 (mkbv NIL ,(match arg |
377 [0 #"<"] |
380 [0 #"<"] |
378 [1 #"<="] |
381 [1 #"<="] |
379 [2 #"+"])))))])] |
382 [2 #"+"])))))])] |
380 [12 (let ((target (next-byte!))) |
383 [12 (let ((target (next-byte!))) |
381 (let@ [block (gensym 'block) |
384 (let@ [block `(mkffiv BLOCK |
382 `(mkffiv BLOCK |
|
383 (lambda (_vm k . block-arguments) |
385 (lambda (_vm k . block-arguments) |
384 ,(let loop ((i arg)) |
386 ,(let loop ((i arg)) |
385 (if (>= i temp-count) |
387 (if (>= i temp-count) |
386 `(void) |
388 `(void) |
387 `(when (pair? block-arguments) |
389 `(when (pair? block-arguments) |
405 ;; immediately returning to the surrounding context!! |
407 ;; immediately returning to the surrounding context!! |
406 ,@(reverse (take stack argc)))] |
408 ,@(reverse (take stack argc)))] |
407 [(obj (== BLOCK) _) |
409 [(obj (== BLOCK) _) |
408 (k ((block->thunk vm ,block (list ,@(reverse (take stack argc))))))]))] |
410 (k ((block->thunk vm ,block (list ,@(reverse (take stack argc))))))]))] |
409 [34 'NIL] |
411 [34 'NIL] |
410 [35 (let@ [n (gensym 'ctx) (build-jit-context-exp ip stack)] |
412 [35 (let@ [ctxref (build-jit-context-exp ip stack)] |
411 (translate ip (cons n stack)))] |
413 (translate ip (cons ctxref stack)))] |
412 [36 (let@ [n (gensym 'arr) `(mkobj ARRAY ,@(reverse (take stack arg)))] |
414 [36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))] |
413 (translate ip (cons n (drop stack arg))))] |
415 (translate ip (cons arr (drop stack arg))))] |
414 [_ (let@ [v (gensym 'primresult) |
416 [_ (let@ [primresult (let ((generator (hash-ref *primitive-code-snippets* |
415 (let ((generator (hash-ref *primitive-code-snippets* |
417 primitive-number |
416 primitive-number |
418 (lambda () |
417 (lambda () |
419 (error 'compile-native-proc |
418 (error 'compile-native-proc |
420 "Unknown primitive: ~a" |
419 "Unknown primitive: ~a" |
421 primitive-number))))) |
420 primitive-number))))) |
422 (generator 'vm (reverse (take stack arg))))] |
421 (generator 'vm (reverse (take stack arg))))] |
423 (translate ip (cons primresult (drop stack arg))))])] |
422 (translate ip (cons v (drop stack arg))))])] |
424 [14 (let@ [clsvar `(slotAt (obj-class* vm self) ,(+ arg 5))] |
423 [14 (let@ [n (gensym 'clsvar) `(slotAt (obj-class* vm self) ,(+ arg 5))] |
425 (translate ip (cons clsvar stack)))] |
424 (translate ip (cons n stack)))] |
|
425 [15 (match arg |
426 [15 (match arg |
426 [1 `(k self)] |
427 [1 `(k self)] |
427 [2 `(k ,(car stack))] |
428 [2 `(k ,(car stack))] |
428 [3 `(outer-k ,(car stack))] |
429 [3 `(outer-k ,(car stack))] |
429 [5 (translate ip (cdr stack))] |
430 [5 (translate ip (cdr stack))] |