mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
Fix nested contification bugs
* module/language/cps/contification.scm (contify): Exhaustively replace contified tail continuations, to fix a bug in nested tail-recursive contifications. Likewise, call lookup-return-cont when searching for common return continuations.
This commit is contained in:
parent
c648869346
commit
fea115c33f
1 changed files with 6 additions and 3 deletions
|
@ -49,7 +49,9 @@
|
||||||
(define (subst-return! old-tail new-tail)
|
(define (subst-return! old-tail new-tail)
|
||||||
(set! cont-substs (acons old-tail new-tail cont-substs)))
|
(set! cont-substs (acons old-tail new-tail cont-substs)))
|
||||||
(define (lookup-return-cont k)
|
(define (lookup-return-cont k)
|
||||||
(or (assq-ref cont-substs k) k))
|
(match (assq-ref cont-substs k)
|
||||||
|
(#f k)
|
||||||
|
(k (lookup-return-cont k))))
|
||||||
|
|
||||||
(define (add-pending-contifications! scope conts)
|
(define (add-pending-contifications! scope conts)
|
||||||
(for-each (match-lambda
|
(for-each (match-lambda
|
||||||
|
@ -78,7 +80,8 @@
|
||||||
(((($ $arity req () #f () #f) . k) . clauses)
|
(((($ $arity req () #f () #f) . k) . clauses)
|
||||||
(if (= (length req) (length args))
|
(if (= (length req) (length args))
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($continue k ($values args)))
|
($continue (lookup-return-cont k)
|
||||||
|
($values args)))
|
||||||
(lp clauses)))
|
(lp clauses)))
|
||||||
((_ . clauses) (lp clauses)))))))
|
((_ . clauses) (lp clauses)))))))
|
||||||
|
|
||||||
|
@ -121,7 +124,7 @@
|
||||||
(match (find-call (lookup-cont use cont-table))
|
(match (find-call (lookup-cont use cont-table))
|
||||||
(($ $continue k ($ $call proc* args))
|
(($ $continue k ($ $call proc* args))
|
||||||
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
|
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
|
||||||
k))
|
(lookup-return-cont k)))
|
||||||
(_ #f)))
|
(_ #f)))
|
||||||
|
|
||||||
(and
|
(and
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue