diff options
-rw-r--r-- | libguile/jit.c | 31 | ||||
-rw-r--r-- | libguile/vm-engine.c | 171 | ||||
-rw-r--r-- | libguile/vm.c | 9 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 12 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 3 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 27 |
6 files changed, 104 insertions, 149 deletions
diff --git a/libguile/jit.c b/libguile/jit.c index 3cb3ddd26..04e28101b 100644 --- a/libguile/jit.c +++ b/libguile/jit.c @@ -61,32 +61,32 @@ compile_call_label (scm_jit_state *j, uint32_t a, uint32_t b, int32_t offset) } static void -compile_tail_call (scm_jit_state *j, uint32_t a) +compile_tail_call (scm_jit_state *j) { } static void -compile_tail_call_label (scm_jit_state *j, uint32_t a, int32_t offset) +compile_tail_call_label (scm_jit_state *j, int32_t offset) { } static void -compile_tail_call_shuffle (scm_jit_state *j, uint32_t a) +compile_receive (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t b) { } static void -compile_receive (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t b) +compile_receive_values (scm_jit_state *j, uint32_t a, uint8_t b, uint32_t c) { } static void -compile_receive_values (scm_jit_state *j, uint32_t a, uint8_t b, uint32_t c) +compile_shuffle_down (scm_jit_state *j, uint16_t from, uint16_t to) { } static void -compile_return_values (scm_jit_state *j, uint32_t a) +compile_return_values (scm_jit_state *j) { } @@ -111,11 +111,6 @@ compile_compose_continuation (scm_jit_state *j, uint32_t a) } static void -compile_tail_apply (scm_jit_state *j) -{ -} - -static void compile_call_cc (scm_jit_state *j) { } @@ -191,6 +186,11 @@ compile_assert_nargs_ee_locals (scm_jit_state *j, uint16_t a, uint16_t b) } static void +compile_expand_apply_argument (scm_jit_state *j) +{ +} + +static void compile_bind_kwargs (scm_jit_state *j, uint32_t a, uint8_t b, uint32_t c, uint32_t d, int32_t offset) { } @@ -917,6 +917,8 @@ compile_f64_set (scm_jit_state *j, uint8_t a, uint8_t b, uint8_t c) COMPILE_X8_C12_C12 (j, comp) #define COMPILE_X8_S12_S12(j, comp) \ COMPILE_X8_C12_C12 (j, comp) +#define COMPILE_X8_F12_F12(j, comp) \ + COMPILE_X8_C12_C12 (j, comp) #define COMPILE_X8_S12_Z12(j, comp) \ { \ @@ -953,6 +955,13 @@ compile_f64_set (scm_jit_state *j, uint8_t a, uint8_t b, uint8_t c) j->ip += 2; \ } +#define COMPILE_X32__L32(j, comp) \ + { \ + int32_t a = j->ip[1]; \ + comp (j, a); \ + j->ip += 1; \ + } + #define COMPILE_X8_C24__L32(j, comp) \ { \ uint32_t a; \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 341a006fd..383b4f5df 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -428,20 +428,14 @@ VM_NAME (scm_thread *thread) NEXT (0); } - /* tail-call nlocals:24 + /* tail-call _:24 * - * Tail-call a procedure. Requires that the procedure and all of the - * arguments have already been shuffled into position. Will reset the - * frame to NLOCALS. + * Tail-call the procedure in slot 0 with the arguments in the current + * stack frame. Requires that the procedure and all of the arguments + * have already been shuffled into position. */ - VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (X8_C24)) + VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (X32)) { - uint32_t nlocals; - - UNPACK_24 (op, nlocals); - - RESET_FRAME (nlocals); - if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) ip = SCM_PROGRAM_CODE (FP_REF (0)); else @@ -456,21 +450,17 @@ VM_NAME (scm_thread *thread) NEXT (0); } - /* tail-call-label nlocals:24 label:32 + /* tail-call-label _:24 label:32 * * Tail-call a known procedure. As call is to call-label, tail-call * is to tail-call-label. */ - VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (X8_C24, L32)) + VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (X32, L32)) { - uint32_t nlocals; int32_t label; - UNPACK_24 (op, nlocals); label = ip[1]; - RESET_FRAME (nlocals); - ip += label; APPLY_HOOK (); @@ -478,39 +468,10 @@ VM_NAME (scm_thread *thread) NEXT (0); } - /* tail-call/shuffle from:24 - * - * Tail-call a procedure. The procedure should already be set to slot - * 0. The rest of the args are taken from the frame, starting at - * FROM, shuffled down to start at slot 0. This is part of the - * implementation of the call-with-values builtin. - */ - VM_DEFINE_OP (5, tail_call_shuffle, "tail-call/shuffle", OP1 (X8_F24)) + VM_DEFINE_OP (5, unused_5, NULL, NOP) { - uint32_t n, from, nlocals; - - UNPACK_24 (op, from); - - VM_ASSERT (from > 0, abort ()); - nlocals = FRAME_LOCALS_COUNT (); - - for (n = 0; from + n < nlocals; n++) - FP_SET (n + 1, FP_REF (from + n)); - - RESET_FRAME (n + 1); - - if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) - ip = SCM_PROGRAM_CODE (FP_REF (0)); - else - { - SYNC_IP (); - CALL_INTRINSIC (apply_non_program, (thread)); - CACHE_REGISTER (); - } - - APPLY_HOOK (); - - NEXT (0); + vm_error_bad_instruction (op); + abort (); /* never reached */ } /* receive dst:12 proc:12 _:8 nlocals:24 @@ -554,29 +515,36 @@ VM_NAME (scm_thread *thread) NEXT (2); } - VM_DEFINE_OP (8, unused_8, NULL, NOP) + /* shuffle-down from:12 to:12 + * + * Shuffle down values from FROM to TO, reducing the frame size by + * (FROM-TO) slots. Part of the internal implementation of + * call-with-values, values, and apply. + */ + VM_DEFINE_OP (8, shuffle_down, "shuffle-down", OP1 (X8_F12_F12)) { - vm_error_bad_instruction (op); - abort (); /* never reached */ + uint32_t n, from, to, nlocals; + + UNPACK_12_12 (op, from, to); + + VM_ASSERT (from > to, abort ()); + nlocals = FRAME_LOCALS_COUNT (); + + for (n = 0; from + n < nlocals; n++) + FP_SET (to + n, FP_REF (from + n)); + + RESET_FRAME (to + n); + + NEXT (1); } - /* return-values nlocals:24 + /* return-values _:24 * - * Return a number of values from a call frame. This opcode - * corresponds to an application of `values' in tail position. As - * with tail calls, we expect that the values have already been - * shuffled down to a contiguous array starting at slot 1. - * If NLOCALS is not zero, we also reset the frame to hold NLOCALS - * values. + * Return all values from a call frame. */ - VM_DEFINE_OP (9, return_values, "return-values", OP1 (X8_C24)) + VM_DEFINE_OP (9, return_values, "return-values", OP1 (X32)) { union scm_vm_stack_element *old_fp; - uint32_t nlocals; - - UNPACK_24 (op, nlocals); - if (nlocals) - RESET_FRAME (nlocals); old_fp = VP->fp; ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (VP->fp); @@ -706,51 +674,10 @@ VM_NAME (scm_thread *thread) NEXT (0); } - /* tail-apply _:24 - * - * Tail-apply the procedure in local slot 1 to the rest of the - * arguments. This instruction is part of the implementation of - * `apply', and is not generated by the compiler. - */ - VM_DEFINE_OP (14, tail_apply, "tail-apply", OP1 (X32)) + VM_DEFINE_OP (14, unused_14, NULL, NOP) { - int i, list_idx, list_len, nlocals; - SCM list; - - nlocals = FRAME_LOCALS_COUNT (); - // At a minimum, there should be apply, f, and the list. - VM_ASSERT (nlocals >= 3, abort ()); - list_idx = nlocals - 1; - list = FP_REF (list_idx); - - SYNC_IP (); - list_len = CALL_INTRINSIC (rest_arg_length, (list)); - - nlocals = nlocals - 2 + list_len; - ALLOC_FRAME (nlocals); - - for (i = 1; i < list_idx; i++) - FP_SET (i - 1, FP_REF (i)); - - /* Null out these slots, just in case there are less than 2 elements - in the list. */ - FP_SET (list_idx - 1, SCM_UNDEFINED); - FP_SET (list_idx, SCM_UNDEFINED); - - for (i = 0; i < list_len; i++, list = SCM_CDR (list)) - FP_SET (list_idx - 1 + i, SCM_CAR (list)); - - if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) - ip = SCM_PROGRAM_CODE (FP_REF (0)); - else - { - CALL_INTRINSIC (apply_non_program, (thread)); - CACHE_REGISTER (); - } - - APPLY_HOOK (); - - NEXT (0); + vm_error_bad_instruction (op); + abort (); /* never reached */ } /* call/cc _:24 @@ -1042,10 +969,30 @@ VM_NAME (scm_thread *thread) NEXT (1); } - VM_DEFINE_OP (30, unused_30, NULL, NOP) + /* expand-apply-argument _:24 + * + * Take the last local in a frame and expand it out onto the stack, as + * for the last argument to "apply". + */ + VM_DEFINE_OP (30, expand_apply_argument, "expand-apply-argument", OP1 (X32)) { - vm_error_bad_instruction (op); - abort (); + int list_len; + SCM list; + + list = SP_REF (0); + + SYNC_IP (); + list_len = CALL_INTRINSIC (rest_arg_length, (list)); + + ALLOC_FRAME (FRAME_LOCALS_COUNT () - 1 + list_len); + + while (list_len--) + { + SP_SET (list_len, SCM_CAR (list)); + list = SCM_CDR (list); + } + + NEXT (1); } /* bind-kwargs nreq:24 flags:8 nreq-and-opt:24 _:8 ntotal:24 kw-offset:32 diff --git a/libguile/vm.c b/libguile/vm.c index 1f2373acd..0e6112035 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -335,11 +335,13 @@ static const uint32_t vm_boot_continuation_code[] = { static const uint32_t vm_builtin_apply_code[] = { SCM_PACK_OP_24 (assert_nargs_ge, 3), - SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */ + SCM_PACK_OP_12_12 (shuffle_down, 1, 0), + SCM_PACK_OP_24 (expand_apply_argument, 0), + SCM_PACK_OP_24 (tail_call, 0), }; static const uint32_t vm_builtin_values_code[] = { - SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */ + SCM_PACK_OP_24 (return_values, 0) }; static const uint32_t vm_builtin_abort_to_prompt_code[] = { @@ -355,7 +357,8 @@ static const uint32_t vm_builtin_call_with_values_code[] = { SCM_PACK_OP_12_12 (mov, 0, 6), SCM_PACK_OP_24 (call, 7), SCM_PACK_OP_ARG_8_24 (0, 1), SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2), - SCM_PACK_OP_24 (tail_call_shuffle, 8) + SCM_PACK_OP_12_12 (shuffle_down, 8, 1), + SCM_PACK_OP_24 (tail_call, 0) }; static const uint32_t vm_builtin_call_with_current_continuation_code[] = { diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 91ae19c4c..4b2f358d7 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -110,22 +110,28 @@ (define (compile-tail label exp) ;; There are only three kinds of expressions in tail position: ;; tail calls, multiple-value returns, and single-value returns. + (define (maybe-reset-frame nlocals) + (unless (= frame-size nlocals) + (emit-reset-frame asm nlocals))) (match exp (($ $call proc args) (for-each (match-lambda ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) - (emit-tail-call asm (1+ (length args)))) + (maybe-reset-frame (1+ (length args))) + (emit-tail-call asm)) (($ $callk k proc args) (for-each (match-lambda ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) - (emit-tail-call-label asm (1+ (length args)) k)) + (maybe-reset-frame (1+ (length args))) + (emit-tail-call-label asm k)) (($ $values args) (for-each (match-lambda ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) - (emit-return-values asm (1+ (length args)))))) + (maybe-reset-frame (1+ (length args))) + (emit-return-values asm)))) (define (compile-value label exp dst) (match exp diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index e57e1bacd..83d29f40a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -237,7 +237,6 @@ emit-tail-call emit-tail-call-label emit-receive-values - emit-return emit-return-values emit-call/cc emit-abort @@ -1562,7 +1561,7 @@ a procedure to do that and return its label. Otherwise return (assert-nargs-ee/locals 1 1) ,@(reverse inits) (load-constant 0 ,*unspecified*) - (return-values 2) + (return-values) (end-program))) label)))) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index f46b160c6..83499333c 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -235,14 +235,8 @@ address of that offset." (list "~a slot~:p" nlocals)) (('reset-frame nlocals) (list "~a slot~:p" nlocals)) - (('return-values nlocals) - (if (zero? nlocals) - (list "all values") - (list "~a value~:p" (1- nlocals)))) (('bind-rest dst) (list "~a slot~:p" (1+ dst))) - (('tail-call nargs proc) - (list "~a arg~:p" nargs)) (('make-closure dst target nfree) (let* ((addr (u32-offset->addr (+ offset target) context)) (pdi (find-program-debug-info addr context)) @@ -264,7 +258,7 @@ address of that offset." "anonymous procedure"))) (push-addr! addr name) (list "~A at #x~X" name addr))) - (('tail-call-label nlocals target) + (('tail-call-label target) (let* ((addr (u32-offset->addr (+ offset target) context)) (pdi (find-program-debug-info addr context)) (name (or (and pdi (program-debug-info-name pdi)) @@ -507,17 +501,10 @@ address of that offset." (define (instruction-has-fallthrough? code pos) (define non-fallthrough-set (static-opcode-set halt - ;; FIXME: add throw, throw/value, - ;; throw/value+data. Currently control flow - ;; nominally continues; we don't add these ops to - ;; the non-fallthrough-set currently to allow the - ;; frame parser to be able to compute the stack - ;; size for following code. throw throw/value throw/value+data - tail-call tail-call-label tail-call/shuffle + tail-call tail-call-label return-values subr-call foreign-call continuation-call - tail-apply j)) (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) (not (bitvector-ref non-fallthrough-set opcode)))) @@ -582,10 +569,14 @@ address of that offset." #xfff)) (nlocals (ash (bytevector-u32-native-ref code pos) -20))) (+ nargs nlocals)))) - ((call call-label) - #'(lambda (code pos size) #f)) - ((tail-call tail-call-label tail-call/shuffle tail-apply) + ((call call-label tail-call tail-call-label expand-apply-argument) #'(lambda (code pos size) #f)) + ((shuffle-down) + #'(lambda (code pos size) + (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8) + #xfff)) + (to (ash (bytevector-u32-native-ref code pos) -20))) + (and size (- size (- from to)))))) (else #f))) (syntax-case x () |