guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 07/13: Fix bad return shuffles for multiply-used $krecei


From: Andy Wingo
Subject: [Guile-commits] 07/13: Fix bad return shuffles for multiply-used $kreceive conts
Date: Wed, 22 Jul 2015 15:32:28 +0000

wingo pushed a commit to branch master
in repository guile.

commit ff2beb186ef52286214ccd2e52c6262c84c3035f
Author: Andy Wingo <address@hidden>
Date:   Tue Jul 21 17:48:22 2015 +0200

    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.
---
 module/language/cps2/reify-primitives.scm |   22 ++++++++++++++++++++++
 1 files changed, 22 insertions(+), 0 deletions(-)

diff --git a/module/language/cps2/reify-primitives.scm 
b/module/language/cps2/reify-primitives.scm
index b5f62d4..55409bf 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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]