compile call-with-values, woot!

* libguile/vm-engine.c (vm_run): Add another byte onto the bootstrap
  program, as the offset passed to mv-call now takes two bytes.

* module/system/vm/frame.scm (bootstrap-frame?): Update for the new
  bootstrap length. Really we should just check for 'halt though.

* libguile/vm-i-system.c (FETCH_OFFSET): New helper, used in BR().
  (goto/nargs, call/nargs): Versions of goto/args and call, respectively,
  that take the number of arguments from a value on the top of the stack.
  (mv-call): Call FETCH_OFFSET to get the offset.

* module/language/scheme/translate.scm (custom-transformer-table):
  Compile call-with-values to <ghil-mv-call>. There is some trickery
  because of the r4rs.scm call-with-values trampolines.

* module/system/il/ghil.scm: Add <ghil-mv-call> and accessors.

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

* module/system/il/glil.scm: Add <glil-mv-call>, which needs some special
  assembly because of the label. Fix some typos.

* module/system/vm/assemble.scm (byte-length): New helper, factored out
  and made more general.
  (codegen): Assemble mv-call, including the label.
  (check-length): New helper, makes sure that the addressing is
  consistent within the produced object code.
  (stack->bytes): Rewrite to be more generic -- now `br' instructions
  aren't the only ones jumping around in the instruction stream.

* module/system/vm/conv.scm (make-byte-decoder): Return two values in the
  #f case.

* module/system/vm/disasm.scm (disassemble-bytecode): Rewrite, because
  the previous implementation depended on a guile interpreter quirk:
  namely, that multiple values could be represented within one value, and
  destructured later.

libguile/vm-engine.c

@@ -101,9 +101,9 @@ vm_run (SCM vm, SCM program, SCM args)
     SCM prog = program;
 
     /* Boot program */
-    scm_byte_t bytes[5] = {scm_op_mv_call, 0, 1, scm_op_make_int8_1, scm_op_halt};
+    scm_byte_t bytes[6] = {scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
     bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
-    program = scm_c_make_program (bytes, 5, SCM_BOOL_F);
+    program = scm_c_make_program (bytes, 6, SCM_BOOL_F);
 
     /* Initial frame */
     CACHE_REGISTER ();

libguile/vm-i-system.c

@@ -376,11 +376,18 @@ VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
  * branch and jump
  */
 
-#define BR(p)					\
+/* offset must be a signed short!!! */
+#define FETCH_OFFSET(offset)                    \
 {						\
   int h = FETCH ();				\
   int l = FETCH ();				\
-  signed short offset = (h << 8) + l;		\
+  offset = (h << 8) + l;                        \
+}
+
+#define BR(p)					\
+{						\
+  signed short offset;                          \
+  FETCH_OFFSET (offset);                        \
   if (p)					\
     ip += offset;				\
   DROP ();					\
@@ -701,13 +708,29 @@ 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)
+VM_DEFINE_INSTRUCTION (goto_nargs, "goto/nargs", 0, 0, 1)
 {
   SCM x;
-  int offset;
+  POP (x);
+  nargs = scm_to_int (x);
+  goto vm_goto_args;
+}
+
+VM_DEFINE_INSTRUCTION (call_nargs, "call/nargs", 0, 0, 1)
+{
+  SCM x;
+  POP (x);
+  nargs = scm_to_int (x);
+  goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (mv_call, "mv-call", 3, -1, 1)
+{
+  SCM x;
+  signed short offset;
   
   nargs = FETCH ();
-  offset = FETCH ();
+  FETCH_OFFSET (offset);
 
   x = sp[-nargs];
 

module/language/scheme/translate.scm

@@ -322,6 +322,16 @@
               (else (make-ghil-inline e l 'apply
                                       (cons (retrans proc) args)))))))
 
+    ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
+    (call-with-values
+     ((,producer ,consumer)
+      (retrans `(@call-with-values ,producer ,consumer)))
+     (else #f))
+
+    (@call-with-values
+     ((,producer ,consumer)
+      (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
+
     (values
      ((,x) (retrans x))
      (,args (make-ghil-values e l (map retrans args))))))

module/system/il/compile.scm

@@ -329,7 +329,28 @@
 	 ;; ([tail-]call NARGS)
 	 (comp-push proc)
 	 (push-call! loc (if tail 'goto/args 'call) args)
-	 (maybe-drop))))
+	 (maybe-drop))
+
+	((<ghil-mv-call> env loc producer consumer)
+	 ;; CONSUMER
+         ;; PRODUCER
+         ;; (mv-call MV)
+         ;; ([tail]-call 1)
+         ;; goto POST
+         ;; MV: [tail-]call/nargs
+         ;; POST: (maybe-drop)
+         (let ((MV (make-label)) (POST (make-label)))
+           (comp-push consumer)
+           (comp-push producer)
+           (push-code! loc (make-glil-mv-call 0 MV))
+           (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
+           (cond ((not tail)
+                  (push-branch! #f 'br POST)))
+           (push-label! MV)
+           (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
+           (cond ((not tail)
+                  (push-label! POST)
+                  (maybe-drop)))))))
     ;;
     ;; main
     (record-case ghil

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-mv-call> make-ghil-mv-call ghil-mv-call?
+   ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer
+
    <ghil-values> make-ghil-values ghil-values?
    ghil-values-env ghil-values-loc ghil-values-values
 
@@ -116,6 +119,7 @@
    (<ghil-bind> env loc vars vals body)
    (<ghil-lambda> env loc vars rest meta body)
    (<ghil-call> env loc proc args)
+   (<ghil-mv-call> env loc producer consumer)
    (<ghil-inline> env loc inline args)
    (<ghil-values> env loc values)
    (<ghil-values*> env loc values)))

module/system/il/glil.scm

@@ -61,10 +61,13 @@
    glil-label-label
 
    <glil-branch> make-glil-branch glil-branch?
-   glil-branch-int glil-branch-label
+   glil-branch-inst glil-branch-label
 
    <glil-call> make-glil-call glil-call?
-   glil-call-int glil-call-nargs))
+   glil-call-inst glil-call-nargs
+
+   <glil-mv-call> make-glil-mv-call glil-mv-call?
+   glil-mv-call-nargs glil-mv-call-ra))
 
 (define-record (<glil-vars> nargs nrest nlocs nexts))
 
