mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 00:40:20 +02:00
Code Activity

More robust contification

Browse source 
* module/language/cps/contification.scm (contify): It could be that
  visiting pending contifications could enqueue more contifications, so
  iterate to a fixed point.  Signal an error if there are any pending
  contifications at the end of an iteration.
This commit is contained in:
Andy Wingo 2013-10-21 16:59:42 +02:00
parent c8ad7426e2
commit e92e0bbe9c
1 changed files with 97 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

39
module/language/cps/contification.scm
View file

@ -59,17 +59,31 @@
(lift-definition! k scope dfg)))
conts)
(hashq-set! pending-contifications scope
(append conts
(hashq-ref pending-contifications scope '()))))
(define (finish-pending-contifications call term-k)
(append conts (hashq-ref pending-contifications scope '()))))
(define (flush-pending-contifications term-k term)
(match (hashq-ref pending-contifications term-k)
(#f call)
(#f term)
((cont ...)
;; Catch any possible double-contification bug.
(hashq-set! pending-contifications term-k 'poison)
(build-cps-term
(hashq-remove! pending-contifications term-k)
;; Visiting the pending continuations can enqueue more
;; contifications in this same scope, so iterate until there
;; are none left.
(flush-pending-contifications
term-k
(let lp ((term term))
(rewrite-cps-term term
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
($letk ,(append conts* (map visit-cont cont))
,body))
(body
($letk ,(map visit-cont cont)
,call)))))
,body))))))))
(define (report-pending-contifications)
(hash-for-each (lambda (sym pending)
(error 'pending-contification sym pending))
pending-contifications))
(define (contify-call proc args)
(and=> (assq-ref call-substs proc)
@ -150,7 +164,7 @@
;; (1) Find the scope at which to contify.
(let ((scope (if (continuation-bound-in? k term-k dfg)
term-k
(lookup-def k dfg))))
(pk 'contify-from term-k 'at k (lookup-block-scope k dfg)))))
;; (2) Mark all SYMs for replacement in calls, and
;; mark the tail continuations for replacement by K.
(for-each (lambda (sym tail arities bodies)
@ -184,6 +198,8 @@
(($ $cont)
,cont)))
(define (visit-term term term-k)
(flush-pending-contifications
term-k
(match term
(($ $letk conts body)
;; Visit the body first, so we visit depth-first.
@ -253,7 +269,6 @@
(build-cps-term ($continue k* ,exp))
(build-cps-term ($continue k* ($values vals)))))
(_ ($continue k* ,exp))))
(finish-pending-contifications
(match exp
(($ $fun meta free
($ $cont fun-k _
@ -269,10 +284,10 @@
(($ $call proc args)
(or (contify-call proc args)
(default)))
(_ (default)))
term-k)))))
(_ (default))))))))
(let ((fun (visit-fun fun)))
(report-pending-contifications)
(if (null? call-substs)
fun
;; Iterate to fixed point.