Vm values

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<Vaslist_sp>(L)) {
+        Vaslist_sp vl = gc::As_unsafe<Vaslist_sp>(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<List_sp>(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);
   }

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<Cons_sp>(form) && oCar(form) == cl::_sym_values;
+}
+
+inline static bool values_list_form_p(T_sp form) {
+  return gc::IsA<Cons_sp>(form) && oCar(form) == cl::_sym_values_list
+    && gc::IsA<Cons_sp>(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<List_sp>(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<List_sp>(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);

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))

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)

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)