mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
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.
This commit is contained in:
parent
08cf30f2a0
commit
ff2beb186e
1 changed files with 22 additions and 0 deletions
|
@ -108,6 +108,16 @@
|
||||||
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
|
(letk kclause ($kclause ('() '() #f '() #f) kbody #f))
|
||||||
kclause))
|
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 (reify-primitives cps)
|
||||||
(define (visit-cont label cont cps)
|
(define (visit-cont label cont cps)
|
||||||
(define (resolve-prim cps name k src)
|
(define (resolve-prim cps name k src)
|
||||||
|
@ -123,6 +133,7 @@
|
||||||
(setk label ($kfun src meta self tail clause))))
|
(setk label ($kfun src meta self tail clause))))
|
||||||
(($ $kargs names vars ($ $continue k src ($ $prim name)))
|
(($ $kargs names vars ($ $continue k src ($ $prim name)))
|
||||||
(with-cps cps
|
(with-cps cps
|
||||||
|
(let$ k (uniquify-receive k))
|
||||||
(let$ body (resolve-prim name k src))
|
(let$ body (resolve-prim name k src))
|
||||||
(setk label ($kargs names vars ,body))))
|
(setk label ($kargs names vars ,body))))
|
||||||
(($ $kargs names vars
|
(($ $kargs names vars
|
||||||
|
@ -135,10 +146,21 @@
|
||||||
cps
|
cps
|
||||||
(with-cps cps
|
(with-cps cps
|
||||||
(letv proc)
|
(letv proc)
|
||||||
|
(let$ k (uniquify-receive k))
|
||||||
(letk kproc ($kargs ('proc) (proc)
|
(letk kproc ($kargs ('proc) (proc)
|
||||||
($continue k src ($call proc args))))
|
($continue k src ($call proc args))))
|
||||||
(let$ body (resolve-prim name kproc src))
|
(let$ body (resolve-prim name kproc src))
|
||||||
(setk label ($kargs names vars ,body)))))
|
(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)))
|
(_ cps)))
|
||||||
|
|
||||||
(with-fresh-name-state cps
|
(with-fresh-name-state cps
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue