add special case for (apply values ...)

* libguile/vm-engine.c (vm_run): Move nvalues to the top level, to avoid
  (spurious, it seems) gcc warnings about it being used uninitialized.

* libguile/vm-i-system.c (halt, return/values): Adapt to gcc silliness.
  Deindent some of return/values.
  (return/values*): New instruction, does what (apply values . args)
  would do.

* module/language/scheme/translate.scm (custom-transformer-table): Move
  the apply and @apply cases here from inline.scm, because we need some
  more cleverness when dealing with cases like (apply values . args).
  (lookup-apply-transformer): Define an eval transformer for `values',
  turning it into ghil-values*.

* module/system/il/compile.scm (codegen): Compile <ghil-values*> into
  return/values*.

* module/system/il/ghil.scm: Add <ghil-values*> and accessors.
  (ghil-lookup): Add optional argument, define?, which if false tells us
  not to actually cache the binding if it is not found in the toplevel.

* module/system/il/inline.scm: Remove apply clauses.

* module/system/vm/frame.scm (bootstrap-frame?): Update heuristic for
  bootstrap-frame?, as the bootstrap frame is now 5 bytes since it
  accepts multiple values.

libguile/vm-engine.c

@@ -65,6 +65,7 @@ vm_run (SCM vm, SCM program, SCM args)
 
   /* Internal variables */
   int nargs = 0;
+  int nvalues = 0;
   long start_time = scm_c_get_internal_run_time ();
   // SCM dynwinds = SCM_EOL;
   SCM err_msg;

libguile/vm-i-system.c

@@ -55,7 +55,6 @@ VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
 VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
 {
   SCM ret;
-  int nvalues;
   vp->time += scm_c_get_internal_run_time () - start_time;
   HALT_HOOK ();
   nvalues = SCM_I_INUM (*sp--);
@@ -859,55 +858,57 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
 
 VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
 {
+  /* nvalues declared at top level, because for some reason gcc seems to think
+     that perhaps it might be used without declaration. Fooey to that, I say. */
+  SCM *data;
+
+  nvalues = FETCH ();
+ vm_return_values:
   EXIT_HOOK ();
   RETURN_HOOK ();
-  {
-    int nvalues = FETCH ();
-    SCM *data = SCM_FRAME_DATA_ADDRESS (fp);
+
+  data = SCM_FRAME_DATA_ADDRESS (fp);
 #ifdef THE_GOVERNMENT_IS_AFTER_ME
-    if (stack_base != data + 4)
-      abort ();
+  if (stack_base != data + 4)
+    abort ();
 #endif
 
-    /* data[3] is the mv return address */
-    if (nvalues != 1 && data[3]) 
-      {
-        int i;
-        /* Restore registers */
-        sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
-        ip = SCM_FRAME_BYTE_CAST (data[3]); /* multiple value ra */
-        fp = SCM_FRAME_STACK_CAST (data[2]);
+  /* data[3] is the mv return address */
+  if (nvalues != 1 && data[3]) 
+    {
+      int i;
+      /* Restore registers */
+      sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
+      ip = SCM_FRAME_BYTE_CAST (data[3]); /* multiple value ra */
+      fp = SCM_FRAME_STACK_CAST (data[2]);
         
-        /* Push return values, and the number of values */
-        for (i = 0; i < nvalues; i++)
-          *++sp = stack_base[1+i];
-        *++sp = SCM_I_MAKINUM (nvalues);
+      /* Push return values, and the number of values */
+      for (i = 0; i < nvalues; i++)
+        *++sp = stack_base[1+i];
+      *++sp = SCM_I_MAKINUM (nvalues);
              
-        /* Finally set new stack_base */
-        stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
-      }
-    else if (nvalues >= 1)
-      {
-        /* Multiple values for a single-valued continuation -- here's where I
-           break with guile tradition and try and do something sensible. (Also,
-           this block handles the single-valued return to an mv
-           continuation.) */
-        /* Restore registers */
-        sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
-        ip = SCM_FRAME_BYTE_CAST (data[4]); /* single value ra */
-        fp = SCM_FRAME_STACK_CAST (data[2]);
+      /* Finally set new stack_base */
+      stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+    }
+  else if (nvalues >= 1)
+    {
+      /* Multiple values for a single-valued continuation -- here's where I
+         break with guile tradition and try and do something sensible. (Also,
+         this block handles the single-valued return to an mv
+         continuation.) */
+      /* Restore registers */
+      sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
+      ip = SCM_FRAME_BYTE_CAST (data[4]); /* single value ra */
+      fp = SCM_FRAME_STACK_CAST (data[2]);
         
-        /* Push first value */
-        *++sp = stack_base[1];
+      /* Push first value */
+      *++sp = stack_base[1];
              
-        /* Finally set new stack_base */
-        stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
-      }
-    else
-      goto vm_error_no_values;
-    
-    
-  }
+      /* Finally set new stack_base */
+      stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1;
+    }
+  else
+    goto vm_error_no_values;
 
   /* Restore the last program */
   program = SCM_FRAME_PROGRAM (fp);
@@ -917,6 +918,28 @@ VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
+{
+  SCM l;
+
+  nvalues = FETCH ();
+#ifdef THE_GOVERNMENT_IS_AFTER_ME
+  if (nvalues < 1)
+    abort ();
+#endif
+    
+  nvalues--;
+  POP (l);
+  while (SCM_CONSP (l))
+    {
+      PUSH (SCM_CAR (l));
+      l = SCM_CDR (l);
+      nvalues++;
+    }
+
+  goto vm_return_values;
+}
+
 /*
   Local Variables:
   c-file-style: "gnu"

module/language/scheme/translate.scm

@@ -302,10 +302,36 @@
     (start-stack
      ((,tag ,expr) (retrans expr)))
 
+    ;; FIXME: not hygienic, relies on @apply not being shadowed
+    (apply
+     (,args (retrans `(@apply ,@args))))
+
+    (@apply
+     ((,proc ,arg1 . ,args)
+      (let ((args (cons (retrans arg1) (map retrans args))))
+        (cond ((and (symbol? proc)
+                    (not (ghil-lookup e proc #f))
+                    (and=> (module-variable (current-module) proc)
+                           (lambda (var)
+                             (and (variable-bound? var)
+                                  (lookup-apply-transformer (variable-ref var))))))
+               ;; that is, a variable, not part of this compilation
+               ;; unit, but defined in the toplevel environment, and has
+               ;; an apply transformer registered
+               => (lambda (t) (t e l args)))
+              (else (make-ghil-inline e l 'apply
+                                      (cons (retrans proc) args)))))))
+
     (values
      ((,x) (retrans x))
      (,args (make-ghil-values e l (map retrans args))))))
 
