[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-856-g545274a
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-856-g545274a |
|
Date: |
Tue, 01 Apr 2014 16:21:22 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=545274a03578b5fa5270c629d704fb9f815517cf
The branch, master has been updated
via 545274a03578b5fa5270c629d704fb9f815517cf (commit)
via 0912202a51d8312c103fc0a43c29a8fdbaf7de00 (commit)
via f9bceb770b06b5e5406ba4a126644688f43ea2cb (commit)
via cc8eb195457312aad9c2caa5654c2dc686028a71 (commit)
via 3269e1b647edcb248ca233c293975456c0d6ad28 (commit)
via c79c02d694a26d0fc3df953d4b0b0a60fde81337 (commit)
via 7c4977e699e282515e4266c9ca8aac2159b20fe2 (commit)
via 7dbf40ea8bb77141d3a30f7e5418cf4f1d03de5e (commit)
from a8430ab1d779278c08b389c566243a2ce013093a (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 545274a03578b5fa5270c629d704fb9f815517cf
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 18:20:02 2014 +0200
Speed up compute-label-and-var-ranges
* module/language/cps/dfg.scm (compute-label-and-var-ranges): Duplicate
the cont-folder cases in the global/not-global cases. Lets the
optimizer DTRT.
commit 0912202a51d8312c103fc0a43c29a8fdbaf7de00
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 18:16:00 2014 +0200
Fix compute-label-and-var-ranges for global DFG computation
* module/language/cps/dfg.scm (compute-label-and-var-ranges): Fix to
work with global DFGs -- it wasn't taking $letrec into account for var
ranges.
* module/language/cps/dce.scm (compute-live-code): Use bitvectors to
represent the live var set.
commit f9bceb770b06b5e5406ba4a126644688f43ea2cb
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 17:51:26 2014 +0200
Renumber doesn't visit unreachable continuations
* module/language/cps/renumber.scm (compute-new-labels-and-vars): Don't
visit functions that are not reachable.
(renumber): Reindent.
commit cc8eb195457312aad9c2caa5654c2dc686028a71
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 16:47:11 2014 +0200
Renumber returns label/var counters for use in let-fresh
* module/language/cps/renumber.scm (renumber): Refactor to return the
label and var counters as additional values.
* module/language/cps/dce.scm (eliminate-dead-code): Use the renumber
label/var counters to initialize the fresh name state.
commit 3269e1b647edcb248ca233c293975456c0d6ad28
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 16:43:55 2014 +0200
Refactor DCE to not build a CFA
* module/language/cps/effects-analysis.scm (compute-effects): Change to
analyze the effects for a subrange of a DFG's continuations.
* module/language/cps/dce.scm (compute-defs, $fun-data, compute-live-code):
(process-eliminations, eliminate-dead-code): Renumber before
eliminating dead code, to avoid computing a CFG and other data.
commit c79c02d694a26d0fc3df953d4b0b0a60fde81337
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 15:56:45 2014 +0200
Simplification renumbers instead of local prune-continuation pass
* module/language/cps/simplify.scm (simplify): Use renumbering instead
of rolling our own prune-continuations pass.
commit 7c4977e699e282515e4266c9ca8aac2159b20fe2
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 15:42:12 2014 +0200
DFA uses DFG var numbering
* module/language/cps/dfg.scm ($dfa): Instead of a var-map table an a
syms vector, use the DFG's var numbering.
(dfa-var-idx, dfa-var-sym, compute-live-variables): Adapt.
commit 7dbf40ea8bb77141d3a30f7e5418cf4f1d03de5e
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 15:21:28 2014 +0200
Allocate-slots avoids building CFA
* module/language/cps/slot-allocation.scm (allocate-slots): Rework to
avoid computing a CFA, and just relying on the incoming term to have
sorted labels.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/dce.scm | 296 +++++++++++++++---------------
module/language/cps/dfg.scm | 136 ++++++++------
module/language/cps/effects-analysis.scm | 10 +-
module/language/cps/renumber.scm | 72 +++-----
module/language/cps/simplify.scm | 55 +-----
module/language/cps/slot-allocation.scm | 100 +++++------
6 files changed, 308 insertions(+), 361 deletions(-)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 20fc9cd..eae551a 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -39,37 +39,31 @@
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps effects-analysis)
+ #:use-module (language cps renumber)
#:export (eliminate-dead-code))
(define-record-type $fun-data
- (make-fun-data cfa effects conts live-conts defs)
+ (make-fun-data min-label effects conts live-conts defs)
fun-data?
- (cfa fun-data-cfa)
+ (min-label fun-data-min-label)
(effects fun-data-effects)
(conts fun-data-conts)
(live-conts fun-data-live-conts)
(defs fun-data-defs))
-(define (compute-cont-vector cfa dfg)
- (let ((v (make-vector (cfa-k-count cfa) #f)))
- (let lp ((n 0))
- (when (< n (vector-length v))
- (vector-set! v n (lookup-cont (cfa-k-sym cfa n) dfg))
- (lp (1+ n))))
- v))
-
-(define (compute-defs cfa contv)
+(define (compute-defs dfg min-label label-count)
(define (cont-defs k)
- (match (vector-ref contv (cfa-k-idx cfa k))
- (($ $kargs names syms) syms)
+ (match (lookup-cont k dfg)
+ (($ $kargs names vars) vars)
(_ #f)))
- (let ((defs (make-vector (vector-length contv) #f)))
+ (define (idx->label idx) (+ idx min-label))
+ (let ((defs (make-vector label-count #f)))
(let lp ((n 0))
- (when (< n (vector-length contv))
+ (when (< n label-count)
(vector-set!
defs
n
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kargs _ _ body)
(match (find-call body)
(($ $continue k) (cont-defs k))))
@@ -84,30 +78,36 @@
defs))
(define (compute-live-code fun)
- (let ((fun-data-table (make-hash-table))
- (live-vars (make-hash-table))
- (dfg (compute-dfg fun #:global? #t))
- (changed? #f))
- (define (mark-live! sym)
- (unless (value-live? sym)
+ (let* ((fun-data-table (make-hash-table))
+ (dfg (compute-dfg fun #:global? #t))
+ (live-vars (make-bitvector (dfg-var-count dfg) #f))
+ (changed? #f))
+ (define (mark-live! var)
+ (unless (value-live? var)
(set! changed? #t)
- (hashq-set! live-vars sym #t)))
- (define (value-live? sym)
- (hashq-ref live-vars sym))
+ (bitvector-set! live-vars var #t)))
+ (define (value-live? var)
+ (bitvector-ref live-vars var))
(define (ensure-fun-data fun)
(or (hashq-ref fun-data-table fun)
- (let* ((cfa (analyze-control-flow fun dfg))
- (effects (compute-effects cfa dfg))
- (contv (compute-cont-vector cfa dfg))
- (live-conts (make-bitvector (cfa-k-count cfa) #f))
- (defs (compute-defs cfa contv))
- (fun-data (make-fun-data cfa effects contv live-conts defs)))
- (hashq-set! fun-data-table fun fun-data)
- (set! changed? #t)
- fun-data)))
+ (call-with-values (lambda ()
+ ((make-cont-folder #f label-count max-label)
+ (lambda (k cont label-count max-label)
+ (values (1+ label-count) (max k max-label)))
+ fun 0 -1))
+ (lambda (label-count max-label)
+ (let* ((min-label (- (1+ max-label) label-count))
+ (effects (compute-effects dfg min-label label-count))
+ (live-conts (make-bitvector label-count #f))
+ (defs (compute-defs dfg min-label label-count))
+ (fun-data (make-fun-data min-label label-count
+ effects live-conts defs)))
+ (hashq-set! fun-data-table fun fun-data)
+ (set! changed? #t)
+ fun-data)))))
(define (visit-fun fun)
(match (ensure-fun-data fun)
- (($ $fun-data cfa effects contv live-conts defs)
+ (($ $fun-data min-label label-count effects live-conts defs)
(define (visit-grey-exp n)
(let ((defs (vector-ref defs n)))
(cond
@@ -117,9 +117,10 @@
#t)
(else
(or-map value-live? defs)))))
- (let lp ((n (1- (cfa-k-count cfa))))
+ (define (idx->label idx) (+ idx min-label))
+ (let lp ((n (1- label-count)))
(unless (< n 0)
- (let ((cont (vector-ref contv n)))
+ (let ((cont (lookup-cont (idx->label n) dfg)))
(match cont
(($ $kargs _ _ body)
(let lp ((body body))
@@ -167,118 +168,123 @@
(mark-live! self))
(($ $ktail) #f))
(lp (1- n))))))))
+ (unless (= (dfg-var-count dfg) (var-counter))
+ (error "internal error" (dfg-var-count dfg) (var-counter)))
(let lp ()
(set! changed? #f)
(visit-fun fun)
(when changed? (lp)))
(values fun-data-table live-vars)))
-(define (eliminate-dead-code fun)
- (with-fresh-name-state fun
- (call-with-values (lambda () (compute-live-code fun))
- (lambda (fun-data-table live-vars)
- (define (value-live? sym)
- (hashq-ref live-vars sym))
- (define (make-adaptor name k defs)
- (let* ((names (map (lambda (_) 'tmp) defs))
- (syms (map (lambda (_) (fresh-var)) defs))
- (live (filter-map (lambda (def sym)
- (and (value-live? def)
- sym))
- defs syms)))
- (build-cps-cont
- (name ($kargs names syms
- ($continue k #f ($values live)))))))
- (define (visit-fun fun)
- (match (hashq-ref fun-data-table fun)
- (($ $fun-data cfa effects contv live-conts defs)
- (define (must-visit-cont cont)
- (match (visit-cont cont)
- ((cont) cont)
- (conts (error "cont must be reachable" cont conts))))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym cont)
- (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
- (#f '())
- (n
- (match cont
- (($ $kargs names syms body)
- (match (filter-map (lambda (name sym)
- (and (value-live? sym)
- (cons name sym)))
- names syms)
- (((names . syms) ...)
- (list
- (build-cps-cont
- (sym ($kargs names syms
- ,(visit-term body n))))))))
- (($ $kentry self tail clause)
- (list
- (build-cps-cont
- (sym ($kentry self ,tail
- ,(and clause (must-visit-cont clause)))))))
- (($ $kclause arity body alternate)
- (list
- (build-cps-cont
- (sym ($kclause ,arity
- ,(must-visit-cont body)
- ,(and alternate
- (must-visit-cont alternate)))))))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (let ((defs (vector-ref defs n)))
- (if (and-map value-live? defs)
- (list (build-cps-cont (sym ,cont)))
- (let-fresh (adapt) ()
- (list (make-adaptor adapt kargs defs)
- (build-cps-cont
- (sym ($kreceive req rest adapt))))))))
- (_ (list (build-cps-cont (sym ,cont))))))))))
- (define (visit-conts conts)
- (append-map visit-cont conts))
- (define (visit-term term term-k-idx)
- (match term
- (($ $letk conts body)
- (let ((body (visit-term body term-k-idx)))
- (match (visit-conts conts)
- (() body)
- (conts (build-cps-term ($letk ,conts ,body))))))
- (($ $letrec names syms funs body)
- (let ((body (visit-term body term-k-idx)))
- (match (filter-map
- (lambda (name sym fun)
- (and (value-live? sym)
- (list name sym (visit-fun fun))))
- names syms funs)
- (() body)
- (((names syms funs) ...)
+(define (process-eliminations fun fun-data-table live-vars)
+ (define (value-live? var)
+ (bitvector-ref live-vars var))
+ (define (make-adaptor name k defs)
+ (let* ((names (map (lambda (_) 'tmp) defs))
+ (syms (map (lambda (_) (fresh-var)) defs))
+ (live (filter-map (lambda (def sym)
+ (and (value-live? def)
+ sym))
+ defs syms)))
+ (build-cps-cont
+ (name ($kargs names syms
+ ($continue k #f ($values live)))))))
+ (define (visit-fun fun)
+ (match (hashq-ref fun-data-table fun)
+ (($ $fun-data min-label label-count effects live-conts defs)
+ (define (label->idx label) (- label min-label))
+ (define (visit-cont cont)
+ (match (visit-cont* cont)
+ ((cont) cont)))
+ (define (visit-cont* cont)
+ (match cont
+ (($ $cont label cont)
+ (match cont
+ (($ $kargs names syms body)
+ (match (filter-map (lambda (name sym)
+ (and (value-live? sym)
+ (cons name sym)))
+ names syms)
+ (((names . syms) ...)
+ (list
+ (build-cps-cont
+ (label ($kargs names syms
+ ,(visit-term body label))))))))
+ (($ $kentry self tail clause)
+ (list
+ (build-cps-cont
+ (label ($kentry self ,tail
+ ,(and clause (visit-cont clause)))))))
+ (($ $kclause arity body alternate)
+ (list
+ (build-cps-cont
+ (label ($kclause ,arity
+ ,(visit-cont body)
+ ,(and alternate
+ (visit-cont alternate)))))))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (let ((defs (vector-ref defs (label->idx label))))
+ (if (and-map value-live? defs)
+ (list (build-cps-cont (label ,cont)))
+ (let-fresh (adapt) ()
+ (list (make-adaptor adapt kargs defs)
+ (build-cps-cont
+ (label ($kreceive req rest adapt))))))))
+ (_ (list (build-cps-cont (label ,cont))))))))
+ (define (visit-conts conts)
+ (append-map visit-cont* conts))
+ (define (visit-term term term-k)
+ (match term
+ (($ $letk conts body)
+ (let ((body (visit-term body term-k)))
+ (match (visit-conts conts)
+ (() body)
+ (conts (build-cps-term ($letk ,conts ,body))))))
+ (($ $letrec names syms funs body)
+ (let ((body (visit-term body term-k)))
+ (match (filter-map
+ (lambda (name sym fun)
+ (and (value-live? sym)
+ (list name sym (visit-fun fun))))
+ names syms funs)
+ (() body)
+ (((names syms funs) ...)
+ (build-cps-term
+ ($letrec names syms funs ,body))))))
+ (($ $continue k src ($ $values args))
+ (match (vector-ref defs (label->idx term-k))
+ (#f term)
+ (defs
+ (let ((args (filter-map (lambda (use def)
+ (and (value-live? def) use))
+ args defs)))
+ (build-cps-term
+ ($continue k src ($values args)))))))
+ (($ $continue k src exp)
+ (if (bitvector-ref live-conts (label->idx term-k))
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k src ,(visit-fun exp)))
+ (_
+ ,(match (vector-ref defs (label->idx term-k))
+ ((or #f ((? value-live?) ...))
(build-cps-term
- ($letrec names syms funs ,body))))))
- (($ $continue k src ($ $values args))
- (match (vector-ref defs term-k-idx)
- (#f term)
- (defs
- (let ((args (filter-map (lambda (use def)
- (and (value-live? def) use))
- args defs)))
- (build-cps-term
- ($continue k src ($values args)))))))
- (($ $continue k src exp)
- (if (bitvector-ref live-conts term-k-idx)
- (rewrite-cps-term exp
- (($ $fun) ($continue k src ,(visit-fun exp)))
- (_
- ,(match (vector-ref defs term-k-idx)
- ((or #f ((? value-live?) ...))
- (build-cps-term
- ($continue k src ,exp)))
- (syms
- (let-fresh (adapt) ()
- (build-cps-term
- ($letk (,(make-adaptor adapt k syms))
- ($continue adapt src ,exp))))))))
- (build-cps-term ($continue k src ($values ())))))))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(must-visit-cont body)))))))
- (visit-fun fun)))))
+ ($continue k src ,exp)))
+ (syms
+ (let-fresh (adapt) ()
+ (build-cps-term
+ ($letk (,(make-adaptor adapt k syms))
+ ($continue adapt src ,exp))))))))
+ (build-cps-term ($continue k src ($values ())))))))
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))))
+ (visit-fun fun))
+
+(define (eliminate-dead-code fun)
+ (call-with-values (lambda () (renumber fun))
+ (lambda (fun nlabels nvars)
+ (parameterize ((label-counter nlabels)
+ (var-counter nvars))
+ (call-with-values (lambda () (compute-live-code fun))
+ (lambda (fun-data-table live-vars)
+ (process-eliminations fun fun-data-table live-vars)))))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 4b4986d..4f32fce 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -659,14 +659,14 @@ BODY for each body continuation in the prompt."
;; Data-flow analysis.
(define-record-type $dfa
- (make-dfa cfa var-map syms in out)
+ (make-dfa cfa min-var var-count in out)
dfa?
;; CFA, for its reverse-post-order numbering
(cfa dfa-cfa)
- ;; Hash table mapping var-sym -> var-idx
- (var-map dfa-var-map)
- ;; Vector of var-idx -> var-sym
- (syms dfa-syms)
+ ;; Minimum var in this function.
+ (min-var dfa-min-var)
+ ;; Minimum var in this function.
+ (var-count dfa-var-count)
;; Vector of k-idx -> bitvector
(in dfa-in)
;; Vector of k-idx -> bitvector
@@ -682,14 +682,15 @@ BODY for each body continuation in the prompt."
(cfa-k-count (dfa-cfa dfa)))
(define (dfa-var-idx dfa var)
- (or (hashq-ref (dfa-var-map dfa) var)
- (error "unknown var" var)))
+ (let ((idx (- var (dfa-min-var dfa))))
+ (unless (< -1 idx (dfa-var-count dfa))
+ (error "var out of range" var))
+ idx))
(define (dfa-var-sym dfa idx)
- (vector-ref (dfa-syms dfa) idx))
-
-(define (dfa-var-count dfa)
- (vector-length (dfa-syms dfa)))
+ (unless (< -1 idx (dfa-var-count dfa))
+ (error "idx out of range" idx))
+ (+ idx (dfa-min-var dfa)))
(define (dfa-k-in dfa idx)
(vector-ref (dfa-in dfa) idx))
@@ -698,38 +699,35 @@ BODY for each body continuation in the prompt."
(vector-ref (dfa-out dfa) idx))
(define (compute-live-variables fun dfg)
- (let* ((var-map (make-hash-table))
- (min-var (dfg-min-var dfg))
+ (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
+ (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
+ (error "function needs renumbering"))
+ (let* ((min-var (dfg-min-var dfg))
(nvars (dfg-var-count dfg))
(cfa (analyze-control-flow fun dfg #:reverse? #t
#:add-handler-preds? #t))
- (syms (make-vector nvars #f))
(usev (make-vector (cfa-k-count cfa) '()))
(defv (make-vector (cfa-k-count cfa) '()))
(live-in (make-vector (cfa-k-count cfa) #f))
(live-out (make-vector (cfa-k-count cfa) #f)))
- ;; Initialize syms, defv, and usev.
+ (define (var->idx var) (- var min-var))
+ (define (idx->var idx) (+ idx min-var))
+
+ ;; Initialize defv and usev.
(let ((defs (dfg-defs dfg))
- (uses (dfg-uses dfg))
- (counter 0))
- (define (counter++)
- (let ((res counter))
- (set! counter (1+ counter))
- res))
+ (uses (dfg-uses dfg)))
(let lp ((n 0))
(when (< n (vector-length defs))
(let ((def (vector-ref defs n)))
- (when def
- (let ((v (counter++)))
- (hashq-set! var-map (+ n min-var) v)
- (vector-set! syms v (+ n min-var))
- (for-each (lambda (def)
- (vector-push! defv (cfa-k-idx cfa def) v))
- (lookup-predecessors def dfg))
- (for-each (lambda (use)
- (vector-push! usev (cfa-k-idx cfa use) v))
- (vector-ref uses n)))))
- (lp (1+ n)))))
+ (unless def
+ (error "internal error -- var array not packed"))
+ (for-each (lambda (def)
+ (vector-push! defv (cfa-k-idx cfa def) n))
+ (lookup-predecessors def dfg))
+ (for-each (lambda (use)
+ (vector-push! usev (cfa-k-idx cfa use) n))
+ (vector-ref uses n))
+ (lp (1+ n))))))
;; Initialize live-in and live-out sets.
(let lp ((n 0))
@@ -746,16 +744,16 @@ BODY for each body continuation in the prompt."
(compute-maximum-fixed-point (cfa-preds cfa)
live-out live-in defv usev #t)
- (make-dfa cfa var-map syms live-in live-out)))
+ (make-dfa cfa min-var nvars live-in live-out)))
(define (print-dfa dfa)
(match dfa
- (($ $dfa cfa var-map syms in out)
+ (($ $dfa cfa min-var in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
(when n
- (format #t " ~A" (vector-ref syms n))
+ (format #t " ~A" (+ n min-var))
(lp (1+ n))))))
(let lp ((n 0))
(when (< n (cfa-k-count cfa))
@@ -883,29 +881,51 @@ BODY for each body continuation in the prompt."
(define (compute-label-and-var-ranges fun global?)
(define (min* a b)
(if b (min a b) a))
- ((make-cont-folder global?
- min-label max-label label-count
- min-var max-var var-count)
- (lambda (label cont
- min-label max-label label-count
- min-var max-var var-count)
- (let ((min-label (min* label min-label))
- (max-label (max label max-label)))
- (match cont
- (($ $kargs names vars)
- (values min-label max-label (1+ label-count)
- (cond (min-var (fold min min-var vars))
- ((pair? vars) (fold min (car vars) (cdr vars)))
- (else min-var))
- (fold max max-var vars)
- (+ var-count (length vars))))
- (($ $kentry self)
- (values min-label max-label (1+ label-count)
- (min* self min-var) (max self max-var) (1+ var-count)))
- (_ (values min-label max-label (1+ label-count)
- min-var max-var var-count)))))
- fun
- #f -1 0 #f -1 0))
+ (define-syntax-rule (do-fold global?)
+ ((make-cont-folder global?
+ min-label max-label label-count
+ min-var max-var var-count)
+ (lambda (label cont
+ min-label max-label label-count
+ min-var max-var var-count)
+ (let ((min-label (min* label min-label))
+ (max-label (max label max-label)))
+ (define (visit-letrec body min-var max-var var-count)
+ (match body
+ (($ $letk conts body)
+ (visit-letrec body min-var max-var var-count))
+ (($ $letrec names vars funs body)
+ (visit-letrec body
+ (cond (min-var (fold min min-var vars))
+ ((pair? vars) (fold min (car vars) (cdr
vars)))
+ (else min-var))
+ (fold max max-var vars)
+ (+ var-count (length vars))))
+ (($ $continue) (values min-var max-var var-count))))
+ (match cont
+ (($ $kargs names vars body)
+ (call-with-values
+ (lambda ()
+ (if global?
+ (visit-letrec body min-var max-var var-count)
+ (values min-var max-var var-count)))
+ (lambda (min-var max-var var-count)
+ (values min-label max-label (1+ label-count)
+ (cond (min-var (fold min min-var vars))
+ ((pair? vars) (fold min (car vars) (cdr vars)))
+ (else min-var))
+ (fold max max-var vars)
+ (+ var-count (length vars))))))
+ (($ $kentry self)
+ (values min-label max-label (1+ label-count)
+ (min* self min-var) (max self max-var) (1+ var-count)))
+ (_ (values min-label max-label (1+ label-count)
+ min-var max-var var-count)))))
+ fun
+ #f -1 0 #f -1 0))
+ (if global?
+ (do-fold #t)
+ (do-fold #f)))
(define* (compute-dfg fun #:key (global? #t))
(call-with-values (lambda () (compute-label-and-var-ranges fun global?))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 87eed03..8601e35 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -460,14 +460,16 @@
(($ $primcall name args)
(primitive-effects dfg name args))))
-(define (compute-effects cfa dfg)
- (let ((effects (make-vector (cfa-k-count cfa) &no-effects)))
+(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
+ (label-count (dfg-label-count dfg)))
+ (let ((effects (make-vector label-count &no-effects)))
+ (define (idx->label idx) (+ idx min-label))
(let lp ((n 0))
- (when (< n (vector-length effects))
+ (when (< n label-count)
(vector-set!
effects
n
- (match (lookup-cont (cfa-k-sym cfa n) dfg)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body)
(expression-effects (find-expression body) dfg))
(($ $kreceive arity kargs)
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 85ac52b..9136247 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -26,44 +26,10 @@
(define-module (language cps renumber)
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (language cps)
#:export (renumber))
-(define (visit-funs proc fun)
- (define (visit-cont cont)
- (match cont
- (($ $cont label cont)
- (match cont
- (($ $kargs names vars body)
- (visit-term body))
- (($ $kentry self tail clause)
- (when clause
- (visit-cont clause)))
- (($ $kclause arity body alternate)
- (visit-cont body)
- (when alternate
- (visit-cont alternate)))
- ((or ($ $kreceive) ($ $kif))
- #f)))))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (for-each visit-cont conts)
- (visit-term body))
- (($ $letrec names syms funs body)
- (for-each visit-fun funs)
- (visit-term body))
- (($ $continue k src (and fun ($ $fun)))
- (visit-fun fun))
- (($ $continue k src _)
- #f)))
- (define (visit-fun fun)
- (proc fun)
- (match fun
- (($ $fun src meta free body)
- (visit-cont body))))
- (visit-fun fun))
-
;; Topologically sort the continuation tree starting at k0, using
;; reverse post-order numbering.
(define (sort-conts k0 conts new-k0)
@@ -149,6 +115,7 @@
(visit-cont body))))
(define (compute-names-in-fun fun)
+ (define queue '())
(define (visit-cont cont)
(match cont
(($ $cont label cont)
@@ -165,12 +132,13 @@
(for-each rename! vars))
(visit-term body reachable?))
(($ $kentry self tail clause)
- (when reachable?
- (rename! self))
+ (unless reachable? (error "entry should be reachable"))
+ (rename! self)
(visit-cont tail)
(when clause
(visit-cont clause)))
(($ $kclause arity body alternate)
+ (unless reachable? (error "clause should be reachable"))
(visit-cont body)
(when alternate
(visit-cont alternate)))
@@ -181,7 +149,7 @@
;; sure we mark as reachable.
(vector-set! labels label next-label)
(set! next-label (1+ next-label))))
- ((or ($ $ktail) ($ $kreceive) ($ $kif))
+ ((or ($ $kreceive) ($ $kif))
#f))))))
(define (visit-term term reachable?)
(match term
@@ -190,23 +158,27 @@
(visit-term body reachable?))
(($ $letrec names syms funs body)
(when reachable?
- (for-each rename! syms))
+ (for-each rename! syms)
+ (set! queue (fold cons queue funs)))
(visit-term body reachable?))
- (($ $continue k src _)
- #f)))
+ (($ $continue k src (and fun ($ $fun)))
+ (when reachable?
+ (set! queue (cons fun queue))))
+ (($ $continue) #f)))
(collect-conts fun)
(match fun
(($ $fun src meta free (and entry ($ $cont kentry)))
(set! next-label (sort-conts kentry labels next-label))
- (visit-cont entry))))
+ (visit-cont entry)
+ (for-each compute-names-in-fun (reverse queue)))))
- (visit-funs compute-names-in-fun fun)
- (values labels vars)))))
+ (compute-names-in-fun fun)
+ (values labels vars next-label next-var)))))
(define (renumber fun)
(call-with-values (lambda () (compute-new-labels-and-vars fun))
- (lambda (labels vars)
+ (lambda (labels vars nlabels nvars)
(define (relabel label) (vector-ref labels label))
(define (rename var) (vector-ref vars var))
(define (rename-kw-arity arity)
@@ -272,16 +244,16 @@
(visit-fun exp))
(($ $values args)
(let ((args (map rename args)))
- (build-cps-exp ($values args))))
+ (build-cps-exp ($values args))))
(($ $call proc args)
(let ((args (map rename args)))
- (build-cps-exp ($call (rename proc) args))))
+ (build-cps-exp ($call (rename proc) args))))
(($ $callk k proc args)
(let ((args (map rename args)))
- (build-cps-exp ($callk (relabel k) (rename proc) args))))
+ (build-cps-exp ($callk (relabel k) (rename proc) args))))
(($ $primcall name args)
(let ((args (map rename args)))
- (build-cps-exp ($primcall name args))))
+ (build-cps-exp ($primcall name args))))
(($ $prompt escape? tag handler)
(build-cps-exp
($prompt escape? (rename tag) (relabel handler))))))
@@ -289,4 +261,4 @@
(rewrite-cps-exp fun
(($ $fun src meta free body)
($fun src meta (map rename free) ,(must-visit-cont body)))))
- (visit-fun fun))))
+ (values (visit-fun fun) nlabels nvars))))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index c30ba76..8c7b898 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -30,58 +30,9 @@
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
+ #:use-module (language cps renumber)
#:export (simplify))
-;; Currently we just try to bypass all $values nodes that we can. This
-;; is eta-reduction on continuations. Then we prune unused
-;; continuations. Note that this pruning is just a quick clean-up; for
-;; a real fixed-point pass that can eliminate unused loops, the
-;; dead-code elimination pass is there for you. But DCE introduces new
-;; nullary $values nodes (as replacements for expressions whose values
-;; aren't used), making it useful for this pass to include its own
-;; little pruner.
-
-(define* (prune-continuations fun #:optional (dfg (compute-dfg fun)))
- (let ((cfa (analyze-control-flow fun dfg)))
- (define (must-visit-cont cont)
- (or (visit-cont cont)
- (error "cont must be reachable" cont)))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym cont)
- (and (cfa-k-idx cfa sym #:default (lambda (k) #f))
- (rewrite-cps-cont cont
- (($ $kargs names syms body)
- (sym ($kargs names syms ,(visit-term body))))
- (($ $kentry self tail clause)
- (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
- (($ $kclause arity body alternate)
- (sym ($kclause ,arity ,(must-visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- ((or ($ $kreceive) ($ $kif))
- (sym ,cont)))))))
- (define (visit-conts conts)
- (filter-map visit-cont conts))
- (define (visit-term term)
- (match term
- (($ $letk conts body)
- (let ((body (visit-term body)))
- (match (visit-conts conts)
- (() body)
- (conts (build-cps-term ($letk ,conts ,body))))))
- (($ $letrec names syms funs body)
- (build-cps-term
- ($letrec names syms (map (cut prune-continuations <> dfg) funs)
- ,(visit-term body))))
- (($ $continue k src (and fun ($ $fun)))
- (build-cps-term
- ($continue k src ,(prune-continuations fun dfg))))
- (($ $continue k src exp)
- term)))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(must-visit-cont body))))))
-
(define (compute-eta-reductions fun)
(let ((table (make-hash-table)))
(define (visit-cont cont)
@@ -283,4 +234,6 @@
(visit-fun fun)))
(define (simplify fun)
- (prune-continuations (eta-reduce (beta-reduce fun))))
+ ;; Renumbering prunes continuations that are made unreachable by
+ ;; eta/beta reductions.
+ (renumber (eta-reduce (beta-reduce fun))))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 96a577b..e5f3117 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -233,10 +233,10 @@ are comparable with eqv?. A tmp slot may be used."
(define (allocate-slots fun dfg)
(let* ((dfa (compute-live-variables fun dfg))
- (cfa (analyze-control-flow fun dfg))
- (usev (make-vector (cfa-k-count cfa) '()))
- (defv (make-vector (cfa-k-count cfa) '()))
- (contv (make-vector (cfa-k-count cfa) #f))
+ (min-label (dfg-min-label dfg))
+ (label-count (dfg-label-count dfg))
+ (usev (make-vector label-count '()))
+ (defv (make-vector label-count '()))
(slots (make-vector (dfa-var-count dfa) #f))
(constant-values (make-vector (dfa-var-count dfa) #f))
(has-constv (make-bitvector (dfa-var-count dfa) #f))
@@ -247,6 +247,9 @@ are comparable with eqv?. A tmp slot may be used."
(nlocals 0) ; Mutable. It pains me.
(nlocals-table (make-hash-table)))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+
(define (bump-nlocals! nlocals*)
(when (< nlocals nlocals*)
(set! nlocals nlocals*)))
@@ -328,20 +331,12 @@ are comparable with eqv?. A tmp slot may be used."
(bitvector-set! needs-slotv n #f)))
(lp (1+ n))))))))
- ;; Transform the DFG's continuation table to a vector, for easy
- ;; access.
- (define (compute-conts!)
- (let lp ((n 0))
- (when (< n (vector-length contv))
- (vector-set! contv n (lookup-cont (cfa-k-sym cfa n) dfg))
- (lp (1+ n)))))
-
;; Record uses and defs, as lists of variable indexes, indexed by
- ;; CFA continuation index.
+ ;; label index.
(define (compute-uses-and-defs!)
(let lp ((n 0))
(when (< n (vector-length usev))
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kentry self)
(vector-set! defv n (list (dfa-var-idx dfa self))))
(($ $kargs names syms body)
@@ -366,30 +361,30 @@ are comparable with eqv?. A tmp slot may be used."
;; Results of function calls that are not used don't need to be
;; allocated to slots.
(define (compute-unused-results!)
- (define (kreceive-get-kargs n)
- (match (vector-ref contv n)
- (($ $kreceive arity kargs) (cfa-k-idx cfa kargs))
+ (define (kreceive-get-kargs kreceive)
+ (match (lookup-cont kreceive dfg)
+ (($ $kreceive arity kargs) kargs)
(_ #f)))
- (let ((candidates (make-bitvector (vector-length contv) #f)))
+ (let ((candidates (make-bitvector label-count #f)))
;; Find all $kargs that are the successors of $kreceive nodes.
(let lp ((n 0))
- (when (< n (vector-length contv))
- (and=> (kreceive-get-kargs n)
+ (when (< n label-count)
+ (and=> (kreceive-get-kargs (idx->label n))
(lambda (kargs)
- (bitvector-set! candidates kargs #t)))
+ (bitvector-set! candidates (label->idx kargs) #t)))
(lp (1+ n))))
;; For $kargs that only have $kreceive predecessors, remove unused
;; variables from the needs-slotv set.
(let lp ((n 0))
(let ((n (bit-position #t candidates n)))
(when n
- (match (cfa-predecessors cfa n)
+ (match (lookup-predecessors (idx->label n) dfg)
;; At least one kreceive is in the predecessor set, so we
;; only need to do the check for nodes with >1
;; predecessor.
((or (_) ((? kreceive-get-kargs) ...))
(for-each (lambda (var)
- (when (dead-after-def? (cfa-k-sym cfa n) var dfa)
+ (when (dead-after-def? (idx->label n) var dfa)
(bitvector-set! needs-slotv var #f)))
(vector-ref defv n)))
(_ #f))
@@ -408,20 +403,20 @@ are comparable with eqv?. A tmp slot may be used."
;; control-flow graph, but we did the live variable analysis in
;; the opposite direction -- so the continuation numbers don't
;; correspond. This helper adapts them.
- (define (cfa-k-idx->dfa-k-idx n)
- (dfa-k-idx dfa (cfa-k-sym cfa n)))
+ (define (label-idx->dfa-k-idx n)
+ (dfa-k-idx dfa (idx->label n)))
(define (live-before n)
- (dfa-k-in dfa (cfa-k-idx->dfa-k-idx n)))
+ (dfa-k-in dfa (label-idx->dfa-k-idx n)))
(define (live-after n)
- (dfa-k-out dfa (cfa-k-idx->dfa-k-idx n)))
+ (dfa-k-out dfa (label-idx->dfa-k-idx n)))
;; Walk backwards. At a call, compute the set of variables that
;; have allocated slots and are live before but not after. This
;; set contains candidates for needs-hintv.
(define (scan-for-call n)
(when (<= 0 n)
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body)
(match (find-expression body)
((or ($ $call) ($ $callk))
@@ -439,10 +434,10 @@ are comparable with eqv?. A tmp slot may be used."
;; ends, we reach a call, or when an expression kills a value.
(define (scan-for-hints n args)
(when (< 0 n)
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body)
- (match (cfa-predecessors cfa (1+ n))
- (((? (cut eqv? <> n)))
+ (match (lookup-predecessors (idx->label (1+ n)) dfg)
+ (((? (cut eqv? <> (idx->label n))))
;; If we are indeed in the same basic block, then if we
;; are finished with the scan, we kill uses of the
;; terminator, but leave its definitions.
@@ -481,10 +476,10 @@ are comparable with eqv?. A tmp slot may be used."
(bit-set*! no-slot-needed needs-slotv #t)
(bit-invert! no-slot-needed)
- (scan-for-call (1- (vector-length contv))))
+ (scan-for-call (1- label-count)))
(define (allocate-call label k uses pre-live post-live)
- (match (vector-ref contv (cfa-k-idx cfa k))
+ (match (lookup-cont k dfg)
(($ $ktail)
(let* ((tail-nlocals (length uses))
(tail-slots (iota tail-nlocals))
@@ -503,7 +498,7 @@ are comparable with eqv?. A tmp slot may be used."
call-slots
(compute-tmp-slot pre-live
call-slots)))
- (result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
+ (result-vars (vector-ref defv (label->idx kargs)))
(value-slots (map (cut + proc-slot 1 <>)
(iota (length result-vars))))
;; Shuffle the first result down to the lowest slot, and
@@ -547,7 +542,7 @@ are comparable with eqv?. A tmp slot may be used."
(make-call-allocation proc-slot arg-moves #f))))))
(define (allocate-values label k uses pre-live post-live)
- (match (vector-ref contv (cfa-k-idx cfa k))
+ (match (lookup-cont k dfg)
(($ $ktail)
(let* ((src-slots (map (cut vector-ref slots <>) uses))
(tail-nlocals (1+ (length uses)))
@@ -565,12 +560,12 @@ are comparable with eqv?. A tmp slot may be used."
;; slot, we can't really compute the parallel moves in that
;; case, so just bail and rely on the bytecode emitter to
;; handle the one-value case specially.
- (match (cons uses (vector-ref defv (cfa-k-idx cfa k)))
+ (match (cons uses (vector-ref defv (label->idx k)))
(((src) . (dst))
(allocate! dst (vector-ref slots src) post-live))))
(($ $kargs)
(let* ((src-slots (map (cut vector-ref slots <>) uses))
- (dst-vars (vector-ref defv (cfa-k-idx cfa k)))
+ (dst-vars (vector-ref defv (label->idx k)))
(result-live (fold allocate! post-live dst-vars src-slots))
(dst-slots (map (cut vector-ref slots <>) dst-vars))
(moves (parallel-move src-slots dst-slots
@@ -581,11 +576,11 @@ are comparable with eqv?. A tmp slot may be used."
(($ $kif) #f)))
(define (allocate-prompt label k handler nargs)
- (match (vector-ref contv (cfa-k-idx cfa handler))
+ (match (lookup-cont handler dfg)
(($ $kreceive arity kargs)
(let* ((handler-live (recompute-live-slots handler nargs))
(proc-slot (compute-prompt-handler-proc-slot handler-live))
- (result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
+ (result-vars (vector-ref defv (label->idx kargs)))
(value-slots (map (cut + proc-slot 1 <>)
(iota (length result-vars))))
(result-live (fold allocate!
@@ -611,23 +606,23 @@ are comparable with eqv?. A tmp slot may be used."
;; before it, in reverse post-order.
(define (visit-clause n nargs live)
(let lp ((n n) (live live))
- (define (kill-dead live vars-by-cfa-idx pred)
+ (define (kill-dead live vars-by-label-idx pred)
(fold (lambda (v live)
(let ((slot (vector-ref slots v)))
(if (and slot
(> slot nargs)
- (pred (cfa-k-sym cfa n) v dfa))
+ (pred (idx->label n) v dfa))
(kill-dead-slot slot live)
live)))
live
- (vector-ref vars-by-cfa-idx n)))
+ (vector-ref vars-by-label-idx n)))
(define (kill-dead-defs live)
(kill-dead live defv dead-after-def?))
(define (kill-dead-uses live)
(kill-dead live usev dead-after-use?))
- (if (= n (cfa-k-count cfa))
+ (if (= n label-count)
n
- (let* ((label (cfa-k-sym cfa n))
+ (let* ((label (idx->label n))
(live (if (control-point? label dfg)
(recompute-live-slots label nargs)
live))
@@ -636,7 +631,7 @@ are comparable with eqv?. A tmp slot may be used."
;; LIVE are the live slots coming into the term.
;; POST-LIVE is the subset that is still live after the
;; term uses its inputs.
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kclause) n)
(($ $kargs names syms body)
(let ((uses (vector-ref usev n)))
@@ -658,28 +653,27 @@ are comparable with eqv?. A tmp slot may be used."
(unless (eqv? live (add-live-slot 0 (empty-live-slots)))
(error "Unexpected clause live set"))
(set! nlocals 1)
- (match (vector-ref contv n)
+ (match (lookup-cont (idx->label n) dfg)
(($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate)
- (unless (eq? (cfa-k-sym cfa (1+ n)) kbody)
- (error "Unexpected CFA order"))
+ (unless (eq? (idx->label (1+ n)) kbody)
+ (error "Unexpected label order"))
(let* ((nargs (length names))
(next (visit-clause (1+ n)
nargs
(fold allocate! live
(vector-ref defv (1+ n))
(cdr (iota (1+ nargs)))))))
- (hashq-set! nlocals-table (cfa-k-sym cfa n) nlocals)
- (when (< next (cfa-k-count cfa))
+ (hashq-set! nlocals-table (idx->label n) nlocals)
+ (when (< next label-count)
(match alternate
(($ $cont kalt)
- (unless (eq? kalt (cfa-k-sym cfa next))
+ (unless (eq? kalt (idx->label next))
(error "Unexpected clause order"))))
(visit-clauses next live))))))
- (match (vector-ref contv 0)
+ (match (lookup-cont (idx->label 0) dfg)
(($ $kentry self)
(visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
- (compute-conts!)
(compute-constants!)
(compute-uses-and-defs!)
(compute-unused-results!)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-856-g545274a,
Andy Wingo <=