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

Closure conversion eliminates self-references introduced by fixpoint

Browse source 
* module/language/cps/closure-conversion.scm (analyze-closures): Build a
  bound-vars set as well, to resolve introduced self-references.
  (prune-free-vars, convert-one): Arrange to eliminate self-references.
This commit is contained in:
Andy Wingo 2014-04-13 14:21:25 +02:00
parent 2920554a1e
commit fcb31f2953
1 changed files with 23 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

35
module/language/cps/closure-conversion.scm
View file

@ -45,11 +45,16 @@
(define (analyze-closures exp dfg) (define (analyze-closures exp dfg)
"Compute the set of free variables for all $fun instances in "Compute the set of free variables for all $fun instances in
@var{exp}." @var{exp}."
(let ((free-vars (make-hash-table)) (let ((bound-vars (make-hash-table))
(free-vars (make-hash-table))
(named-funs (make-hash-table)) (named-funs (make-hash-table))
(well-known-vars (make-bitvector (var-counter) #t))) (well-known-vars (make-bitvector (var-counter) #t)))
(define (add-named-fun! var cont) (define (add-named-fun! var cont)
(hashq-set! named-funs var cont)) (hashq-set! named-funs var cont)
(match cont
(($ $cont label ($ $kfun src meta self))
(unless (eq? var self)
(hashq-set! bound-vars label var)))))
(define (clear-well-known! var) (define (clear-well-known! var)
(bitvector-set! well-known-vars var #f)) (bitvector-set! well-known-vars var #f))
(define (compute-well-known-labels) (define (compute-well-known-labels)
@ -131,7 +136,7 @@
(let ((free (visit-cont exp '()))) (let ((free (visit-cont exp '())))
(unless (null? free) (unless (null? free)
(error "Expected no free vars in toplevel thunk" free exp)) (error "Expected no free vars in toplevel thunk" free exp))
(values free-vars named-funs (compute-well-known-labels))))) (values bound-vars free-vars named-funs (compute-well-known-labels)))))
(define (prune-free-vars free-vars named-funs well-known var-aliases) (define (prune-free-vars free-vars named-funs well-known var-aliases)
(define (well-known? label) (define (well-known? label)
@ -158,7 +163,7 @@
;; Normally you wouldn't see duplicates in a free variable ;; Normally you wouldn't see duplicates in a free variable
;; list, but with aliases that is possible. ;; list, but with aliases that is possible.
(if (memq elt list) list (cons elt list))) (if (memq elt list) list (cons elt list)))
(define (filter-out-eliminated free) (define (prune-free closure-label free)
(match free (match free
(() '()) (() '())
((var . free) ((var . free)
@ -167,7 +172,7 @@
(($ $cont label) (($ $cont label)
(cond (cond
((bitvector-ref eliminated label) ((bitvector-ref eliminated label)
(filter-out-eliminated free)) (prune-free closure-label free))
((vector-ref label-aliases label) ((vector-ref label-aliases label)
=> (lambda (var) => (lambda (var)
(cond (cond
@ -180,19 +185,23 @@
(bitvector-set! eliminated label #t) (bitvector-set! eliminated label #t)
(set! recurse? #t)) (set! recurse? #t))
alias-stack) alias-stack)
(filter-out-eliminated free)) (prune-free closure-label free))
(else (else
(lp var (cons label alias-stack)))))) (lp var (cons label alias-stack))))))
((eq? closure-label label)
;; Eliminate self-reference.
(pk 'hi)
(prune-free closure-label free))
(else (else
(adjoin var (filter-out-eliminated free))))) (adjoin var (prune-free closure-label free)))))
(_ (adjoin var (filter-out-eliminated free)))))))) (_ (adjoin var (prune-free closure-label free))))))))
(hash-for-each-handle (hash-for-each-handle
(lambda (pair) (lambda (pair)
(match pair (match pair
((label . ()) #t) ((label . ()) #t)
((label . free) ((label . free)
(let ((orig-nfree (length free)) (let ((orig-nfree (length free))
(free (filter-out-eliminated free))) (free (prune-free label free)))
(set-cdr! pair free) (set-cdr! pair free)
;; If we managed to eliminate one or more free variables ;; If we managed to eliminate one or more free variables
;; from a well-known function, it could be that we can ;; from a well-known function, it could be that we can
@ -219,7 +228,7 @@
(vector-set! var-aliases var alias)))))) (vector-set! var-aliases var alias))))))
named-funs))) named-funs)))
(define (convert-one label fun free-vars named-funs well-known aliases) (define (convert-one bound label fun free-vars named-funs well-known aliases)
(define (well-known? label) (define (well-known? label)
(bitvector-ref well-known label)) (bitvector-ref well-known label))
@ -259,6 +268,7 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
(else 'vector-ref)) (else 'vector-ref))
(self idx))))))) (self idx)))))))
($continue kidx #f ($const free-idx))))))))) ($continue kidx #f ($const free-idx)))))))))
((eq? var bound) (k self))
(else (k var)))) (else (k var))))
(define (convert-free-vars vars k) (define (convert-free-vars vars k)
@ -509,13 +519,14 @@ and allocate and initialize flat closures."
(let ((dfg (compute-dfg fun))) (let ((dfg (compute-dfg fun)))
(with-fresh-name-state-from-dfg dfg (with-fresh-name-state-from-dfg dfg
(call-with-values (lambda () (analyze-closures fun dfg)) (call-with-values (lambda () (analyze-closures fun dfg))
(lambda (free-vars named-funs well-known) (lambda (bound-vars free-vars named-funs well-known)
(let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <)) (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
(aliases (make-vector (var-counter) #f))) (aliases (make-vector (var-counter) #f)))
(prune-free-vars free-vars named-funs well-known aliases) (prune-free-vars free-vars named-funs well-known aliases)
(build-cps-term (build-cps-term
($program ($program
,(map (lambda (label) ,(map (lambda (label)
(convert-one label (lookup-cont label dfg) (convert-one (hashq-ref bound-vars label) label
(lookup-cont label dfg)
free-vars named-funs well-known aliases)) free-vars named-funs well-known aliases))
labels))))))))) labels)))))))))