+(define (lookup-apply-transformer proc)
+  (cond ((eq? proc values)
+         (lambda (e l args)
+           (make-ghil-values* e l args)))
+        (else #f)))
+
 (define (trans-quasiquote e l x level)
   (cond ((not (pair? x)) x)
 	((memq (car x) '(unquote unquote-splicing))

module/system/il/compile.scm

@@ -312,6 +312,17 @@
                 (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
                 (push-call! loc 'call values))))
                 
+        ((<ghil-values*> env loc values)
+         (cond (tail ;; (lambda () (apply values '(1 2)))
+                (push-call! loc 'return/values* values))
+               (drop ;; (lambda () (apply values '(1 2)) 3)
+                (for-each comp-drop values))
+               (else ;; (lambda () (list (apply values '(10 12)) 1))
+                (push-code! #f (make-glil-const #:obj 'values))
+                (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1))
+                (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0))
+                (push-call! loc 'apply values))))
+                
 	((<ghil-call> env loc proc args)
 	 ;; PROC
 	 ;; ARGS...

module/system/il/ghil.scm

@@ -75,6 +75,9 @@
    <ghil-values> make-ghil-values ghil-values?
    ghil-values-env ghil-values-loc ghil-values-values
 
+   <ghil-values*> make-ghil-values* ghil-values*?
+   ghil-values*-env ghil-values*-loc ghil-values*-values
+
    <ghil-var> make-ghil-var ghil-var?
    ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value
    ghil-var-index
@@ -114,7 +117,8 @@
    (<ghil-lambda> env loc vars rest meta body)
    (<ghil-call> env loc proc args)
    (<ghil-inline> env loc inline args)
-   (<ghil-values> env loc values)))
+   (<ghil-values> env loc values)
+   (<ghil-values*> env loc values)))
 
 
 ;;;
@@ -168,15 +172,17 @@
 ;; which will be looked up at runtime with respect to the module that
 ;; was current when the lambda was bound, at runtime. The variable will
 ;; be resolved when it is first used.
-(define (ghil-lookup env sym)
+(define (ghil-lookup env sym . define?)
   (let loop ((e env))
     (record-case e
       ((<ghil-toplevel-env> table)
        (let ((key (cons (module-name (current-module)) sym)))
          (or (assoc-ref table key)
-             (let ((var (make-ghil-var (car key) (cdr key) 'module)))
-               (apush! key var (ghil-toplevel-env-table e))
-               var))))
+             (and (or (null? define?)
+                      (car define?))
+                  (let ((var (make-ghil-var (car key) (cdr key) 'module)))
+                    (apush! key var (ghil-toplevel-env-table e))
+                    var)))))
       ((<ghil-env> parent table variables)
        (let ((found (assq-ref table sym)))
          (if found

module/system/il/inline.scm

@@ -198,12 +198,3 @@
   (x) x
   (x y) (cons x y)
   (x y . rest) (cons x (cons* y . rest)))
-
-(define-inline apply (proc . args)
-  (apply proc . args))
-
-;; From ice-9/r4rs.scm; actually not that bad of a strategy for handling
-;; the (apply apply ...) case
-
-(define-inline @apply (proc . args)
-  (apply proc . args))

module/system/vm/frame.scm

@@ -46,8 +46,8 @@
 
 (define (bootstrap-frame? frame)
   (let ((code (program-bytecode (frame-program frame))))
-    (and (= (uniform-vector-length code) 3)
-         (= (uniform-vector-ref code 2)
+    (and (= (uniform-vector-length code) 5)
+         (= (uniform-vector-ref code 4)
             (instruction->opcode 'halt)))))
 
 (define (make-frame-chain frame addr)