add multiple values support to the vm

* libguile/vm-engine.c (vm_run): The bootstrap program now uses mv_call,
  so as to allow multiple values out of the VM. (It did before, because
  multiple values were represented internally as single scm_values
  objects, but now that values go on the stack, we need to note the boot
  frame as accepting multiple values.)
  (vm_error_no_values): New error, happens if you pass no values into a
  single-value continuation. Passing more than one is OK though, it just
  takes the first one.

* libguile/vm-i-system.c (halt): Assume that someone has pushed the
  number of values onto the stack, and package up that number of values
  as a scm_values() object, for communication with the interpreter.
  (mv-call): New instruction, calls a procedure with a multiple-value
  continuation, even handling calls out to the interpreter.
  (return/values): New instruction, returns multiple values to the
  continuation. If the continuation is single-valued, takes the first
  value or errors if there are no values. Otherwise it returns to the
  multiple-value return address, pushing the number of values on top of
  the values.

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

* module/system/il/ghil.scm (<ghil-values>) Add new GHIL data structure
  and associated procedures.

* module/language/scheme/translate.scm (custom-transformer-table):
  Compile (values .. ) forms into <ghil-values>.

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index def7e80..14f444c 100644 (file)
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -100,9 +100,9 @@ vm_run (SCM vm, SCM program, SCM args)
     SCM prog = program;
 
     /* Boot program */
-    scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
+    scm_byte_t bytes[5] = {scm_op_mv_call, 0, 1, scm_op_make_int8_1, scm_op_halt};
     bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
-    program = scm_c_make_program (bytes, 3, SCM_BOOL_F);
+    program = scm_c_make_program (bytes, 5, SCM_BOOL_F);
 
     /* Initial frame */
     CACHE_REGISTER ();
@@ -166,6 +166,11 @@ vm_run (SCM vm, SCM program, SCM args)
     err_args = SCM_EOL;
     goto vm_error;
 
+  vm_error_no_values:
+    err_msg  = scm_from_locale_string ("VM: 0-valued return");
+    err_args = SCM_EOL;
+    goto vm_error;
+
 #if VM_CHECK_IP
   vm_error_invalid_address:
     err_msg  = scm_from_locale_string ("VM: Invalid program address");

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 86e6578..4e9ec42 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -55,9 +55,19 @@ 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 ();
-  POP (ret);
+  nvalues = SCM_I_INUM (*sp--);
+  if (nvalues == 1)
+    POP (ret);
+  else
+    {
+      POP_LIST (nvalues);
+      POP (ret);
+      ret = scm_values (ret);
+    }
+    
   {
 #ifdef THE_GOVERNMENT_IS_AFTER_ME
     if (sp != stack_base)
@@ -692,6 +702,68 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1)
   goto vm_error_wrong_type_apply;
 }
 
+VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 2, -1, 1)
+{
+  SCM x;
+  int offset;
+  
+  nargs = FETCH ();
+  offset = FETCH ();
+
+  x = sp[-nargs];
+
+  /*
+   * Subprogram call
+   */
+  if (SCM_PROGRAM_P (x))
+    {
+      program = x;
+      CACHE_PROGRAM ();
+      INIT_ARGS ();
+      NEW_FRAME ();
+      SCM_FRAME_DATA_ADDRESS (fp)[3] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
+      ENTER_HOOK ();
+      APPLY_HOOK ();
+      NEXT;
+    }
+  /*
+   * Other interpreted or compiled call
+   */
+  if (!SCM_FALSEP (scm_procedure_p (x)))
+    {
+      /* At this point, the stack contains the procedure and each one of its
+        arguments.  */
+      SCM args;
+      POP_LIST (nargs);
+      POP (args);
+      SYNC_REGISTER ();
+      *sp = scm_apply (x, args, SCM_EOL);
+      if (SCM_VALUESP (*sp))
+        {
+          SCM values, len;
+          POP (values);
+          values = scm_struct_ref (values, SCM_INUM0);
+          len = scm_length (values);
+          while (!SCM_NULLP (values))
+            PUSH (SCM_CAR (values));
+          PUSH (len);
+          ip += offset;
+        }
+      NEXT;
+    }
+  /*
+   * Continuation call
+   */
+  if (SCM_VM_CONT_P (x))
+    {
+      program = x;
+      goto vm_call_continuation;
+    }
+
+  program = x;
+  goto vm_error_wrong_type_apply;
+}
+
 VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
 {
   int len;
@@ -785,6 +857,66 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (return_values, "return/values", 1, -1, -1)
+{
+  EXIT_HOOK ();
+  RETURN_HOOK ();
+  {
+    int nvalues = FETCH ();
+    SCM *data = SCM_FRAME_DATA_ADDRESS (fp);
+#ifdef THE_GOVERNMENT_IS_AFTER_ME
+    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]);
+        
+        /* 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]);
+        
+        /* 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;
+    
+    
+  }
+
+  /* Restore the last program */
+  program = SCM_FRAME_PROGRAM (fp);
+  CACHE_PROGRAM ();
+  CACHE_EXTERNAL ();
+  CHECK_IP ();
+  NEXT;
+}
+
 /*
   Local Variables:
   c-file-style: "gnu"

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 493ce81..2946900 100644 (file)
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -300,7 +300,11 @@
 
     ;; FIXME: make this actually do something
     (start-stack
-     ((,tag ,expr) (retrans expr)))))
+     ((,tag ,expr) (retrans expr)))
+
+    (values
+     ((,x) (retrans x))
+     (,args (make-ghil-values e l (map retrans args))))))
 
 (define (trans-quasiquote e l x level)
   (cond ((not (pair? x)) x)

diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index ffc5181..66d566b 100644 (file)
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -301,6 +301,17 @@
         (maybe-drop)
         (maybe-return))
 
+        ((<ghil-values> env loc values)
+         (cond (tail ;; (lambda () (values 1 2))
+                (push-call! loc 'return/values values))
+               (drop ;; (lambda () (values 1 2) 3)
+                (for-each comp-drop values))
+               (else ;; (lambda () (list (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 'call values))))
+                
        ((<ghil-call> env loc proc args)
         ;; PROC
         ;; ARGS...

diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 2a03109..ae42d4f 100644 (file)
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -72,6 +72,9 @@
    <ghil-call> make-ghil-call ghil-call?
    ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
 
+   <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
@@ -110,7 +113,8 @@
    (<ghil-bind> env loc vars vals body)
    (<ghil-lambda> env loc vars rest meta body)
    (<ghil-call> env loc proc args)
-   (<ghil-inline> env loc inline args)))
+   (<ghil-inline> env loc inline args)
+   (<ghil-values> env loc values)))
 
 \f
 ;;;