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

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

@ -59,17 +59,31 @@
(lift-definition! k scope dfg))) (lift-definition! k scope dfg)))
conts) conts)
(hashq-set! pending-contifications scope (hashq-set! pending-contifications scope
(append conts (append conts (hashq-ref pending-contifications scope '()))))
(hashq-ref pending-contifications scope '())))) (define (flush-pending-contifications term-k term)
(define (finish-pending-contifications call term-k)
(match (hashq-ref pending-contifications term-k) (match (hashq-ref pending-contifications term-k)
(#f call) (#f term)
((cont ...) ((cont ...)
;; Catch any possible double-contification bug. (hashq-remove! pending-contifications term-k)
(hashq-set! pending-contifications term-k 'poison) ;; Visiting the pending continuations can enqueue more
(build-cps-term ;; contifications in this same scope, so iterate until there
($letk ,(map visit-cont cont) ;; are none left.
,call))))) (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)
,body))))))))
(define (report-pending-contifications)
(hash-for-each (lambda (sym pending)
(error 'pending-contification sym pending))
pending-contifications))
(define (contify-call proc args) (define (contify-call proc args)
(and=> (assq-ref call-substs proc) (and=> (assq-ref call-substs proc)
@ -150,7 +164,7 @@
;; (1) Find the scope at which to contify. ;; (1) Find the scope at which to contify.
(let ((scope (if (continuation-bound-in? k term-k dfg) (let ((scope (if (continuation-bound-in? k term-k dfg)
term-k 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 ;; (2) Mark all SYMs for replacement in calls, and
;; mark the tail continuations for replacement by K. ;; mark the tail continuations for replacement by K.
(for-each (lambda (sym tail arities bodies) (for-each (lambda (sym tail arities bodies)
@ -184,76 +198,77 @@
(($ $cont) (($ $cont)
,cont))) ,cont)))
(define (visit-term term term-k) (define (visit-term term term-k)
(match term (flush-pending-contifications
(($ $letk conts body) term-k
;; Visit the body first, so we visit depth-first. (match term
(let lp ((body (visit-term body term-k))) (($ $letk conts body)
;; Because we attach contified functions on a particular ;; Visit the body first, so we visit depth-first.
;; term-k, and one term-k can correspond to an arbitrarily (let lp ((body (visit-term body term-k)))
;; nested sequence of $letrec and $letk instances, normalize ;; Because we attach contified functions on a particular
;; so that all continuations are bound by one $letk -- ;; term-k, and one term-k can correspond to an arbitrarily
;; guaranteeing that they are in the same scope. ;; nested sequence of $letrec and $letk instances, normalize
(rewrite-cps-term body ;; so that all continuations are bound by one $letk --
(($ $letrec names syms funs body) ;; guaranteeing that they are in the same scope.
($letrec names syms funs ,(lp body))) (rewrite-cps-term body
(($ $letk conts* body) (($ $letrec names syms funs body)
($letk ,(append conts* (map visit-cont conts)) ($letrec names syms funs ,(lp body)))
,body)) (($ $letk conts* body)
(body ($letk ,(append conts* (map visit-cont conts))
($letk ,(map visit-cont conts) ,body))
,body))))) (body
(($ $letrec names syms funs body) ($letk ,(map visit-cont conts)
(define (split-components nsf) ,body)))))
;; FIXME: Compute strongly-connected components. Currently (($ $letrec names syms funs body)
;; we just put non-recursive functions in their own (define (split-components nsf)
;; components, and lump everything else in the remaining ;; FIXME: Compute strongly-connected components. Currently
;; component. ;; we just put non-recursive functions in their own
(define (recursive? k) ;; components, and lump everything else in the remaining
(or-map (cut variable-free-in? <> k dfg) syms)) ;; component.
(let lp ((nsf nsf) (rec '())) (define (recursive? k)
(match nsf (or-map (cut variable-free-in? <> k dfg) syms))
(() (let lp ((nsf nsf) (rec '()))
(if (null? rec) (match nsf
'() (()
(list rec))) (if (null? rec)
(((and elt (n s ($ $fun meta free ($ $cont kentry)))) '()
. nsf) (list rec)))
(if (recursive? kentry) (((and elt (n s ($ $fun meta free ($ $cont kentry))))
(lp nsf (cons elt rec)) . nsf)
(cons (list elt) (lp nsf rec))))))) (if (recursive? kentry)
(define (visit-components components) (lp nsf (cons elt rec))
(match components (cons (list elt) (lp nsf rec)))))))
(() (visit-term body term-k)) (define (visit-components components)
((((name sym fun) ...) . components) (match components
(match fun (() (visit-term body term-k))
((($ $fun meta free ((((name sym fun) ...) . components)
($ $cont fun-k _ (match fun
($ $kentry self ((($ $fun meta free
($ $cont tail-k _ ($ $ktail)) ($ $cont fun-k _
(($ $cont _ _ ($ $kclause arity body)) ($ $kentry self
...)))) ($ $cont tail-k _ ($ $ktail))
...) (($ $cont _ _ ($ $kclause arity body))
(if (contify-funs term-k sym self tail-k arity body) ...))))
(visit-components components) ...)
(build-cps-term (if (contify-funs term-k sym self tail-k arity body)
($letrec name sym (map visit-fun fun) (visit-components components)
,(visit-components components))))))))) (build-cps-term
(visit-components (split-components (map list names syms funs)))) ($letrec name sym (map visit-fun fun)
(($ $continue k exp) ,(visit-components components)))))))))
(let ((k* (lookup-return-cont k))) (visit-components (split-components (map list names syms funs))))
(define (default) (($ $continue k exp)
(rewrite-cps-term exp (let ((k* (lookup-return-cont k)))
(($ $fun) ($continue k* ,(visit-fun exp))) (define (default)
(($ $primcall 'return (val)) (rewrite-cps-term exp
,(if (eq? k k*) (($ $fun) ($continue k* ,(visit-fun exp)))
(build-cps-term ($continue k* ,exp)) (($ $primcall 'return (val))
(build-cps-term ($continue k* ($values (val)))))) ,(if (eq? k k*)
(($ $primcall 'return-values vals) (build-cps-term ($continue k* ,exp))
,(if (eq? k k*) (build-cps-term ($continue k* ($values (val))))))
(build-cps-term ($continue k* ,exp)) (($ $primcall 'return-values vals)
(build-cps-term ($continue k* ($values vals))))) ,(if (eq? k k*)
(_ ($continue k* ,exp)))) (build-cps-term ($continue k* ,exp))
(finish-pending-contifications (build-cps-term ($continue k* ($values vals)))))
(_ ($continue k* ,exp))))
(match exp (match exp
(($ $fun meta free (($ $fun meta free
($ $cont fun-k _ ($ $cont fun-k _
@ -269,10 +284,10 @@
(($ $call proc args) (($ $call proc args)
(or (contify-call proc args) (or (contify-call proc args)
(default))) (default)))
(_ (default))) (_ (default))))))))
term-k)))))
(let ((fun (visit-fun fun))) (let ((fun (visit-fun fun)))
(report-pending-contifications)
(if (null? call-substs) (if (null? call-substs)
fun fun
;; Iterate to fixed point. ;; Iterate to fixed point.