lambda-lifting for (lambda () ...) as consumer of call-with-values

* libguile/vm-engine.c (vm_run): Add new error case,
  vm_error_not_enough_values.

* libguile/vm-i-system.c (goto/nargs, call/nargs): So, in these cases, if
  we get too many values, we don't truncate the values like we do in the
  single-value continuation case, or in the mvbind case. What to do? I
  guess we either truncate them here, or only allow the correct number of
  values. Dunno. Mark the code as a fixme.
  (truncate-values): New instruction, for mv-bind: checks that the number
  of values on the stack is compatible with the number of bindings we
  have arranged for them, truncating if necessary.

* module/language/scheme/translate.scm (custom-transformer-table):
  Compile receive as a primary form -- not so much because it is a
  primary form, but more to test the mv-bind machinery. Also it's more
  efficient, I think.

* module/system/il/compile.scm (lift-variables!): New helper, factored
  out of `optimize'.
  (optimize): Add a few more cases. Adapt `lambda' optimization, which
  isn't much. I'm not happy with ghil as a mungeable language.
  Add a case for call-with-values with the second argument is
  a lambda: lift the lambda. Untested.
  (codegen): Refactor the push-bindings! code. Compile mv-bind.

* module/system/il/ghil.scm (<ghil-mv-bind>): Add mv-bind construct,
  along with its procedures.

* module/system/il/glil.scm (<glil-mv-bind>): Add mv-bind construct,
  different from the high-level one. It makes sense in the source, I
  think.

* module/system/vm/assemble.scm (codegen): Assemble glil-mv-bind by
  pushing onto the bindings list, and actually push some code to truncate
  the values.

libguile/vm-engine.c

@@ -172,6 +172,11 @@ vm_run (SCM vm, SCM program, SCM args)
     err_args = SCM_EOL;
     goto vm_error;
 
+  vm_error_not_enough_values:
+    err_msg  = scm_from_locale_string ("VM: Not enough values for mv-bind");
+    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");

libguile/vm-i-system.c

@@ -713,6 +713,7 @@ VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1)
   SCM x;
   POP (x);
   nargs = scm_to_int (x);
+  /* FIXME: should truncate values? */
   goto vm_goto_args;
 }
 
@@ -721,6 +722,7 @@ VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1)
   SCM x;
   POP (x);
   nargs = scm_to_int (x);
+  /* FIXME: should truncate values? */
   goto vm_call;
 }
 
@@ -963,6 +965,29 @@ VM_DEFINE_INSTRUCTION (return_values_star, "return/values*", 1, -1, -1)
   goto vm_return_values;
 }
 
