mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

CPS2 closure conversion bugfixes

Browse source 
* module/language/cps2/closure-conversion.scm
  (rewrite-shared-closure-calls): Fix to make shared closures call the
  right label.
  (closure-label): New helper.
  (prune-free-vars): If a shared closure is not well-known, don't use
  the alias optimization.
  (convert-one): Fix for shared closures with one not-well-known
  closure.
This commit is contained in:
Andy Wingo 2015-07-15 16:11:09 +02:00
parent e9e6da1902
commit 6cfb7afb61
1 changed files with 19 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

29
module/language/cps2/closure-conversion.scm
View file

@ -261,16 +261,16 @@ shared closures to use the appropriate 'self' variable, if possible."
($prompt escape? (subst tag) handler))))))))
(define (visit-exp label cps names vars k src exp)
(define (compute-env label bound self rec-bound env)
(define (add-bound-var bound env)
(define (compute-env label bound self rec-bound rec-labels env)
(define (add-bound-var bound label env)
(intmap-add env bound (cons self label) (lambda (old new) new)))
(if (intmap-ref shared label (lambda (_) #f))
;; Within a function with a shared closure, rewrite
;; references to bound vars to use the "self" var.
(fold add-bound-var env rec-bound)
(fold add-bound-var env rec-bound rec-labels)
;; Otherwise be sure to use "self" references in any
;; closure.
(add-bound-var bound env)))
(add-bound-var bound label env)))
(match exp
(($ $fun label)
(rewrite-fun label cps env))
@ -279,7 +279,8 @@ shared closures to use the appropriate 'self' variable, if possible."
(match (intmap-ref cps label)
(($ $kfun src meta self)
(rewrite-fun label cps
(compute-env label var self vars env)))))
(compute-env label var self vars labels
env)))))
cps labels vars))
(_ (rename-exp label cps names vars k src exp))))
@ -395,11 +396,18 @@ references."
(define (eliminate-closure? label free-vars)
(eq? (intmap-ref free-vars label) empty-intset))
(define (closure-label label shared bound->label)
(cond
((intmap-ref shared label (lambda (_) #f))
=> (lambda (closure)
(intmap-ref bound->label closure)))
(else label)))
(define (closure-alias label well-known free-vars)
(and (intset-ref well-known label)
(trivial-intset (intmap-ref free-vars label))))
(define (prune-free-vars free-vars bound->label well-known)
(define (prune-free-vars free-vars bound->label well-known shared)
"Given the label->bound-var map @var{free-vars}, remove free variables
that are known functions with zero free variables, and replace
references to well-known functions with one free variable with that free
@ -412,7 +420,8 @@ variable, until we reach a fixed point on the free-vars map."
(cond
((eliminate-closure? label free-vars)
(intset-remove free var))
((closure-alias label well-known free-vars)
((closure-alias (closure-label label shared bound->label)
well-known free-vars)
=> (lambda (alias)
;; If VAR is free in LABEL, then ALIAS must
;; also be free because its definition must
@ -455,7 +464,7 @@ variable, until we reach a fixed point on the free-vars map."
(let* ((free (intmap-ref free-vars label))
(nfree (intset-count free))
(self-known? (well-known? label))
(self-known? (well-known? (closure-label label shared bound->label)))
(self (match (intmap-ref cps label) (($ $kfun _ _ self) self))))
(define (convert-arg cps var k)
"Convert one possibly free variable reference to a bound reference.
@ -642,7 +651,7 @@ bound to @var{var}, and continue to @var{k}."
(with-cps cps
($ (with-cps-constants ((false #f))
($ (have-closure false))))))
((and (well-known? label)
((and (well-known? (closure-label label shared bound->label))
(trivial-intset (intmap-ref free-vars label)))
;; Well-known closures with one free variable are
;; replaced at their use sites by uses of the one free
@ -810,7 +819,7 @@ and allocate and initialize flat closures."
kfun))
;; label -> free-var...
(free-vars (compute-free-vars cps kfun shared))
(free-vars (prune-free-vars free-vars bound->label well-known)))
(free-vars (prune-free-vars free-vars bound->label well-known shared)))
(let ((free-in-program (intmap-ref free-vars kfun)))
(unless (eq? empty-intset free-in-program)
(error "Expected no free vars in program" free-in-program)))