Fix bad return shuffles for multiply-used $kreceive conts

* module/language/cps2/reify-primitives.scm (uniquify-receive):
  (reify-primitives): Ensure that $kreceive conts can have only one
  predecessor.  Otherwise return shuffles are incorrectly allocated.

1 files changed, 22 insertions, 0 deletions

diff --git a/module/language/cps2/reify-primitives.scm b/module/language/cps2/reify-primitives.scm
index b5f62d456..55409bfc1 100644
--- a/module/language/cps2/reify-primitives.scm
+++ b/module/language/cps2/reify-primitives.scm
@@ -108,6 +108,16 @@
     (letk kclause ($kclause ('() '() #f '() #f) kbody #f))
     kclause))
 
+;; A $kreceive continuation should have only one predecessor.
+(define (uniquify-receive cps k)
+  (match (intmap-ref cps k)
+    (($ $kreceive ($ $arity req () rest () #f) kargs)
+     (with-cps cps
+       (letk k ($kreceive req rest kargs))
+       k))
+    (_
+     (with-cps cps k))))
+
 (define (reify-primitives cps)
   (define (visit-cont label cont cps)
     (define (resolve-prim cps name k src)
@@ -123,6 +133,7 @@
          (setk label ($kfun src meta self tail clause))))
       (($ $kargs names vars ($ $continue k src ($ $prim name)))
        (with-cps cps
+         (let$ k (uniquify-receive k))
          (let$ body (resolve-prim name k src))
          (setk label ($kargs names vars ,body))))
       (($ $kargs names vars
@@ -135,10 +146,21 @@
            cps
            (with-cps cps
              (letv proc)
+             (let$ k (uniquify-receive k))
              (letk kproc ($kargs ('proc) (proc)
                            ($continue k src ($call proc args))))
              (let$ body (resolve-prim name kproc src))
              (setk label ($kargs names vars ,body)))))
+      (($ $kargs names vars ($ $continue k src ($ $call proc args)))
+       (with-cps cps
+         (let$ k (uniquify-receive k))
+         (setk label ($kargs names vars
+                       ($continue k src ($call proc args))))))
+      (($ $kargs names vars ($ $continue k src ($ $callk k* proc args)))
+       (with-cps cps
+         (let$ k (uniquify-receive k))
+         (setk label ($kargs names vars
+                       ($continue k src ($callk k* proc args))))))
       (_ cps)))
 
   (with-fresh-name-state cps