diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc index 0175ea0565..f1140a04c9 100644 --- a/src/core/bytecode.cc +++ b/src/core/bytecode.cc @@ -903,6 +903,52 @@ gctools::return_type bytecode_vm(VirtualMachine& vm, pc++; break; } + case vm_values: { + // POP with n values. Or alternately, POP-VALUES with a fixed n. + uint8_t n = *(++pc); + DBG_VM1("values %" PRIu8 "\n", n); + vm.copyto(sp, n, &my_thread->_MultipleValues._Values[0]); + multipleValues.setSize(n); + vm.drop(sp, n); + pc++; + break; + } + case vm_push_fixed: { + // Mark the previous N values as being part of MV call args. + // This is actually identical to pushing an integer constant, + // but semantically very distinct. + uint8_t n = *(++pc); + DBG_VM1("push-fixed %" PRIu8 "\n", n); + vm.push(sp, make_fixnum(n).raw_()); + pc++; + break; + } + case vm_append_values_list: { + // Pop a list or valist, and then append it all to the stack + // for an upcoming MV call. + DBG_VM1("append-values-list"); + T_sp L((gctools::Tagged)vm.pop(sp)); + T_sp texisting_values((gctools::Tagged)vm.pop(sp)); + size_t existing_values = texisting_values.unsafe_fixnum(); + size_t nargs = 0; + if (gc::IsA(L)) { + Vaslist_sp vl = gc::As_unsafe(L); + nargs = vl->nargs(); + // Make sure we do NOT advance the vaslist, + // as we do not own it and something else might be using it. + // TODO: direct copy? + for (size_t i = 0; i < nargs; ++i) vm.push(sp, (*vl)[i]); + } else { // list + List_sp arglist = gc::As(L); + for (auto largs : arglist) { + ++nargs; + vm.push(sp, oCar(largs).raw_()); + } + } + vm.push(sp, make_fixnum(nargs + existing_values).raw_()); + pc++; + break; + } case vm_long: { // In a separate function to facilitate better icache utilization // by bytecode_vm (hopefully) @@ -1342,6 +1388,24 @@ static unsigned char *long_dispatch(VirtualMachine& vm, pc++; break; } + case vm_values: { + uint8_t low = *(++pc); + uint16_t n = low + (*(++pc) << 8); + DBG_VM1("long values %" PRIu16 "\n", n); + vm.copyto(sp, n, &my_thread->_MultipleValues._Values[0]); + multipleValues.setSize(n); + vm.drop(sp, n); + pc++; + break; + } + case vm_push_fixed: { + uint8_t low = *(++pc); + uint16_t n = low + (*(++pc) << 8); + DBG_VM1("long push-fixed %" PRIu16 "\n", n); + vm.push(sp, make_fixnum(n).raw_()); + pc++; + break; + } default: SIMPLE_ERROR("Unknown LONG sub_opcode %hu", sub_opcode); } diff --git a/src/core/bytecode_compiler.cc b/src/core/bytecode_compiler.cc index b16574ec77..d58e00b745 100644 --- a/src/core/bytecode_compiler.cc +++ b/src/core/bytecode_compiler.cc @@ -1894,10 +1894,19 @@ void compile_fdesignator(T_sp fform, Lexenv_sp env, const Context ctxt) { // TODO: We could do something smarter if given 'foo or a constant, // but those are more marginal. if (fform.consp()) { + // In either case we are skipping compile_form on fform, + // so make sure to call the walker manually. + // We ignore the result though. That would be bad, except we don't + // actually use the code walker for rewriting anyway. + // FIXME: Encode that. if (oCar(fform) == cl::_sym_Function_O) { + if (code_walking_p()) + eval::funcall(_sym_STARcodeWalkerSTAR->symbolValue(), fform, env); compile_called_function(oCadr(fform), env, ctxt); return; } else if (oCar(fform) == cl::_sym_lambda) { + if (code_walking_p()) + eval::funcall(_sym_STARcodeWalkerSTAR->symbolValue(), fform, env); compile_called_function(fform, env, ctxt); return; } @@ -2263,24 +2272,59 @@ void compile_progv(T_sp syms, T_sp vals, List_sp body, Lexenv_sp env, const Cont ctxt.emit_unbind(1); } +// TODO: Hypothetically these could macroexpand etc., but honestly +// I don't wanna go through all that trouble, especially in C++. +inline static bool values_form_p(T_sp form) { + return gc::IsA(form) && oCar(form) == cl::_sym_values; +} + +inline static bool values_list_form_p(T_sp form) { + return gc::IsA(form) && oCar(form) == cl::_sym_values_list + && gc::IsA(oCdr(form)) && oCddr(form).nilp(); +} + void compile_multiple_value_call(T_sp fform, List_sp aforms, Lexenv_sp env, const Context ctxt) { compile_fdesignator(fform, env, ctxt); - if (aforms.nilp()) { - ctxt.emit_call(0); - } else { - // Compile the arguments - T_sp first = oCar(aforms); - List_sp rest = gc::As(oCdr(aforms)); - compile_form(first, env, ctxt.sub_receiving(-1)); - ctxt.assemble0(vm_push_values); - if (rest.notnilp()) { - for (auto cur : rest) { - compile_form(oCar(cur), env, ctxt.sub_receiving(-1)); - ctxt.assemble0(vm_append_values); + // Compile the arguments. We search for and pick out (values ...) + // forms in the first arguments, and (values-list ...) anywhere. + bool fixed_prefix = true; // still looking for (values ...) + size_t nfixed = 0; + for (auto cur : aforms) { + T_sp form = oCar(cur); + if (fixed_prefix) { + if (values_form_p(form)) { + for (auto largs : gc::As(oCdr(form))) { + ++nfixed; + compile_form(oCar(largs), env, ctxt.sub_receiving(1)); + } + continue; // skip the compilations below + } else { // first non-values form + fixed_prefix = false; + // With no prefix, we generate + // push-fixed 0; [form]; append-values + // which is a little dumb, but I doubt push-values would be + // meaningfully faster anyway. + ctxt.assemble1(vm_push_fixed, nfixed); + // form is actually compiled below. + // Checking for (values ...) after a non-values is pointless + // since append-fixed would, when you think about it, require + // a bunch of stack shifting or something. } } - ctxt.emit_mv_call(); + if (values_list_form_p(form)) { + compile_form(oCadr(form), env, ctxt.sub_receiving(1)); + ctxt.assemble0(vm_append_values_list); + } else { + compile_form(form, env, ctxt.sub_receiving(-1)); + ctxt.assemble0(vm_append_values); + } } + if (fixed_prefix) + // we have (mv-call foo (values ...) (values ...) etc). + // weird flex, but ok. + ctxt.emit_call(nfixed); + else + ctxt.emit_mv_call(); } void compile_multiple_value_prog1(T_sp fform, List_sp forms, Lexenv_sp env, const Context ctxt) { @@ -2426,6 +2470,30 @@ void compile_primop_funcall(T_sp callee, List_sp args, Lexenv_sp env, const Cont compile_call(args, env, context); } +void compile_values(List_sp args, Lexenv_sp env, const Context context) { + size_t nreceiving = context.receiving(); + if (nreceiving == -1) { // All values needed. + size_t nargs = 0; + for (auto largs : args) { + T_sp form = oCar(largs); + ++nargs; + compile_form(form, env, context.sub_receiving(1)); + } + if (nargs == 1) + context.assemble0(vm_pop); + else + context.assemble1(vm_values, nargs); + } else { // Get the first n values and discard the rest. + // Note that if args = nil oCar will properly return nil. + for (size_t i = 0; i < nreceiving; ++i) { + compile_form(oCar(args), env, context.sub_receiving(1)); + args = oCdr(args); + } + for (auto largs : args) + compile_form(oCar(largs), env, context.sub_receiving(0)); + } +} + void compile_combination(T_sp head, T_sp rest, Lexenv_sp env, const Context context) { if (head == cl::_sym_progn) compile_progn(rest, env, context); @@ -2474,6 +2542,8 @@ void compile_combination(T_sp head, T_sp rest, Lexenv_sp env, const Context cont // Do a basic syntax check so that (funcall) fails properly. && rest.consp()) compile_funcall(oCar(rest), oCdr(rest), env, context); + else if (head == cl::_sym_values) + compile_values(rest, env, context); // extension else if (head == cleavirPrimop::_sym_funcall) compile_primop_funcall(oCar(rest), oCdr(rest), env, context); diff --git a/src/lisp/kernel/cleavir/inline.lisp b/src/lisp/kernel/cleavir/inline.lisp index a571d396c3..f83433dbb9 100644 --- a/src/lisp/kernel/cleavir/inline.lisp +++ b/src/lisp/kernel/cleavir/inline.lisp @@ -75,17 +75,6 @@ (core:coerce-called-fdesignator ,function) ,@arguments)) -;;; We do this so that the compiler only has one form of variadic call to -;;; worry about. Also, perhaps counterintuitively, mv-call is actually -;;; easier for the compiler to work with than APPLY is, and more general -;;; besides. -(define-cleavir-compiler-macro apply (&whole form function &rest arguments) - (if (null arguments) - form ; invalid, let runtime handle the error - `(multiple-value-call ,function - ,@(loop for arg in (butlast arguments) - collect `(values ,arg)) - (values-list ,(first (last arguments)))))) #+(or) (define-cleavir-compiler-macro values (&whole form &rest values) `(cleavir-primop:values ,@values)) diff --git a/src/lisp/kernel/cmp/bytecode-machines.lisp b/src/lisp/kernel/cmp/bytecode-machines.lisp index 57fc890182..02589dd7c2 100644 --- a/src/lisp/kernel/cmp/bytecode-machines.lisp +++ b/src/lisp/kernel/cmp/bytecode-machines.lisp @@ -94,6 +94,9 @@ ("dup" 58) ("fdesignator" 59) ("called-fdefinition" 60 ((constant-arg 1)) ((constant-arg 2))) + ("values" 61 (1) (2)) + ("push-fixed" 62 (1) (2)) + ("append-values-list" 63) ("long" 255))) (defun pythonify-arguments (args) diff --git a/src/lisp/kernel/cmp/opt/opt-control.lisp b/src/lisp/kernel/cmp/opt/opt-control.lisp index d71f3dc334..0e01cfabf8 100644 --- a/src/lisp/kernel/cmp/opt/opt-control.lisp +++ b/src/lisp/kernel/cmp/opt/opt-control.lisp @@ -1,29 +1,22 @@ (in-package #:cmp) +;;; We do this so that the compiler only has one form of variadic call to +;;; worry about. Also, perhaps counterintuitively, mv-call is actually +;;; easier for the compiler to work with than APPLY is, and more general +;;; besides. (define-compiler-macro apply (&whole form function &rest arguments - &environment env) + &environment env) (if (null arguments) - form ; error, leave it to runtime - (let* ((fixed (butlast arguments)) - (last (first (last arguments))) - (fsym (gensym "FUNCTION")) - (syms (gensym-list fixed)) - (op (case (length fixed) - ((0) 'core:apply0) - ((1) 'core:apply1) - ((2) 'core:apply2) - ((3) 'core:apply3) - (otherwise 'core:apply4)))) - ;; Pick off (apply ... nil), which could be generated - ;; (for example in CLOS). - (if (and (constantp last env) - (null (ext:constant-form-value last env))) - `(funcall ,function ,@fixed) - ;; The LET is so that we evaluate the arguments to APPLY - ;; in the correct order. - `(let ((,fsym (core:coerce-called-fdesignator ,function)) - ,@(mapcar #'list syms fixed)) - (,op ,fsym ,last ,@syms)))))) + form ; invalid, let runtime handle the error + (let ((lastform (first (last arguments)))) + (if (and (constantp lastform env) + ;; generated by e.g. CLOS + (null (ext:constant-form-value lastform env))) + `(funcall ,function ,@(butlast arguments)) + `(multiple-value-call ,function + ,@(loop for arg in (butlast arguments) + collect `(values ,arg)) + (values-list ,(first (last arguments)))))))) (defun function-form-p (form) (and (consp form)