From 05c51bcff5604d520c9335cfbf91eb4bf84003ed Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 3 Mar 2010 20:57:18 +0100
Subject: [PATCH] use anonymous mv-bind in compile-glil.scm; fix abort
 compilation bug

* module/language/tree-il/compile-glil.scm (flatten): Change to use the
  anonymous <glil-mv-bind> form when truncating to 0 or 1 values. In
  those cases, remove the <glil-unbind> statements. As a side effect,
  fixes compilation of abort in a "values" context.

  Thanks to Tristan Colgate for the bug report.

* test-suite/tests/tree-il.test: Update to expect anonymous mv-bind.
---
 module/language/tree-il/compile-glil.scm | 8 +++-----
 test-suite/tests/tree-il.test            | 6 +++---
 2 files changed, 6 insertions(+), 8 deletions(-)

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 7030430f0..197daf2a0 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -496,8 +496,7 @@
                        (emit-code #f (make-glil-call 'drop 1))
                        (emit-branch #f 'br (or RA POST))
                        (emit-label MV)
-                       (emit-code #f (make-glil-mv-bind '() #f))
-                       (emit-code #f (make-glil-unbind))
+                       (emit-code #f (make-glil-mv-bind 0 #f))
                        (if RA
                            (emit-branch #f 'br RA)
                            (emit-label POST)))))))))
@@ -1124,12 +1123,11 @@
           (emit-code #f (make-glil-call 'return/nvalues 1)))
          ((drop)
           ;; Drop all values and goto RA, or otherwise fall through.
-          (emit-code #f (make-glil-mv-bind '() #f))
-          (emit-code #f (make-glil-unbind))
+          (emit-code #f (make-glil-mv-bind 0 #f))
           (if RA (emit-branch #f 'br RA)))
          ((push)
           ;; Truncate to one value.
-          (emit-code #f (make-glil-mv-bind '(val) #f)))
+          (emit-code #f (make-glil-mv-bind 1 #f)))
          ((vals)
           ;; Go to MVRA.
           (emit-branch #f 'br MVRA)))))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 539540c6d..a3023f3c2 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -74,7 +74,7 @@
    (begin (apply (toplevel foo) (const 1)) (void))
    (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2)
-            (label ,l3) (mv-bind () #f) (unbind)
+            (label ,l3) (mv-bind 0 #f)
             (label ,l4)
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
@@ -461,7 +461,7 @@
    (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
-            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
             (label ,l4)
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))
@@ -480,7 +480,7 @@
    (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
    (program () (std-prelude 0 0 #f) (label _)
             (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
-            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
             (label ,l4)
             (void) (call return 1))
    (and (eq? l1 l3) (eq? l2 l4)))