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

Optimize closures with one free variable

Browse source 
* module/language/cps/closure-conversion.scm (convert-free-var)
  (allocate-closure, init-closure, prune-free-vars, convert-one)
  (convert-closures): Optimize closures with one free variable.
This commit is contained in:
Andy Wingo 2014-04-13 11:47:17 +02:00
parent cd130361b8
commit 32e62c2dae
1 changed files with 111 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -53,6 +53,8 @@ called with @var{var}."
((list-index (cut eq? <> var) free) ((list-index (cut eq? <> var) free)
=> (lambda (free-idx) => (lambda (free-idx)
(match (cons self-known? free) (match (cons self-known? free)
;; A reference to the one free var of a well-known function.
((#t _) (k self))
;; A reference to one of the two free vars in a well-known ;; A reference to one of the two free vars in a well-known
;; function. ;; function.
((#t _ _) ((#t _ _)
@ -99,12 +101,15 @@ term."
($continue k* src ($continue k* src
($closure label (length free))))))) ($closure label (length free)))))))
((#t) ((#t)
;; Well-known callee with no free variables; elide the ;; Well-known closure with no free variables; elide the
;; binding entirely. ;; binding entirely.
body) body)
;; FIXME: Single-var case here. ((#t _)
;; Well-known closure with one free variable; the free var is the
;; closure, and no new binding need be made.
body)
((#t _ _) ((#t _ _)
;; Well-known callee with two free variables; the closure is a ;; Well-known closure with two free variables; the closure is a
;; pair. ;; pair.
(let-fresh (kinit kfalse) (false) (let-fresh (kinit kfalse) (false)
(build-cps-term (build-cps-term
@ -142,6 +147,9 @@ performed, and @var{outer-free} is the list of free variables there."
;; Well-known callee with no free variables; no initialization ;; Well-known callee with no free variables; no initialization
;; necessary. ;; necessary.
((#t) body) ((#t) body)
;; Well-known callee with one free variable; no initialization
;; necessary.
((#t _) body)
;; Well-known callee with two free variables; do a set-car! and ;; Well-known callee with two free variables; do a set-car! and
;; set-cdr!. ;; set-cdr!.
((#t v0 v1) ((#t v0 v1)
@ -273,54 +281,109 @@ performed, and @var{outer-free} is the list of free variables there."
(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 free-vars named-funs (compute-well-known-labels)))))
(define (prune-free-vars free-vars named-funs well-known) (define (prune-free-vars free-vars named-funs well-known var-aliases)
(define (well-known? label) (define (well-known? label)
(bitvector-ref well-known label)) (bitvector-ref well-known label))
(let ((eliminated (make-bitvector (label-counter) #f))) (let ((eliminated (make-bitvector (label-counter) #f))
(define (filter-out-eliminated free) (label-aliases (make-vector (label-counter) #f)))
(match free
(() '())
((var . free)
(match (hashq-ref named-funs var)
(($ $cont (? (cut bitvector-ref eliminated <>) label))
(filter-out-eliminated free))
(_ (cons var (filter-out-eliminated free)))))))
(let lp ((label 0)) (let lp ((label 0))
(let ((label (bit-position #t well-known label))) (let ((label (bit-position #t well-known label)))
(when label (when label
(match (hashq-ref free-vars label) (match (hashq-ref free-vars label)
;; Eliminate all well-known closures that have no free ;; Mark all well-known closures that have no free variables
;; variables. ;; for elimination.
(() (bitvector-set! eliminated label #t)) (() (bitvector-set! eliminated label #t))
;; Replace well-known closures that have just one free
;; variable by references to that free variable.
((var)
(vector-set! label-aliases label var))
(_ #f)) (_ #f))
(lp (1+ label))))) (lp (1+ label)))))
;; Iterative free variable elimination.
(let lp () (let lp ()
(let ((recurse? #f)) (let ((recurse? #f))
(define (adjoin elt list)
;; Normally you wouldn't see duplicates in a free variable
;; list, but with aliases that is possible.
(if (memq elt list) list (cons elt list)))
(define (filter-out-eliminated free)
(match free
(() '())
((var . free)
(let lp ((var var) (alias-stack '()))
(match (hashq-ref named-funs var)
(($ $cont label)
(cond
((bitvector-ref eliminated label)
(filter-out-eliminated free))
((vector-ref label-aliases label)
=> (lambda (var)
(cond
((memq label alias-stack)
;; We have found a set of mutually recursive
;; well-known procedures, each of which only
;; closes over one of the others. Mark them
;; all for elimination.
(for-each (lambda (label)
(bitvector-set! eliminated label #t)
(set! recurse? #t))
alias-stack)
(filter-out-eliminated free))
(else
(lp var (cons label alias-stack))))))
(else
(adjoin var (filter-out-eliminated free)))))
(_ (adjoin var (filter-out-eliminated 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)
;; We could be more precise and eliminate elements of (let ((orig-nfree (length free))
;; `free' that are well-known closures within this (free (filter-out-eliminated free)))
;; function, even if they aren't globally well known. Not
;; implemented.
(let ((free (filter-out-eliminated free)))
(set-cdr! pair free) (set-cdr! pair free)
(when (and (null? free) (well-known? label)) ;; If we managed to eliminate one or more free variables
(bitvector-set! eliminated label #t) ;; from a well-known function, it could be that we can
(set! recurse? #t)))))) ;; eliminate or alias this function as well.
(when (and (well-known? label)
(< (length free) orig-nfree))
(match free
(()
(bitvector-set! eliminated label #t)
(set! recurse? #t))
((var)
(vector-set! label-aliases label var)
(set! recurse? #t))
(_ #t)))))))
free-vars) free-vars)
;; Iterate to fixed point. ;; Iterate to fixed point.
(when recurse? (lp)))))) (when recurse? (lp))))
;; Populate var-aliases from label-aliases.
(hash-for-each (lambda (var cont)
(match cont
(($ $cont label)
(let ((alias (vector-ref label-aliases label)))
(when alias
(vector-set! var-aliases var alias))))))
named-funs)))
(define (convert-one label fun free-vars named-funs well-known) (define (convert-one 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))
;; Load the closure for a known call. The callee may or may not be ;; Load the closure for a known call. The callee may or may not be
;; known at all call sites. ;; known at all call sites.
(define (convert-known-proc-call var label self self-known? free k) (define (convert-known-proc-call var label self self-known? free k)
;; Well-known closures with one free variable are replaced at their
;; use sites by uses of the one free variable. The use sites of a
;; well-known closures are only in well-known proc calls, and in
;; free lists of other closures. Here we handle the call case; the
;; free list case is handled by prune-free-vars.
(define (rename var)
(let ((var* (vector-ref aliases var)))
(if var*
(rename var*)
var)))
(match (cons (well-known? label) (match (cons (well-known? label)
(hashq-ref free-vars label)) (hashq-ref free-vars label))
((#t) ((#t)
@ -330,6 +393,10 @@ performed, and @var{outer-free} is the list of free variables there."
(build-cps-term (build-cps-term
($letk ((k* ($kargs (v*) (v*) ,(k v*)))) ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
($continue k* #f ($const #f)))))) ($continue k* #f ($const #f))))))
((#t _)
;; Calling a well-known procedure with one free variable; pass
;; the free variable as the closure.
(convert-free-var (rename var) self self-known? free k))
(_ (_
(convert-free-var var self self-known? free k)))) (convert-free-var var self self-known? free k))))
@ -370,7 +437,8 @@ performed, and @var{outer-free} is the list of free variables there."
src name var kfun (well-known? kfun) fun-free src name var kfun (well-known? kfun) fun-free
(bindings body))) (bindings body)))
(init-closure (init-closure
src var (well-known? kfun) fun-free self self-known? free src var
(well-known? kfun) fun-free self self-known? free
body))))))) body)))))))
(($ $continue k src (or ($ $void) ($ $const) ($ $prim))) (($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
@ -378,18 +446,27 @@ performed, and @var{outer-free} is the list of free variables there."
(($ $continue k src ($ $fun () ($ $cont kfun))) (($ $continue k src ($ $fun () ($ $cont kfun)))
(let ((fun-free (hashq-ref free-vars kfun))) (let ((fun-free (hashq-ref free-vars kfun)))
(match fun-free (match (cons (well-known? kfun) fun-free)
(() ((known?)
(build-cps-term (build-cps-term
($continue k src ,(if (well-known? kfun) ($continue k src ,(if known?
(build-cps-exp ($const #f)) (build-cps-exp ($const #f))
(build-cps-exp ($closure kfun 0)))))) (build-cps-exp ($closure kfun 0))))))
((#t _)
;; A well-known closure of one free variable is replaced
;; at each use with the free variable itself, so we don't
;; need a binding at all; and yet, the continuation
;; expects one value, so give it something. DCE should
;; clean up later.
(build-cps-term
($continue k src ,(build-cps-exp ($const #f)))))
(_ (_
(let-fresh () (var) (let-fresh () (var)
(allocate-closure (allocate-closure
src #f var kfun (well-known? kfun) fun-free src #f var kfun (well-known? kfun) fun-free
(init-closure (init-closure
src var (well-known? kfun) fun-free self self-known? free src var
(well-known? kfun) fun-free self self-known? free
(build-cps-term ($continue k src ($values (var))))))))))) (build-cps-term ($continue k src ($values (var)))))))))))
(($ $continue k src ($ $call proc args)) (($ $continue k src ($ $call proc args))
@ -438,11 +515,12 @@ and allocate and initialize flat closures."
(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 (free-vars named-funs well-known)
(prune-free-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)))
(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 label (lookup-cont label dfg)
free-vars named-funs well-known)) free-vars named-funs well-known aliases))
labels))))))))) labels)))))))))