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

Fix contification bugs

Browse source 
* module/language/cps/contification.scm (compute-contification): Rewrite
  to avoid mutating the DFG and the function while we are rewriting.
  Instead we compute a contification, and if it is not empty, we apply
  it and loop.
This commit is contained in:
Andy Wingo 2013-10-21 22:24:18 +02:00
parent e92e0bbe9c
commit 0620d6b4d2
1 changed files with 216 additions and 171 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -38,66 +38,22 @@
#:use-module (language rtl) #:use-module (language rtl)
#:export (contify)) #:export (contify))
(define (contify fun) (define (compute-contification fun)
(let* ((dfg (compute-dfg fun)) (let* ((dfg (compute-dfg fun))
(cont-table (dfg-cont-table dfg)) (cont-table (dfg-cont-table dfg))
(call-substs '()) (call-substs '())
(cont-substs '()) (cont-substs '())
(pending-contifications (make-hash-table))) (fun-elisions '())
(cont-splices (make-hash-table)))
(define (subst-call! sym arities body-ks) (define (subst-call! sym arities body-ks)
(set! call-substs (acons sym (map cons arities body-ks) call-substs))) (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(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 (elide-function! k)
(match (assq-ref cont-substs k) (set! fun-elisions (cons k fun-elisions)))
(#f k) (define (splice-conts! scope conts)
(k (lookup-return-cont k)))) (hashq-set! cont-splices scope
(append conts (hashq-ref cont-splices scope '()))))
(define (add-pending-contifications! scope conts)
(for-each (match-lambda
(($ $cont k)
(lift-definition! k scope dfg)))
conts)
(hashq-set! pending-contifications scope
(append conts (hashq-ref pending-contifications scope '()))))
(define (flush-pending-contifications term-k term)
(match (hashq-ref pending-contifications term-k)
(#f term)
((cont ...)
(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)
,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)
(lambda (clauses)
(let lp ((clauses clauses))
(match clauses
(() (error "invalid contification"))
(((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args))
(build-cps-term
($continue (lookup-return-cont k)
($values args)))
(lp clauses)))
((_ . clauses) (lp clauses)))))))
;; If K is a continuation that binds one variable, and it has only ;; If K is a continuation that binds one variable, and it has only
;; one predecessor, return that variable. ;; one predecessor, return that variable.
@ -138,7 +94,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)
(lookup-return-cont k))) k))
(_ #f))) (_ #f)))
(and (and
@ -162,133 +118,222 @@
;; We have a common continuation. High fives! ;; We have a common continuation. High fives!
;; ;;
;; (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) (and=>
term-k (if (continuation-bound-in? k term-k dfg)
(pk 'contify-from term-k 'at k (lookup-block-scope k dfg))))) ;; The common continuation is in scope at the
;; (2) Mark all SYMs for replacement in calls, and ;; function definition; yay.
;; mark the tail continuations for replacement by K. term-k
(for-each (lambda (sym tail arities bodies) ;; The common continuation is not in scope at the
(match bodies ;; function definition. Boo.
((($ $cont body-k) ...) (let ((scope (lookup-block-scope k dfg)))
(subst-call! sym arities body-k))) (match (lookup-cont scope cont-table)
(subst-return! tail k)) ;; The common continuation was the tail of some
syms tails arities bodies) ;; function inside the letrec body.
;; (3) Mutate the DFG to reflect the new scope of the (($ $kentry self tail clauses)
;; continuations, and arrange for the continuations to (match clauses
;; be spliced into their new scope. ;; If that function has just one clause,
(add-pending-contifications! scope (concatenate bodies)) ;; contify into that clause. Otherwise
k))))) ;; bail.
((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
kargs)
(_ #f)))
;; Otherwise the common continuation is in some
;; scope we can add to via $letk.
(cont scope))))
(lambda (scope)
;; (2) Mark all SYMs for replacement in calls, and
;; mark the tail continuations for replacement by K.
(for-each (lambda (sym tail arities bodies)
(match bodies
((($ $cont body-k) ...)
(subst-call! sym arities body-k)))
(subst-return! tail k))
syms tails arities bodies)
;; (3) Arrange for the continuations to be spliced
;; into their new scope.
(splice-conts! scope (concatenate bodies))
k))))))
(define (visit-fun term) (define (visit-fun term)
(rewrite-cps-exp term (match term
(($ $fun meta free body) (($ $fun meta free body)
($fun meta free ,(visit-cont body))))) (visit-cont body))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (match cont
(($ $cont sym src (($ $cont sym src ($ $kargs _ _ body))
($ $kargs (name) (and sym (? (cut assq <> call-substs))) (visit-term body sym))
body))
(sym src ($kargs () () ,(visit-term body sym))))
(($ $cont sym src ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body sym))))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym src ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses)))) (for-each visit-cont clauses))
(($ $cont sym src ($ $kclause arity body)) (($ $cont sym src ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body)))) (visit-cont body))
(($ $cont) (($ $cont)
,cont))) #t)))
(define (visit-term term term-k) (define (visit-term term term-k)
(flush-pending-contifications (match term
term-k (($ $letk conts body)
(match term (for-each visit-cont conts)
(($ $letk conts body) (visit-term body term-k))
;; Visit the body first, so we visit depth-first. (($ $letrec names syms funs body)
(let lp ((body (visit-term body term-k))) (define (split-components nsf)
;; Because we attach contified functions on a particular ;; FIXME: Compute strongly-connected components. Currently
;; term-k, and one term-k can correspond to an arbitrarily ;; we just put non-recursive functions in their own
;; nested sequence of $letrec and $letk instances, normalize ;; components, and lump everything else in the remaining
;; so that all continuations are bound by one $letk -- ;; component.
;; guaranteeing that they are in the same scope. (define (recursive? k)
(rewrite-cps-term body (or-map (cut variable-free-in? <> k dfg) syms))
(($ $letrec names syms funs body) (let lp ((nsf nsf) (rec '()))
($letrec names syms funs ,(lp body))) (match nsf
(($ $letk conts* body) (()
($letk ,(append conts* (map visit-cont conts)) (if (null? rec)
,body)) '()
(body (list rec)))
($letk ,(map visit-cont conts) (((and elt (n s ($ $fun meta free ($ $cont kentry))))
,body))))) . nsf)
(($ $letrec names syms funs body) (if (recursive? kentry)
(define (split-components nsf) (lp nsf (cons elt rec))
;; FIXME: Compute strongly-connected components. Currently (cons (list elt) (lp nsf rec)))))))
;; we just put non-recursive functions in their own (define (visit-component component)
;; components, and lump everything else in the remaining (match component
;; component. (((name sym fun) ...)
(define (recursive? k) (match fun
(or-map (cut variable-free-in? <> k dfg) syms)) ((($ $fun meta free
(let lp ((nsf nsf) (rec '())) ($ $cont fun-k _
(match nsf ($ $kentry self
(() ($ $cont tail-k _ ($ $ktail))
(if (null? rec) (($ $cont _ _ ($ $kclause arity body))
'() ...))))
(list rec))) ...)
(((and elt (n s ($ $fun meta free ($ $cont kentry)))) (unless (contify-funs term-k sym self tail-k arity body)
. nsf) (for-each visit-fun fun)))))))
(if (recursive? kentry) (visit-term body term-k)
(lp nsf (cons elt rec)) (for-each visit-component
(cons (list elt) (lp nsf rec))))))) (split-components (map list names syms funs))))
(define (visit-components components) (($ $continue k exp)
(match components (match exp
(() (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 (if (and=> (bound-symbol k)
($ $cont tail-k _ ($ $ktail)) (lambda (sym)
(($ $cont _ _ ($ $kclause arity body)) (contify-fun term-k sym self tail-k arity body)))
...)))) (elide-function! k)
...) (visit-fun exp)))
(if (contify-funs term-k sym self tail-k arity body) (_ #t)))))
(visit-components components)
(build-cps-term
($letrec name sym (map visit-fun fun)
,(visit-components components)))))))))
(visit-components (split-components (map list names syms funs))))
(($ $continue k exp)
(let ((k* (lookup-return-cont k)))
(define (default)
(rewrite-cps-term exp
(($ $fun) ($continue k* ,(visit-fun exp)))
(($ $primcall 'return (val))
,(if (eq? k k*)
(build-cps-term ($continue k* ,exp))
(build-cps-term ($continue k* ($values (val))))))
(($ $primcall 'return-values vals)
,(if (eq? k k*)
(build-cps-term ($continue k* ,exp))
(build-cps-term ($continue k* ($values vals)))))
(_ ($continue k* ,exp))))
(match exp
(($ $fun meta free
($ $cont fun-k _
($ $kentry self
($ $cont tail-k _ ($ $ktail))
(($ $cont _ _ ($ $kclause arity body)) ...))))
(if (and=> (bound-symbol k*)
(lambda (sym)
(contify-fun term-k sym self tail-k arity body)))
(build-cps-term
($continue k* ($values ())))
(default)))
(($ $call proc args)
(or (contify-call proc args)
(default)))
(_ (default))))))))
(let ((fun (visit-fun fun))) (visit-fun fun)
(report-pending-contifications) (values call-substs cont-substs fun-elisions cont-splices)))
(define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
(define (contify-call proc args)
(and=> (assq-ref call-substs proc)
(lambda (clauses)
(let lp ((clauses clauses))
(match clauses
(() (error "invalid contification"))
(((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args))
(build-cps-term
($continue (lookup-return-cont k)
($values args)))
(lp clauses)))
((_ . clauses) (lp clauses)))))))
(define (lookup-return-cont k)
(match (assq-ref cont-substs k)
(#f k)
(k (lookup-return-cont k))))
(define (splice-continuations term-k term)
(match (hashq-ref cont-splices term-k)
(#f term)
((cont ...)
(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 (visit-fun term)
(rewrite-cps-exp term
(($ $fun meta free body)
($fun meta free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym src
($ $kargs (name) (and sym (? (cut assq <> call-substs)))
body))
(sym src ($kargs () () ,(visit-term body sym))))
(($ $cont sym src ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body sym))))
(($ $cont sym src ($ $kentry self tail clauses))
(sym src ($kentry self ,tail ,(map visit-cont clauses))))
(($ $cont sym src ($ $kclause arity body))
(sym src ($kclause ,arity ,(visit-cont body))))
(($ $cont)
,cont)))
(define (visit-term term term-k)
(match term
(($ $letk conts body)
;; Visit the body first, so we rewrite depth-first.
(let lp ((body (visit-term body term-k)))
;; Because we attach contified functions on a particular
;; term-k, and one term-k can correspond to an arbitrarily
;; nested sequence of $letrec and $letk instances, normalize
;; so that all continuations are bound by one $letk --
;; guaranteeing that they are in the same scope.
(rewrite-cps-term body
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
($letk ,(append conts* (map visit-cont conts))
,body))
(body
($letk ,(map visit-cont conts)
,body)))))
(($ $letrec names syms funs body)
(rewrite-cps-term (filter (match-lambda
((n s f) (not (assq s call-substs))))
(map list names syms funs))
(((names syms funs) ...)
($letrec names syms (map visit-fun funs)
,(visit-term body term-k)))))
(($ $continue k exp)
(splice-continuations
term-k
(let ((k* (lookup-return-cont k)))
(define (default)
(rewrite-cps-term exp
(($ $fun) ($continue k* ,(visit-fun exp)))
(($ $primcall 'return (val))
,(if (eq? k k*)
(build-cps-term ($continue k* ,exp))
(build-cps-term ($continue k* ($values (val))))))
(($ $primcall 'return-values vals)
,(if (eq? k k*)
(build-cps-term ($continue k* ,exp))
(build-cps-term ($continue k* ($values vals)))))
(_ ($continue k* ,exp))))
(match exp
(($ $fun)
(if (memq k fun-elisions)
(build-cps-term
($continue k* ($values ())))
(default)))
(($ $call proc args)
(or (contify-call proc args)
(default)))
(_ (default))))))))
(visit-fun fun))
(define (contify fun)
(call-with-values (lambda () (compute-contification fun))
(lambda (call-substs cont-substs fun-elisions cont-splices)
(if (null? call-substs) (if (null? call-substs)
fun fun
;; Iterate to fixed point. ;; Iterate to fixed point.
(contify fun))))) (contify
(apply-contification fun call-substs cont-substs fun-elisions cont-splices))))))