allow primcall ops to push 0 values

* libguile/objcodes.c (OBJCODE_COOKIE): Bump the objcode cookie. We'll
  be doing this on incompatible changes until 2.0.

* libguile/vm-i-scheme.c (set_car, set_cdr, slot_set): These
  instructions don't have natural return values -- so declare them that
  way, that they push 0 values.

* module/language/tree-il/compile-glil.scm (flatten): When compiling
  primitive calls, check `(instruction-pushes op)' to see how many
  values that instruction will push, and do something appropriate,
  instead of just assuming that all primcall ops push 1 value.

diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 6b69fb7..fc59c09 100644 (file)
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -34,7 +34,7 @@
 #include "objcodes.h"
 
 /* nb, the length of the header should be a multiple of 8 bytes */
-#define OBJCODE_COOKIE "GOOF-0.5"
+#define OBJCODE_COOKIE "GOOF-0.6"
 
 \f
 /*

diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 02139c0..4fc026c 100644 (file)
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -131,20 +131,24 @@ VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
   RETURN (SCM_CDR (x));
 }
 
-VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2)
+VM_DEFINE_INSTRUCTION (93, set_car, "set-car!", 0, 2, 0)
 {
-  ARGS2 (x, y);
+  SCM x, y;
+  POP (y);
+  POP (x);
   VM_VALIDATE_CONS (x);
   SCM_SETCAR (x, y);
-  RETURN (SCM_UNSPECIFIED);
+  NEXT;
 }
 
-VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2)
+VM_DEFINE_INSTRUCTION (94, set_cdr, "set-cdr!", 0, 2, 0)
 {
-  ARGS2 (x, y);
+  SCM x, y;
+  POP (y);
+  POP (x);
   VM_VALIDATE_CONS (x);
   SCM_SETCDR (x, y);
-  RETURN (SCM_UNSPECIFIED);
+  NEXT;
 }
 
 \f
@@ -263,13 +267,16 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
   RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
 }
 
-VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3)
+VM_DEFINE_INSTRUCTION (108, slot_set, "slot-set", 0, 3, 0)
 {
+  SCM instance, idx, val;
   size_t slot;
-  ARGS3 (instance, idx, val);
+  POP (val);
+  POP (idx);
+  POP (instance);
   slot = SCM_I_INUM (idx);
   SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
-  RETURN (SCM_UNSPECIFIED);
+  NEXT;
 }
 
 /*

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 6dade35..a75843d 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -22,6 +22,7 @@
   #:use-module (system base syntax)
   #:use-module (ice-9 receive)
   #:use-module (language glil)
+  #:use-module (system vm instruction)
   #:use-module (language tree-il)
   #:use-module (language tree-il optimize)
   #:use-module (language tree-il analyze)
@@ -305,10 +306,20 @@
          => (lambda (op)
               (for-each comp-push args)
               (emit-code src (make-glil-call op (length args)))
-              (case context
-                ((tail) (emit-code #f (make-glil-call 'return 1)))
-                ((drop) (emit-code #f (make-glil-call 'drop 1))))))
-
+              (case (instruction-pushes op)
+                ((0)
+                 (case context
+                   ((tail) (emit-code #f (make-glil-void))
+                           (emit-code #f (make-glil-call 'return 1)))
+                   ((push vals) (emit-code #f (make-glil-void)))))
+                ((1)
+                 (case context
+                   ((tail) (emit-code #f (make-glil-call 'return 1)))
+                   ((drop) (emit-code #f (make-glil-call 'drop 1)))))
+                (else
+                 (error "bad primitive op: too many pushes"
+                        op (instruction-pushes op))))))
+        
         (else
          (comp-push proc)
          (for-each comp-push args)