@@ -87,7 +90,8 @@
    ;; Controls
    (<glil-label> label)
    (<glil-branch> inst label)
-   (<glil-call> inst nargs)))
+   (<glil-call> inst nargs)
+   (<glil-mv-call> nargs ra)))
 
 
 ;;;

module/system/vm/assemble.scm

@@ -90,6 +90,13 @@
                        #:bytes (stack->bytes (reverse! stack) '())
                        #:meta #f #:objs #f #:closure? #f))))
 
+(define (byte-length x)
+  (cond ((u8vector? x) (u8vector-length x))
+        ((>= (instruction-length (car x)) 0)
+         ;; one byte for the instruction itself
+         (1+ (instruction-length (car x))))
+        (else (error "variable-length instruction?" x))))
+
 (define (codegen glil toplevel)
   (record-case glil
     ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
@@ -113,9 +120,6 @@
 				  i)))))
 		  (push-code! `(object-ref ,i))))))
        (define (current-address)
-	 (define (byte-length x)
-	   (cond ((u8vector? x) (u8vector-length x))
-		 (else 3)))
 	 (apply + (map byte-length stack)))
        (define (generate-code x)
 	 (record-case x
@@ -206,7 +210,11 @@
 			 (push-code! (list inst)))
 			(else
 			 (error "Wrong number of arguments:" inst nargs))))
-		(error "Unknown instruction:" inst)))))
+		(error "Unknown instruction:" inst)))
+
+	   ((<glil-mv-call> nargs ra)
+            (push (list 'mv-call nargs ra) stack))))
+
        ;;
        ;; main
        (for-each generate-code body)
@@ -228,22 +236,36 @@
     ((<vlink-later>) (assoc x alist))
     (else        (assq x alist))))
 
+(define (check-length len u8v)
+  (or (= len (u8vector-length u8v))
+      (error "the badness!" len u8v))
+  u8v)
+
 (define (stack->bytes stack label-alist)
   (let loop ((result '()) (stack stack) (addr 0))
     (if (null? stack)
-	(list->u8vector(append-map u8vector->list
+        (check-length
-                                   (reverse! result)))
+         addr
-	(let ((bytes (car stack)))
+         (list->u8vector
-	  (if (pair? bytes)
+          (append-map u8vector->list (reverse! result))))
-	      (let* ((offset (- (assq-ref label-alist (cadr bytes))
+        (let ((elt (car stack)))
-				(+ addr 3)))
+          (cond
-		     (n (if (< offset 0) (+ offset 65536) offset)))
+           ((u8vector? elt)
-		(set! bytes (code->bytes (list (car bytes)
+            (loop (cons elt result)
-					       (quotient n 256)
+                  (cdr stack)
-					       (modulo n 256))))))
+                  (+ addr (byte-length elt))))
-	  (loop (cons bytes result)
+           ((symbol? (car (last-pair elt)))
-		(cdr stack)
+            ;; not yet code because labels needed to be resolved
-		(+ addr (u8vector-length bytes)))))))
+            (let* ((head (list-head elt (1- (length elt))))
+                   (label-addr (assq-ref label-alist (car (last-pair elt))))
+                   (offset (- label-addr (+ addr (byte-length elt))))
+                   (n (if (< offset 0) (+ offset 65536) offset)))
+              (loop (cons (code->bytes
+                           (append head (list (quotient n 256) (modulo n 256))))
+                          result)
+                    (cdr stack)
+                    (+ addr (byte-length elt)))))
+           (else (error "bad code" elt)))))))
 
 
 ;;;

module/system/vm/conv.scm

@@ -163,7 +163,7 @@
 				(l '() (cons (pop) l)))
 			       ((= n 0) (cons* inst (reverse! l)))))))
 	    (values start code))
-	  #f))))
+	  (values #f #f)))))
 
 
 ;;;

module/system/vm/disasm.scm

@@ -71,23 +71,23 @@
 
 (define (disassemble-bytecode bytes objs)
   (let ((decode (make-byte-decoder bytes))
-	(programs '()))
+        (programs '()))
-    (do ((addr+code (decode) (decode)))
+    (define (lp addr code)
-	((not addr+code) (newline))
+      (pmatch code
-      (receive (addr code) addr+code
+       (#f (newline))
-	(pmatch code
+       ((load-program ,x)
-	  ((load-program ,x)
+        (let ((sym (gensym "")))
-	   (let ((sym (gensym "")))
+          (set! programs (acons sym x programs))
-	     (set! programs (acons sym x programs))
+          (print-info addr (format #f "(load-program #~A)" sym) #f)))
-	     (print-info addr (format #f "(load-program #~A)" sym) #f)))
+       (else
-	  (else
+        (print-info addr (list->info code)
-	   (let ((info (list->info code))
+                    (original-value addr code objs))))
-		 (extra (original-value addr code objs)))
+      (if code (call-with-values decode lp)))
-	     (print-info addr info extra))))))
+    (call-with-values decode lp)
     (for-each (lambda (sym+bytes)
-		(format #t "Bytecode #~A:\n\n" (car sym+bytes))
+                (format #t "Bytecode #~A:\n\n" (car sym+bytes))
-		(disassemble-bytecode (cdr sym+bytes) #f))
+                (disassemble-bytecode (cdr sym+bytes) #f))
-	      (reverse! programs))))
+              (reverse! programs))))
 
 (define (disassemble-objects objs)
   (display "Objects:\n\n")
@@ -178,6 +178,9 @@
 	       ((make-false) "#f")
 	       ((object-ref)
 		(if objs (object->string (vector-ref objs (car args))) #f))
+               ((mv-call)
+                (let ((offset (+ (* (caddr code) 256) (cadddr code))))
+                  (format #f "MV -> ~A" (+ addr offset 4))))
 	       (else #f)))))))
 
 (define (list->info list)

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) 5)
+    (and (= (uniform-vector-length code) 6)
-         (= (uniform-vector-ref code 4)
+         (= (uniform-vector-ref code 5)
             (instruction->opcode 'halt)))))
 
 (define (make-frame-chain frame addr)