+VM_DEFINE_INSTRUCTION (truncate_values, "truncate-values", 2, -1, -1)
+{
+  SCM x;
+  int nbinds, rest;
+  POP (x);
+  nvalues = scm_to_int (x);
+  nbinds = FETCH ();
+  rest = FETCH ();
+
+  if (rest)
+    nbinds--;
+
+  if (nvalues < nbinds)
+    goto vm_error_not_enough_values;
+
+  if (rest)
+    POP_LIST (nvalues - nbinds);
+  else
+    DROPN (nvalues - nbinds);
+
+  NEXT;
+}
+
 /*
   Local Variables:
   c-file-style: "gnu"

module/language/scheme/translate.scm

@@ -25,7 +25,6 @@
   #:use-module (system il ghil)
   #:use-module (system il inline)
   #:use-module (ice-9 receive)
-  #:use-module (srfi srfi-39)
   #:use-module ((system base compile) #:select (syntax-error))
   #:export (translate))
 
@@ -332,6 +331,17 @@
      ((,producer ,consumer)
       (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
 
+    (receive
+     ((,formals ,producer-exp . ,body)
+      ;; Lovely, self-referential usage. Not strictly necessary, the
+      ;; macro would do the trick; but it's good to test the mv-bind
+      ;; code.
+      (receive (syms rest) (parse-formals formals)
+        (call-with-ghil-bindings e syms
+          (lambda (vars)
+            (make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
+                               vars rest (trans-body e l body)))))))
+
     (values
      ((,x) (retrans x))
      (,args (make-ghil-values e l (map retrans args))))))

module/system/il/compile.scm

@@ -35,14 +35,32 @@
 ;;; Stage 2: Optimization
 ;;;
 
+(define (lift-variables! env)
+  (let ((parent-env (ghil-env-parent env)))
+    (for-each (lambda (v)
+                (case (ghil-var-kind v)
+                  ((argument) (set! (ghil-var-kind v) 'local)))
+                (set! (ghil-var-env v) parent-env)
+                (ghil-env-add! parent-env v))
+              (ghil-env-variables env))))
+
 (define (optimize x)
   (record-case x
     ((<ghil-set> env loc var val)
      (make-ghil-set env var (optimize val)))
 
+    ((<ghil-define> env loc var val)
+     (make-ghil-define env var (optimize val)))
+
     ((<ghil-if> env loc test then else)
      (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
 
+    ((<ghil-and> env loc exps)
+     (make-ghil-and env loc (map optimize exps)))
+
+    ((<ghil-or> env loc exps)
+     (make-ghil-or env loc (map optimize exps)))
+
     ((<ghil-begin> env loc exps)
      (make-ghil-begin env loc (map optimize exps)))
 
@@ -63,17 +81,23 @@
          ((<ghil-lambda> env loc vars rest meta body)
           (cond
            ((not rest)
-            (for-each (lambda (v)
-                        (case (ghil-var-kind v)
-                          ((argument) (set! (ghil-var-kind v) 'local)))
-                        (set! (ghil-var-env v) parent-env)
-                        (ghil-env-add! parent-env v))
-                      (ghil-env-variables env)))
+            (lift-variables! env)
+            (make-ghil-bind parent-env loc (map optimize args)))
            (else
             (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
          (else
           (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
 
+    ((<ghil-mv-call> env loc producer consumer)
+     (record-case consumer
+      ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
+      ;;   (mv-let PRODUCER ARGS BODY...)
+      ((<ghil-lambda> env loc vars rest meta body)
+       (lift-variables! env)
+       (make-ghil-mv-bind producer vars rest body))
+      (else
+       (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
+
     (else x)))
 
 
@@ -116,15 +140,11 @@
     (define (push-code! loc code)
       (set! stack (cons code stack))
       (if loc (set! stack (cons (make-glil-source loc) stack))))
+    (define (var->binding var)
+      (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
     (define (push-bindings! loc vars)
       (if (not (null? vars))
-          (push-code!
-           loc
-           (make-glil-bind
-            (map list
-                 (map ghil-var-name vars)
-                 (map ghil-var-kind vars)
-                 (map ghil-var-index vars))))))
+          (push-code! loc (make-glil-bind (map var->binding vars)))))
     (define (comp tree tail drop)
       (define (push-label! label)
 	(push-code! #f (make-glil-label label)))
@@ -290,6 +310,21 @@
 	 (comp-tail body)
 	 (push-code! #f (make-glil-unbind)))
 
+	((<ghil-mv-bind> env loc producer vars rest body)
+	 ;; VALS...
+	 ;; (set VARS)...
+	 ;; BODY
+         (let ((MV (make-label)))
+           (comp-push producer)
+           (push-code! loc (make-glil-mv-call 0 MV))
+           (push-code! #f (make-glil-const #:obj 1))
+           (push-label! MV)
+           (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
+           (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
+                     (reverse vars)))
+         (comp-tail body)
+         (push-code! #f (make-glil-unbind)))
+
 	((<ghil-lambda> env loc vars rest meta body)
 	 (return-code! loc (codegen tree)))
 

module/system/il/ghil.scm

@@ -62,6 +62,9 @@
    <ghil-bind> make-ghil-bind ghil-bind?
    ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
 
+   <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
+   ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
+
    <ghil-lambda> make-ghil-lambda ghil-lambda?
    ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
    ghil-lambda-meta ghil-lambda-body
@@ -117,6 +120,7 @@
    (<ghil-or> env loc exps)
    (<ghil-begin> env loc exps)
    (<ghil-bind> env loc vars vals body)
+   (<ghil-mv-bind> env loc producer vars rest body)
    (<ghil-lambda> env loc vars rest meta body)
    (<ghil-call> env loc proc args)
    (<ghil-mv-call> env loc producer consumer)

module/system/il/glil.scm

@@ -32,6 +32,9 @@
    <glil-bind> make-glil-bind glil-bind?
    glil-bind-vars
 
+   <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
+   glil-mv-bind-vars glil-mv-bind-rest
+
    <glil-unbind> make-glil-unbind glil-unbind?
 
    <glil-source> make-glil-source glil-source?
@@ -76,6 +79,7 @@
    ;; Meta operations
    (<glil-asm> vars meta body)
    (<glil-bind> vars)
+   (<glil-mv-bind> vars rest)
    (<glil-unbind>)
    (<glil-source> loc)
    ;; Objects

module/system/vm/assemble.scm

@@ -139,6 +139,19 @@
 	      (set! binding-alist
 		    (acons (current-address) bindings binding-alist))))
 
+	   ((<glil-mv-bind> (binds vars) rest)
+	    (let ((bindings
+		   (map (lambda (v)
+			  (let ((name (car v)) (type (cadr v)) (i (caddr v)))
+			    (case type
+			      ((argument) (make-binding name #f i))
+			      ((local) (make-binding name #f (+ (glil-vars-nargs vars) i)))
+			      ((external) (make-binding name #t i)))))
+			binds)))
+	      (set! binding-alist
+		    (acons (current-address) bindings binding-alist))
+              (push-code! `(truncate-values ,(length binds) ,(if rest 1 0)))))
+
 	   ((<glil-unbind>)
 	    (set! binding-alist (acons (current-address) #f binding-alist)))