[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-881-g5e8f5eb
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-881-g5e8f5eb |
|
Date: |
Fri, 04 Apr 2014 14:51:41 +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=5e8f5ebaf371c95d898e2d46c5fd99fda5a5e157
The branch, master has been updated
via 5e8f5ebaf371c95d898e2d46c5fd99fda5a5e157 (commit)
via 8c6a0b7e137d97a2c42c6a0008c7cfaa23d04ac5 (commit)
via 780ad383bb43d8a1dfcc4da32c48eaac00f8ec14 (commit)
via 7a08e479672e1ab31da0dfcdc2d026d8d4e70600 (commit)
via a11778dd8e5e6e73ed5c72bc42da954826774f5c (commit)
via b764157a7ba4f56281327b096e1c78d916b39fc0 (commit)
via 36aeda5b6a25048bd1d8bc939662a31f2cbdee34 (commit)
via f85ce39610ca388d1f030d0271c3f22ac8212805 (commit)
via 19ceadab5154af4c9e28ebe573da79db618e0bc9 (commit)
via f5fcd7f2031896cdbdc449b7c1c7305d0b9b425e (commit)
via 54c7882a759a08c4ef3d79f7d9b1aa8ed53322ac (commit)
via 3e1b97c1b06b76ef178ffd2ffe68a1babc86333c (commit)
from af11242268c22fb80a102e66f142e0073f7889cc (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 5e8f5ebaf371c95d898e2d46c5fd99fda5a5e157
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 16:49:59 2014 +0200
Fix coverage expectations
* test-suite/tests/coverage.test ("line-execution-counts"): Update
expectations. Since there's nothing to do at the loop header and the
renaming of X happens at the end of the loops, the compiled code only
sees the loop header once.
commit 8c6a0b7e137d97a2c42c6a0008c7cfaa23d04ac5
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 14:29:11 2014 +0200
More bailout preparation work
* module/language/cps/cse.scm (compute-available-expressions): Compute a
bailout set -- or at least, set things up so that we can do so.
(compute-idoms): Don't add predecessors that bail out.
(apply-cse, cse, compute-equivalent-subexpressions): Thread the
bailout set through the computations.
commit 780ad383bb43d8a1dfcc4da32c48eaac00f8ec14
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 13:42:54 2014 +0200
Prepare for CSE bailout propagation
* module/language/cps/cse.scm (compute-available-expressions): Prepare
for being able to prune joins from bailouts. Always loop after the
first iteration.
* module/language/cps/effects-analysis.scm: Remove &possible-bailout.
Rename &definite-bailout to &bailout, and rename
&all-effects-but-bailout to &unknown-effects.
commit 7a08e479672e1ab31da0dfcdc2d026d8d4e70600
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 12:15:10 2014 +0200
Add common subexpression elimination pass on CPS
* module/language/cps/cse.scm: New file.
* module/language/cps/compile-bytecode.scm: Wire up CSE, on by default.
Currently using the #:cps-cse? keyword.
* module/Makefile.am: Add new file.
commit a11778dd8e5e6e73ed5c72bc42da954826774f5c
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 12:08:52 2014 +0200
Effects analysis tweaks
* module/language/cps/effects-analysis.scm: Add &fluid-environment
effect, a dependency of fluid-ref and fluid-set!, and an effect of
push-fluid/pop-fluid.
(list): Depend on &cdr.
(resolve, cached-toplevel-box, cached-module-box): Don't depend on
&box.
commit b764157a7ba4f56281327b096e1c78d916b39fc0
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 12:07:24 2014 +0200
Fix verify-cps to work
* module/language/cps/verify.scm (verify-cps): Relax requirements for
variable names to be symbols.
commit 36aeda5b6a25048bd1d8bc939662a31f2cbdee34
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 12:06:59 2014 +0200
constant-needs-allocation? fix
* module/language/cps/dfg.scm (constant-needs-allocation?): Constants
need allocation when they are used as a slot-needing operand, not when
they are not used as an immediate operand. Fixes the case where one
var is used in both ways after CSE, in struct-set!/immediate.
commit f85ce39610ca388d1f030d0271c3f22ac8212805
Author: Andy Wingo <address@hidden>
Date: Fri Apr 4 10:39:42 2014 +0200
Remove variable-set! clause from compile-fun
* module/language/cps/compile-bytecode.scm (compile-fun): Remove
vestigial `variable-set!' clause.
commit 19ceadab5154af4c9e28ebe573da79db618e0bc9
Author: Andy Wingo <address@hidden>
Date: Thu Apr 3 16:37:07 2014 +0200
Effects analysis: define causes-all-effects?
* module/language/cps/effects-analysis.scm (causes-all-effects?): New
export.
commit f5fcd7f2031896cdbdc449b7c1c7305d0b9b425e
Author: Andy Wingo <address@hidden>
Date: Thu Apr 3 16:36:23 2014 +0200
build-cps niceties
* module/language/cps.scm (build-cps-exp, build-cont-body): Respect
unquote in list builders (kargs, call, callk, primcall, and values).
commit 54c7882a759a08c4ef3d79f7d9b1aa8ed53322ac
Author: Andy Wingo <address@hidden>
Date: Thu Apr 3 09:40:18 2014 +0200
Minor CSE optimization
* module/language/tree-il/cse.scm (cse): Use hashq instead of modulo to
convert a full-width hash value to a vector index.
commit 3e1b97c1b06b76ef178ffd2ffe68a1babc86333c
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 16:25:07 2014 +0200
Add with-fresh-name-state-from-dfg
* module/language/cps/dfg.scm (with-fresh-name-state-from-dfg): New
helper.
($dfg, compute-dfg): Store max-var and max-label in the dfg.
* module/language/cps.scm (with-fresh-name-state): Don't raise an error
on recursive invocation; that was mostly useful when finding a bug.
* module/language/cps/arities.scm (fix-arities):
* module/language/cps/specialize-primcalls.scm (specialize-primcalls):
Use the new helper.
* .dir-locals.el: Update.
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 1 +
module/Makefile.am | 1 +
module/language/cps.scm | 21 +-
module/language/cps/arities.scm | 5 +-
module/language/cps/compile-bytecode.scm | 4 +-
module/language/cps/cse.scm | 465 ++++++++++++++++++++++++++
module/language/cps/dfg.scm | 41 ++-
module/language/cps/effects-analysis.scm | 80 +++---
module/language/cps/specialize-primcalls.scm | 4 +-
module/language/cps/verify.scm | 8 +-
module/language/tree-il/cse.scm | 4 +-
test-suite/tests/coverage.test | 6 +-
12 files changed, 562 insertions(+), 78 deletions(-)
create mode 100644 module/language/cps/cse.scm
diff --git a/.dir-locals.el b/.dir-locals.el
index 2efca64..597f741 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -14,6 +14,7 @@
(eval . (put 'let-gensyms 'scheme-indent-function 1))
(eval . (put 'let-fresh 'scheme-indent-function 2))
(eval . (put 'with-fresh-name-state 'scheme-indent-function 1))
+ (eval . (put 'with-fresh-name-state-from-dfg 'scheme-indent-function 1))
(eval . (put 'build-cps-term 'scheme-indent-function 0))
(eval . (put 'build-cps-exp 'scheme-indent-function 0))
(eval . (put 'build-cps-cont 'scheme-indent-function 0))
diff --git a/module/Makefile.am b/module/Makefile.am
index 0e2ce6d..783173e 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -124,6 +124,7 @@ CPS_LANG_SOURCES =
\
language/cps/compile-bytecode.scm \
language/cps/constructors.scm \
language/cps/contification.scm \
+ language/cps/cse.scm \
language/cps/dce.scm \
language/cps/dfg.scm \
language/cps/effects-analysis.scm \
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 90f38a4..f546628 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -215,15 +215,12 @@
body ...))
(define-syntax-rule (with-fresh-name-state fun body ...)
- (begin
- (when (or (label-counter) (var-counter))
- (error "with-fresh-name-state should not be called recursively"))
- (call-with-values (lambda ()
- (compute-max-label-and-var fun))
- (lambda (max-label max-var)
- (parameterize ((label-counter (1+ max-label))
- (var-counter (1+ max-var)))
- body ...)))))
+ (call-with-values (lambda ()
+ (compute-max-label-and-var fun))
+ (lambda (max-label max-var)
+ (parameterize ((label-counter (1+ max-label))
+ (var-counter (1+ max-var)))
+ body ...))))
(define-syntax build-arity
(syntax-rules (unquote)
@@ -239,6 +236,8 @@
(make-$kif kt kf))
((_ ($kreceive req rest kargs))
(make-$kreceive (make-$arity req '() rest '() #f) kargs))
+ ((_ ($kargs (name ...) (unquote syms) body))
+ (make-$kargs (list name ...) syms (build-cps-term body)))
((_ ($kargs (name ...) (sym ...) body))
(make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
((_ ($kargs names syms body))
@@ -265,12 +264,16 @@
((_ ($prim name)) (make-$prim name))
((_ ($fun src meta free body))
(make-$fun src meta free (build-cps-cont body)))
+ ((_ ($call proc (unquote args))) (make-$call proc args))
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
+ ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
((_ ($callk k proc args)) (make-$callk k proc args))
+ ((_ ($primcall name (unquote args))) (make-$primcall name args))
((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($values (unquote args))) (make-$values args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
((_ ($prompt escape? tag handler))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index b470ba1..8b9ce41 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -190,5 +190,6 @@
($fun src meta free ,(fix-clause-arities body dfg)))))
(define (fix-arities fun)
- (with-fresh-name-state fun
- (fix-arities* fun (compute-dfg fun))))
+ (let ((dfg (compute-dfg fun)))
+ (with-fresh-name-state-from-dfg dfg
+ (fix-arities* fun dfg))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index c016e11..9924902 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -31,6 +31,7 @@
#:use-module (language cps closure-conversion)
#:use-module (language cps contification)
#:use-module (language cps constructors)
+ #:use-module (language cps cse)
#:use-module (language cps dce)
#:use-module (language cps dfg)
#:use-module (language cps elide-values)
@@ -68,6 +69,7 @@
(exp (run-pass exp inline-constructors #:inline-constructors? #t))
(exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
(exp (run-pass exp elide-values #:elide-values? #t))
+ (exp (run-pass exp eliminate-common-subexpressions #:cps-cse? #t))
(exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
(exp (run-pass exp simplify #:simplify? #t)))
;; Passes that are needed:
@@ -329,8 +331,6 @@
(($ $primcall 'vector-set!/immediate (vector index value))
(emit-vector-set!/immediate asm (slot vector) (constant index)
(slot value)))
- (($ $primcall 'variable-set! (var val))
- (emit-box-set! asm (slot var) (slot val)))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(($ $primcall 'set-cdr! (pair value))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
new file mode 100644
index 0000000..bc0da12
--- /dev/null
+++ b/module/language/cps/cse.scm
@@ -0,0 +1,465 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; Common subexpression elimination for CPS.
+;;;
+;;; Code:
+
+(define-module (language cps cse)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps effects-analysis)
+ #:use-module (language cps renumber)
+ #:export (eliminate-common-subexpressions))
+
+(define (compute-always-available-expressions effects)
+ "Return the set of continuations whose values are always available
+within their dominance frontier. This is the case for effects that have
+no dependencies and which cause no effects besides &type-check."
+ (let ((out (make-bitvector (vector-length effects) #f)))
+ (let lp ((n 0))
+ (cond
+ ((< n (vector-length effects))
+ (when (zero? (exclude-effects (vector-ref effects n) &type-check))
+ (bitvector-set! out n #t))
+ (lp (1+ n)))
+ (else out)))))
+
+(define (compute-available-expressions dfg min-label label-count)
+ "Compute and return the continuations that may be reached if flow
+reaches a continuation N. Returns a vector of bitvectors, whose first
+index corresponds to MIN-LABEL, and so on."
+ (let* ((effects (compute-effects dfg min-label label-count))
+ (always-avail (compute-always-available-expressions effects))
+ ;; Vector of bitvectors, indicating that at a continuation N,
+ ;; the values from continuations M... are available.
+ (avail-in (make-vector label-count #f))
+ (avail-out (make-vector label-count #f))
+ (bailouts (make-bitvector label-count #f)))
+
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+
+ (define (for-each f l)
+ (let lp ((l l))
+ (when (pair? l)
+ (f (car l))
+ (lp (cdr l)))))
+
+ (let lp ((n 0))
+ (when (< n label-count)
+ (let ((in (make-bitvector label-count #f))
+ (out (make-bitvector label-count #f)))
+ (vector-set! avail-in n in)
+ (vector-set! avail-out n out)
+ #;
+ (bitvector-set! bailouts n
+ (causes-effects? (vector-ref effects n) &bailout))
+ (lp (1+ n)))))
+
+ (let ((tmp (make-bitvector label-count #f)))
+ (define (bitvector-copy! dst src)
+ (bitvector-fill! dst #f)
+ (bit-set*! dst src #t))
+ (define (intersect! dst src)
+ (bitvector-copy! tmp src)
+ (bit-invert! tmp)
+ (bit-set*! dst tmp #f))
+ (let lp ((n 0) (first? #t) (changed? #f))
+ (cond
+ ((< n label-count)
+ (let* ((in (vector-ref avail-in n))
+ (prev-count (bit-count #t in))
+ (out (vector-ref avail-out n))
+ (fx (vector-ref effects n)))
+ ;; Intersect avail-out from predecessors into "in".
+ (let lp ((preds (lookup-predecessors (idx->label n) dfg))
+ (initialized? #f))
+ (match preds
+ (() #t)
+ ((pred . preds)
+ (let ((pred (label->idx pred)))
+ (cond
+ ((or (and first? (<= n pred))
+ ;; Here it would be nice to avoid intersecting
+ ;; with predecessors that bail out, which might
+ ;; allow expressions from the other (if there's
+ ;; only one) predecessor to propagate past the
+ ;; join. However that would require the tree
+ ;; to be rewritten so that the successor is
+ ;; correctly scoped, and gets the right
+ ;; dominator. Punt for now.
+
+ ;; (bitvector-ref bailouts pred)
+ )
+ ;; Avoid intersecting back-edges and cross-edges on
+ ;; the first iteration.
+ (lp preds initialized?))
+ (else
+ (if initialized?
+ (intersect! in (vector-ref avail-out pred))
+ (bitvector-copy! in (vector-ref avail-out pred)))
+ (lp preds #t)))))))
+ (let ((new-count (bit-count #t in)))
+ (unless (= prev-count new-count)
+ ;; Copy "in" to "out".
+ (bitvector-copy! out in)
+ ;; Kill expressions that don't commute.
+ (cond
+ ((causes-all-effects? fx &unknown-effects)
+ ;; Fast-path if this expression clobbers the world.
+ (intersect! out always-avail))
+ ((effect-free? (exclude-effects fx &type-check))
+ ;; Fast-path if this expression clobbers nothing.
+ #t)
+ (else
+ ;; Loop of sadness.
+ (bitvector-copy! tmp out)
+ (bit-set*! tmp always-avail #f)
+ (let lp ((i 0))
+ (let ((i (bit-position #t tmp i)))
+ (when i
+ (unless (effects-commute? (vector-ref effects i) fx)
+ (bitvector-set! out i #f))
+ (lp (1+ i))))))))
+ ;; Unless this expression allocates a fresh object or
+ ;; changes the current fluid environment, mark expressions
+ ;; that match it as available for elimination.
+ (unless (causes-effects? fx (logior &fluid-environment
+ &allocation))
+ (bitvector-set! out n #t))
+ (lp (1+ n) first? (or changed? (not (= prev-count
new-count)))))))
+ (else
+ (if (or first? changed?)
+ (lp 0 #f #f)
+ (values avail-in bailouts))))))))
+
+(define (compute-defs dfg min-label label-count)
+ (define (cont-defs k)
+ (match (lookup-cont k dfg)
+ (($ $kargs names vars) vars)
+ (_ '())))
+ (define (idx->label idx) (+ idx min-label))
+ (let ((defs (make-vector label-count '())))
+ (let lp ((n 0))
+ (when (< n label-count)
+ (vector-set!
+ defs
+ n
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kargs _ _ body)
+ (match (find-call body)
+ (($ $continue k) (cont-defs k))))
+ (($ $kreceive arity kargs)
+ (cont-defs kargs))
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
+ syms)
+ (($ $kif) '())
+ (($ $kentry self) (list self))
+ (($ $ktail) '())))
+ (lp (1+ n))))
+ defs))
+
+(define (compute-label-and-var-ranges fun)
+ (match fun
+ (($ $fun src meta free ($ $cont kentry ($ $kentry self)))
+ ((make-cont-folder #f min-label label-count min-var var-count)
+ (lambda (k cont min-label label-count min-var var-count)
+ (let ((min-label (min k min-label))
+ (label-count (1+ label-count)))
+ (match cont
+ (($ $kargs names vars body)
+ (let lp ((body body)
+ (min-var (fold min min-var vars))
+ (var-count (+ var-count (length vars))))
+ (match body
+ (($ $letrec names vars funs body)
+ (lp body
+ (fold min min-var vars)
+ (+ var-count (length vars))))
+ (($ $letk conts body) (lp body min-var var-count))
+ (_ (values min-label label-count min-var var-count)))))
+ (($ $kentry self)
+ (values min-label label-count (min self min-var) (1+ var-count)))
+ (_
+ (values min-label label-count min-var var-count)))))
+ fun kentry 0 self 0))))
+
+(define (compute-idoms dfg bailouts min-label label-count)
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (let ((idoms (make-vector label-count #f)))
+ (define (common-idom d0 d1)
+ ;; We exploit the fact that a reverse post-order is a topological
+ ;; sort, and so the idom of a node is always numerically less than
+ ;; the node itself.
+ (cond
+ ((= d0 d1) d0)
+ ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
+ (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
+ (define (compute-idom preds)
+ (define (has-idom? pred)
+ (and (vector-ref idoms (label->idx pred))
+ (not (bitvector-ref bailouts (label->idx pred)))))
+ (match preds
+ (() min-label)
+ ((pred . preds)
+ (if (has-idom? pred)
+ (let lp ((idom pred) (preds preds))
+ (match preds
+ (() idom)
+ ((pred . preds)
+ (lp (if (has-idom? pred)
+ (common-idom idom pred)
+ idom)
+ preds))))
+ (compute-idom preds)))))
+ ;; This is the iterative O(n^2) fixpoint algorithm, originally from
+ ;; Allen and Cocke ("Graph-theoretic constructs for program flow
+ ;; analysis", 1972). See the discussion in Cooper, Harvey, and
+ ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
+ (let iterate ((n 0) (changed? #f))
+ (cond
+ ((< n label-count)
+ (let ((idom (vector-ref idoms n))
+ (idom* (compute-idom (lookup-predecessors (idx->label n) dfg))))
+ (cond
+ ((eqv? idom idom*)
+ (iterate (1+ n) changed?))
+ (else
+ (vector-set! idoms n idom*)
+ (iterate (1+ n) #t)))))
+ (changed?
+ (iterate 0 #f))
+ (else idoms)))))
+
+;; Compute a vector containing, for each node, a list of the nodes that
+;; it immediately dominates. These are the "D" edges in the DJ tree.
+(define (compute-dom-edges idoms min-label)
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (define (vector-push! vec idx val)
+ (let ((v vec) (i idx))
+ (vector-set! v i (cons val (vector-ref v i)))))
+ (let ((doms (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length idoms))
+ (let ((idom (vector-ref idoms n)))
+ (vector-push! doms (label->idx idom) (idx->label n)))
+ (lp (1+ n))))
+ doms))
+
+(define (compute-equivalent-subexpressions fun dfg)
+ (define (compute min-label label-count min-var var-count avail bailouts)
+ (let ((idoms (compute-idoms dfg bailouts min-label label-count))
+ (defs (compute-defs dfg min-label label-count))
+ (var-substs (make-vector var-count #f))
+ (label-substs (make-vector label-count #f))
+ (equiv-set (make-hash-table)))
+ (define (idx->label idx) (+ idx min-label))
+ (define (label->idx label) (- label min-label))
+ (define (idx->var idx) (+ idx min-var))
+ (define (var->idx var) (- var min-var))
+
+ (define (subst-var var)
+ ;; It could be that the var is free in this function; if so, its
+ ;; name will be less than min-var.
+ (let ((idx (var->idx var)))
+ (if (<= 0 idx)
+ (vector-ref var-substs idx)
+ var)))
+
+ (define (compute-exp-key exp)
+ (match exp
+ (($ $void) 'void)
+ (($ $const val) (cons 'const val))
+ (($ $prim name) (cons 'prim name))
+ (($ $fun src meta free body) #f)
+ (($ $call proc args) #f)
+ (($ $callk k proc args) #f)
+ (($ $primcall name args)
+ (cons* 'primcall name (map subst-var args)))
+ (($ $values args) #f)
+ (($ $prompt escape? tag handler) #f)))
+
+ ;; The initial substs vector is the identity map.
+ (let lp ((var min-var))
+ (when (< (var->idx var) var-count)
+ (vector-set! var-substs (var->idx var) var)
+ (lp (1+ var))))
+
+ ;; Traverse the labels in fun in forward order, which will visit
+ ;; dominators first.
+ (let lp ((label min-label))
+ (when (< (label->idx label) label-count)
+ (match (lookup-cont label dfg)
+ (($ $kargs names vars body)
+ (match (find-call body)
+ (($ $continue k src exp)
+ (let* ((exp-key (compute-exp-key exp))
+ (equiv (hash-ref equiv-set exp-key '()))
+ (avail (vector-ref avail (label->idx label))))
+ (let lp ((candidates equiv))
+ (match candidates
+ (()
+ ;; No matching expressions. Add our expression
+ ;; to the equivalence set, if appropriate.
+ (when exp-key
+ (hash-set! equiv-set exp-key (cons label equiv))))
+ ((candidate . candidates)
+ (let ((subst (vector-ref defs (label->idx candidate))))
+ (cond
+ ((not (bitvector-ref avail (label->idx candidate)))
+ ;; This expression isn't available here; try
+ ;; the next one.
+ (lp candidates))
+ (else
+ ;; Yay, a match. Mark expression for
+ ;; replacement with $values.
+ (vector-set! label-substs (label->idx label) subst)
+ ;; If we dominate the successor, mark vars
+ ;; for substitution.
+ (when (= label (vector-ref idoms (label->idx k)))
+ (for-each
+ (lambda (var subst-var)
+ (vector-set! var-substs (var->idx var)
subst-var))
+ (vector-ref defs (label->idx label))
+ subst))))))))))))
+ (_ #f))
+ (lp (1+ label))))
+ (values (compute-dom-edges idoms min-label)
+ label-substs min-label var-substs min-var
+ bailouts)))
+
+ (call-with-values (lambda () (compute-label-and-var-ranges fun))
+ (lambda (min-label label-count min-var var-count)
+ (call-with-values
+ (lambda ()
+ (compute-available-expressions dfg min-label label-count))
+ (lambda (avail bailouts)
+ (compute min-label label-count min-var var-count avail bailouts))))))
+
+(define (apply-cse fun dfg doms label-substs min-label var-substs min-var
+ bailouts)
+ (define (idx->label idx) (+ idx min-label))
+ (define (label->idx label) (- label min-label))
+ (define (idx->var idx) (+ idx min-var))
+ (define (var->idx var) (- var min-var))
+
+ (define (subst-var var)
+ ;; It could be that the var is free in this function; if so,
+ ;; its name will be less than min-var.
+ (let ((idx (var->idx var)))
+ (if (<= 0 idx)
+ (vector-ref var-substs idx)
+ var)))
+
+ (define (visit-entry-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body label))))
+ (($ $cont label ($ $kentry self tail clause))
+ (label ($kentry self ,tail
+ ,(and clause (visit-entry-cont clause)))))
+ (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
+ (label ($kclause ,arity ,(visit-cont kbody body)
+ ,(and alternate (visit-entry-cont alternate)))))))
+
+ (define (visit-cont label cont)
+ (rewrite-cps-cont cont
+ (($ $kargs names vars body)
+ (label ($kargs names vars ,(visit-term body label))))
+ (_ (label ,cont))))
+
+ (define (visit-term term label)
+ (define (visit-exp exp)
+ ;; We shouldn't see $fun here.
+ (rewrite-cps-exp exp
+ ((or ($ $void) ($ $const) ($ $prim)) ,exp)
+ (($ $call proc args)
+ ($call (subst-var proc) ,(map subst-var args)))
+ (($ $callk k proc args)
+ ($callk k (subst-var proc) ,(map subst-var args)))
+ (($ $primcall name args)
+ ($primcall name ,(map subst-var args)))
+ (($ $values args)
+ ($values ,(map subst-var args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst-var tag) handler))))
+
+ (define (visit-exp* k exp)
+ (match exp
+ ((and fun ($ $fun)) (cse fun dfg))
+ (_
+ (match (lookup-cont k dfg)
+ (($ $kargs names vars)
+ (cond
+ ((vector-ref label-substs (label->idx label))
+ => (lambda (vars)
+ (build-cps-exp ($values vars))))
+ (else (visit-exp exp))))
+ (_ (visit-exp exp))))))
+
+ (define (visit-dom-conts label)
+ (let ((cont (lookup-cont label dfg)))
+ (match cont
+ (($ $ktail) '())
+ (($ $kargs) (list (visit-cont label cont)))
+ (else
+ (cons (visit-cont label cont)
+ (append-map visit-dom-conts
+ (vector-ref doms (label->idx label))))))))
+
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ,(visit-term body label))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map (lambda (fun) (cse fun dfg)) funs)
+ ,(visit-term body label)))
+ (($ $continue k src exp)
+ ,(let* ((k (if (bitvector-ref bailouts (label->idx label))
+ (match fun
+ (($ $fun src meta free ($ $kentry self ($ $cont
ktail)))
+ ktail))
+ k))
+ (exp (visit-exp* k exp))
+ (conts (append-map visit-dom-conts
+ (vector-ref doms (label->idx label)))))
+ (if (null? conts)
+ (build-cps-term ($continue k src ,exp))
+ (build-cps-term ($letk ,conts ($continue k src ,exp))))))))
+
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta (map subst-var free) ,(visit-entry-cont body)))))
+
+;; TODO: Bailout branches, truth values, and interprocedural CSE.
+(define (cse fun dfg)
+ (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
+ (lambda (doms label-substs min-label var-substs min-var bailouts)
+ (apply-cse fun dfg doms label-substs min-label var-substs min-var
+ bailouts))))
+
+(define (eliminate-common-subexpressions fun)
+ (call-with-values (lambda () (renumber fun))
+ (lambda (fun nlabels nvars)
+ (cse fun (compute-dfg fun)))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index c52093a..3180e3d 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -49,6 +49,7 @@
dfg-label-count
dfg-min-var
dfg-var-count
+ with-fresh-name-state-from-dfg
lookup-def
lookup-uses
lookup-predecessors
@@ -102,7 +103,8 @@
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
(make-dfg conts preds defs uses scopes scope-levels
- min-label label-count min-var var-count)
+ min-label max-label label-count
+ min-var max-var var-count)
dfg?
;; vector of label -> $kif, $kargs, etc
(conts dfg-cont-table)
@@ -118,8 +120,11 @@
(scope-levels dfg-scope-levels)
(min-label dfg-min-label)
+ (max-label dfg-max-label)
(label-count dfg-label-count)
+
(min-var dfg-min-var)
+ (max-var dfg-max-var)
(var-count dfg-var-count))
(define-inlinable (vector-push! vec idx val)
@@ -905,7 +910,13 @@ body continuation in the prompt."
(visit-fun fun conts preds defs uses scopes scope-levels
min-label min-var global?)
(make-dfg conts preds defs uses scopes scope-levels
- min-label label-count min-var var-count)))))
+ min-label max-label label-count
+ min-var max-var var-count)))))
+
+(define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
+ (parameterize ((label-counter (1+ (dfg-max-label dfg)))
+ (var-counter (1+ (dfg-max-var dfg))))
+ body ...))
(define (lookup-cont label dfg)
(let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
@@ -968,13 +979,13 @@ body continuation in the prompt."
(else
(values #f #f))))
-(define (constant-needs-allocation? sym val dfg)
+(define (constant-needs-allocation? var val dfg)
(define (immediate-u8? val)
(and (integer? val) (exact? val) (<= 0 val 255)))
(define (find-exp term)
(match term
- (($ $kargs names syms body) (find-exp body))
+ (($ $kargs names vars body) (find-exp body))
(($ $letk conts body) (find-exp body))
(else term)))
@@ -985,33 +996,33 @@ body continuation in the prompt."
(($ $callk) #f)
(($ $values) #f)
(($ $primcall 'free-ref (closure slot))
- (not (eq? sym slot)))
+ (eq? var closure))
(($ $primcall 'free-set! (closure slot value))
- (not (eq? sym slot)))
+ (or (eq? var closure) (eq? var value)))
(($ $primcall 'cache-current-module! (mod . _))
- (eq? sym mod))
+ (eq? var mod))
(($ $primcall 'cached-toplevel-box _)
#f)
(($ $primcall 'cached-module-box _)
#f)
(($ $primcall 'resolve (name bound?))
- (eq? sym name))
+ (eq? var name))
(($ $primcall 'make-vector/immediate (len init))
- (not (eq? sym len)))
+ (eq? var init))
(($ $primcall 'vector-ref/immediate (v i))
- (not (eq? sym i)))
+ (eq? var v))
(($ $primcall 'vector-set!/immediate (v i x))
- (not (eq? sym i)))
+ (or (eq? var v) (eq? var x)))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
- (not (eq? sym nfields)))
+ (eq? var vtable))
(($ $primcall 'struct-ref/immediate (s n))
- (not (eq? sym n)))
+ (eq? var s))
(($ $primcall 'struct-set!/immediate (s n x))
- (not (eq? sym n)))
+ (or (eq? var s) (eq? var x)))
(($ $primcall 'builtin-ref (idx))
#f)
(_ #t)))
- (vector-ref (dfg-uses dfg) (- sym (dfg-min-var dfg)))))
+ (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))))
(define (continuation-scope-contains? scope-k k dfg)
(let ((scope-level (lookup-scope-level scope-k dfg)))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 8601e35..215ecfb 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -47,9 +47,9 @@
compute-effects
&fluid
+ &fluid-environment
&prompt
- &definite-bailout
- &possible-bailout
+ &bailout
&allocation
&car
&cdr
@@ -63,14 +63,15 @@
&no-effects
&all-effects
- &all-effects-but-bailout
+ &unknown-effects
effects-commute?
exclude-effects
effect-free?
constant?
depends-on-effects?
- causes-effects?))
+ causes-effects?
+ causes-all-effects?))
(define-syntax define-effects
(lambda (x)
@@ -110,16 +111,16 @@
;; variable.
&fluid
+ ;; Indicates that an expression depends on the current fluid environment.
+ &fluid-environment
+
;; Indicates that an expression depends on the current prompt
;; stack.
&prompt
;; Indicates that an expression definitely causes a non-local,
;; non-resumable exit -- a bailout. Only used in the "changes" sense.
- &definite-bailout
-
- ;; Indicates that an expression may cause a bailout.
- &possible-bailout
+ &bailout
;; Indicates that an expression may return a fresh object -- a
;; "causes" effect.
@@ -181,8 +182,7 @@
(define-effects &all-effects
&fluid
&prompt
- &definite-bailout
- &possible-bailout
+ &bailout
&allocation
&car
&cdr
@@ -193,6 +193,7 @@
&string
&bytevector
&type-check)
+ (define-syntax &fluid-environment (identifier-syntax &fluid))
(define-syntax &struct-0 (identifier-syntax &struct))
(define-syntax &struct-1 (identifier-syntax &struct))
(define-syntax &struct-2 (identifier-syntax &struct))
@@ -203,16 +204,12 @@
(define-syntax &no-effects (identifier-syntax 0))
-;; Definite bailout is an oddball effect. Since it indicates that an
-;; expression definitely causes bailout, it's not in the set of effects
-;; of a call to an unknown procedure. At the same time, it's also
-;; special in that a definite bailout in a subexpression doesn't always
-;; cause an outer expression to include &definite-bailout in its
-;; effects. For that reason we have to treat it specially.
+;; An expression with unknown effects can cause any effect, except
+;; &bailout (which indicates certain bailout).
;;
-(define-syntax &all-effects-but-bailout
+(define-syntax &unknown-effects
(identifier-syntax
- (logand &all-effects (lognot &definite-bailout))))
+ (logand &all-effects (lognot &bailout))))
(define-inlinable (cause effect)
(ash effect 1))
@@ -233,6 +230,8 @@
(not (zero? (logand (&depends-on x) effects))))
(define-inlinable (causes-effects? x effects)
(not (zero? (logand (&causes x) (cause effects)))))
+(define-inlinable (causes-all-effects? x effects)
+ (= (logand (&causes x) (cause effects)) (cause effects)))
(define-inlinable (effects-commute? a b)
(and (not (causes-effects? a (&depends-on b)))
@@ -249,8 +248,7 @@
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda* ((dfg . args) effects)
- (_ (logior (cause &possible-bailout)
- (cause &definite-bailout)))))
+ (_ (cause &bailout))))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects) ...)
@@ -269,7 +267,6 @@
((pair? arg) &no-effects)
((null? arg) &no-effects)
((nil? arg ) &no-effects)
- ((list? arg) &no-effects)
((symbol? arg) &no-effects)
((variable? arg) &no-effects)
((vector? arg) &no-effects)
@@ -282,10 +279,14 @@
;; Fluids.
(define-primitive-effects
- ((fluid-ref f) (logior (cause &type-check) &fluid))
- ((fluid-set! f v) (logior (cause &type-check) (cause &fluid)))
- ((push-fluid f v) (logior (cause &type-check) (cause &fluid)))
- ((pop-fluid) (logior (cause &fluid))))
+ ((fluid-ref f)
+ (logior (cause &type-check) &fluid &fluid-environment))
+ ((fluid-set! f v)
+ (logior (cause &type-check) (cause &fluid) &fluid-environment))
+ ((push-fluid f v)
+ (logior (cause &type-check) (cause &fluid-environment)))
+ ((pop-fluid)
+ (logior (cause &fluid-environment))))
;; Prompts.
(define-primitive-effects
@@ -293,9 +294,9 @@
;; Bailout.
(define-primitive-effects
- ((error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
- ((scm-error . _) (logior (cause &definite-bailout) (cause
&possible-bailout)))
- ((throw . _) (logior (cause &definite-bailout) (cause &possible-bailout))))
+ ((error . _) (logior (cause &bailout)))
+ ((scm-error . _) (logior (cause &bailout)))
+ ((throw . _) (logior (cause &bailout))))
;; Pairs.
(define-primitive-effects
@@ -307,6 +308,7 @@
((set-cdr! x y) (logior (cause &type-check) (cause &cdr)))
((memq x y) (logior (cause &type-check) &car &cdr))
((memv x y) (logior (cause &type-check) &car &cdr))
+ ((list? arg) &cdr)
((length l) (logior (cause &type-check) &car &cdr)))
;; Vectors.
@@ -324,12 +326,12 @@
;; Structs.
(define-primitive-effects* dfg
- ((allocate-struct vtable nfields) (logior (cause &type-check)
- (cause &allocation)))
- ((make-struct vtable ntail . args) (logior (cause &type-check)
- (cause &allocation)))
- ((make-struct/no-tail vtable . args) (logior (cause &type-check)
- (cause &allocation)))
+ ((allocate-struct vtable nfields)
+ (logior (cause &type-check) (cause &allocation)))
+ ((make-struct vtable ntail . args)
+ (logior (cause &type-check) (cause &allocation)))
+ ((make-struct/no-tail vtable . args)
+ (logior (cause &type-check) (cause &allocation)))
((struct-ref s n)
(logior (cause &type-check)
(match (lookup-constant-index n dfg)
@@ -436,16 +438,16 @@
(define-primitive-effects
((current-module) &module)
((cache-current-module! mod scope) (cause &box))
- ((resolve name bound?) (logior &box &module (cause &type-check)))
- ((cached-toplevel-box scope name bound?) (logior &box (cause &type-check)))
- ((cached-module-box scope name bound?) (logior &box (cause &type-check)))
+ ((resolve name bound?) (logior &module (cause &type-check)))
+ ((cached-toplevel-box scope name bound?) (cause &type-check))
+ ((cached-module-box scope name bound?) (cause &type-check))
((define! name val) (logior &module (cause &box))))
(define (primitive-effects dfg name args)
(let ((proc (hashq-ref *primitive-effects* name)))
(if proc
(apply proc dfg args)
- (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))))
+ (logior &unknown-effects (cause &unknown-effects)))))
(define (expression-effects exp dfg)
(match exp
@@ -456,7 +458,7 @@
(($ $prompt)
(cause &prompt))
((or ($ $call) ($ $callk))
- (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
+ (logior &unknown-effects (cause &unknown-effects)))
(($ $primcall name args)
(primitive-effects dfg name args))))
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index 6372026..e1283e4 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -31,8 +31,8 @@
#:export (specialize-primcalls))
(define (specialize-primcalls fun)
- (with-fresh-name-state fun
- (let ((dfg (compute-dfg fun #:global? #t)))
+ (let ((dfg (compute-dfg fun #:global? #t)))
+ (with-fresh-name-state-from-dfg dfg
(define (immediate-u8? sym)
(call-with-values (lambda () (find-constant-value sym dfg))
(lambda (has-const? val)
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 9bc082b..d521351 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -77,7 +77,7 @@
(check-label kf k-env))
(($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f)
k)
(check-label k k-env))
- (($ $kargs ((? symbol? name) ...) (sym ...) body)
+ (($ $kargs (name ...) (sym ...) body)
(unless (= (length name) (length sym))
(error "name and sym lengths don't match" name sym))
(visit-term body k-env (add-vars sym v-env)))
@@ -93,7 +93,7 @@
((? symbol? req) ...)
((? symbol? opt) ...)
(and rest (or #f (? symbol?)))
- (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
+ (((? keyword? kw) (? symbol? kwname) kwsym) ...)
(or #f #t))
($ $cont kbody (and body ($ $kargs names syms _)))
alternate))
@@ -141,7 +141,7 @@
#t)
(($ $fun)
(visit-fun exp k-env v-env))
- (($ $call (? symbol? proc) (arg ...))
+ (($ $call proc (arg ...))
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
(($ $callk k* proc (arg ...))
@@ -169,7 +169,7 @@
(for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env)))
- (($ $letrec ((? symbol? name) ...) (sym ...) (fun ...) body)
+ (($ $letrec (name ...) (sym ...) (fun ...) body)
(unless (= (length name) (length sym) (length fun))
(error "letrec syms, names, and funs not same length" term))
(let ((v-env (add-vars sym v-env)))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 5d0277f..d4cf686 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -1,6 +1,6 @@
;;; Common Subexpression Elimination (CSE) on Tree-IL
-;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -194,7 +194,7 @@
(define (hasher n)
- (lambda (x size) (modulo n size)))
+ (lambda (x size) (hashq n size)))
(define (add-to-db exp effects ctx db)
(let ((v (vector exp effects ctx))
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 33b839a..822d06e 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation,
Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -107,8 +107,8 @@
(let ((line (car line+count))
(count (cdr line+count)))
(case line
- ((0 1) (= count 1))
- ((2 3) (= count 78))
+ ((0 1 2) (= count 1))
+ ((3) (= count 78))
((4 5 6) (= count 77))
((7) (= count 1))
((8) (= count 0))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-881-g5e8f5eb,
Andy Wingo <=