mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

Fix contification of non-recursive closures

Browse source 
* module/language/cps/contification.scm (compute-contification): When
  eliding let-bound functions, also record the cont that declares the
  function.
  (apply-contification): Instead of reifying ($values ()) gotos instead
  of the elided function, inline the body that binds the function
  directly.  This ensures that the function gets contified in its own
  scope.
This commit is contained in:
Andy Wingo 2013-11-01 18:22:58 +01:00
parent d258fcccee
commit b681671ede
1 changed files with 18 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -30,7 +30,7 @@
(define-module (language cps contification) (define-module (language cps contification)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (concatenate)) #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps dfg) #:use-module (language cps dfg)
@ -49,8 +49,8 @@
(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 (elide-function! k) (define (elide-function! k cont)
(set! fun-elisions (cons k fun-elisions))) (set! fun-elisions (acons k cont fun-elisions)))
(define (splice-conts! scope conts) (define (splice-conts! scope conts)
(hashq-set! cont-splices scope (hashq-set! cont-splices scope
(append conts (hashq-ref cont-splices scope '())))) (append conts (hashq-ref cont-splices scope '()))))
@ -230,7 +230,7 @@
(if (and=> (bound-symbol k) (if (and=> (bound-symbol k)
(lambda (sym) (lambda (sym)
(contify-fun term-k sym self tail-k arity body))) (contify-fun term-k sym self tail-k arity body)))
(elide-function! k) (elide-function! k (lookup-cont k cont-table))
(visit-fun exp))) (visit-fun exp)))
(_ #t))))) (_ #t)))))
@ -276,10 +276,10 @@
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms funs ,(lp body))) ($letrec names syms funs ,(lp body)))
(($ $letk conts* body) (($ $letk conts* body)
($letk ,(append conts* (map visit-cont cont)) ($letk ,(append conts* (filter-map visit-cont cont))
,body)) ,body))
(body (body
($letk ,(map visit-cont cont) ($letk ,(filter-map visit-cont cont)
,body))))))) ,body)))))))
(define (visit-fun term) (define (visit-fun term)
(rewrite-cps-exp term (rewrite-cps-exp term
@ -287,9 +287,9 @@
($fun meta free ,(visit-cont body))))) ($fun meta free ,(visit-cont body)))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont (and k (? (cut memq <> fun-elisions))) src (($ $cont (? (cut assq <> fun-elisions)))
($ $kargs (_) (_) body)) ;; This cont gets inlined in place of the $fun.
(k src ($kargs () () ,(visit-term body k)))) ,#f)
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym src ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body sym)))) (sym src ($kargs names syms ,(visit-term body sym))))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym src ($ $kentry self tail clauses))
@ -312,10 +312,10 @@
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
($letrec names syms funs ,(lp body))) ($letrec names syms funs ,(lp body)))
(($ $letk conts* body) (($ $letk conts* body)
($letk ,(append conts* (map visit-cont conts)) ($letk ,(append conts* (filter-map visit-cont conts))
,body)) ,body))
(body (body
($letk ,(map visit-cont conts) ($letk ,(filter-map visit-cont conts)
,body))))) ,body)))))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
(rewrite-cps-term (filter (match-lambda (rewrite-cps-term (filter (match-lambda
@ -329,10 +329,13 @@
term-k term-k
(match exp (match exp
(($ $fun) (($ $fun)
(if (memq k fun-elisions) (cond
(build-cps-term ((assq-ref fun-elisions k)
($continue k ($values ()))) => (match-lambda
(continue k (visit-fun exp)))) (($ $kargs (_) (_) body)
(visit-term body k))))
(else
(continue k (visit-fun exp)))))
(($ $call proc args) (($ $call proc args)
(or (contify-call proc args) (or (contify-call proc args)
(continue k exp))) (continue k exp)))