[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-888-g9e94cd9
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-888-g9e94cd9 |
|
Date: |
Sat, 05 Apr 2014 10:22:23 +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=9e94cd9bf504b99adbf4f6825ab09efcbf02656f
The branch, master has been updated
via 9e94cd9bf504b99adbf4f6825ab09efcbf02656f (commit)
via 3625351955708d2d2fd56305c560470754623dbd (commit)
via 4fef637362c9225b7ad0b20e4d757f516afa0a56 (commit)
via 9382794ab6b64f8d9015a3d996c9530002f5368a (commit)
via 634638801c72dec6bc09c88c53728f5a17e1a683 (commit)
via 84d3ce20cd12c7f2bf84637bcc4843772d62191a (commit)
via a79f4f67e29253cb195cc73141a16eaaff2c000d (commit)
from 5e8f5ebaf371c95d898e2d46c5fd99fda5a5e157 (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 9e94cd9bf504b99adbf4f6825ab09efcbf02656f
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 12:16:34 2014 +0200
Prune bailouts after contification
* module/language/cps/compile-bytecode.scm (optimize): Prune bailouts
after contifying, so that we return to the tail of the contified
function.
commit 3625351955708d2d2fd56305c560470754623dbd
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 11:56:44 2014 +0200
Match and srfi-9 expose their bailouts to the CSE pass
* module/ice-9/match.upstream.scm (match-next): Inline a call to
"error", so the new CSE pass will see this case as a bailout.
* module/srfi/srfi-9.scm (throw-bad-struct): Reimplement as a syntax
rule, so that the CSE pass sees the "throw" call.
commit 4fef637362c9225b7ad0b20e4d757f516afa0a56
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 11:21:33 2014 +0200
Remove &bailout; replace uses of &unknown-effects with &all-effects
* module/language/cps/effects-analysis.scm (&bailout): Remove effect.
(&unknown-effects): Remove. Replace uses with &all-effects.
* module/language/cps/cse.scm:
commit 9382794ab6b64f8d9015a3d996c9530002f5368a
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 11:18:20 2014 +0200
Remove parts of CSE that deal with bailout
* module/language/cps/cse.scm (compute-available-expressions, cse):
(compute-idoms, compute-equivalent-subexpressions, apply-cse): Remove
attempts to deal with bailout, as the bailout pass handles that
already.
commit 634638801c72dec6bc09c88c53728f5a17e1a683
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 11:08:47 2014 +0200
Add prune-bailouts pass
* module/language/cps/prune-bailouts.scm: New pass.
* module/language/cps/compile-bytecode.scm: Wire it up.
* module/Makefile.am: Add new file.
commit 84d3ce20cd12c7f2bf84637bcc4843772d62191a
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 10:27:26 2014 +0200
Disable Tree-IL CSE
* module/language/tree-il/optimize.scm (optimize): Disable Tree-IL CSE
by default.
commit a79f4f67e29253cb195cc73141a16eaaff2c000d
Author: Andy Wingo <address@hidden>
Date: Sat Apr 5 11:32:06 2014 +0200
Fix effects analysis for cached-module-box
* module/language/cps/effects-analysis.scm (cached-module-box): Fix
expected arity.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 1 +
module/ice-9/match.upstream.scm | 11 +---
module/language/cps/compile-bytecode.scm | 2 +
module/language/cps/cse.scm | 61 +++++--------------
module/language/cps/effects-analysis.scm | 28 +-------
module/language/cps/prune-bailouts.scm | 98 ++++++++++++++++++++++++++++++
module/language/tree-il/optimize.scm | 11 ++--
module/srfi/srfi-9.scm | 12 ++--
8 files changed, 136 insertions(+), 88 deletions(-)
create mode 100644 module/language/cps/prune-bailouts.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 783173e..b3b96d9 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -130,6 +130,7 @@ CPS_LANG_SOURCES =
\
language/cps/effects-analysis.scm \
language/cps/elide-values.scm \
language/cps/primitives.scm \
+ language/cps/prune-bailouts.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
language/cps/renumber.scm \
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index 3d66555..ede1d43 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -280,19 +280,14 @@
;; clauses. `g+s' is a list of two elements, the get! and set!
;; expressions respectively.
-(define (match-error v)
- #((definite-bailout? . #t))
- (error 'match "no matching pattern" v))
-
(define-syntax match-next
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next v g+s)
- ;; Here we call match-error in non-tail context, so that the
- ;; backtrace can show the source location of the failing match
- ;; form.
+ ;; Here we call error in non-tail context, so that the backtrace
+ ;; can show the source location of the failing match form.
(begin
- (match-error v)
+ (error 'match "no matching pattern" v)
#f))
;; named failure continuation
((match-next v g+s (pat (=> failure) . body) . rest)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 9924902..a4d96ad 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -36,6 +36,7 @@
#:use-module (language cps dfg)
#:use-module (language cps elide-values)
#:use-module (language cps primitives)
+ #:use-module (language cps prune-bailouts)
#:use-module (language cps prune-top-level-scopes)
#:use-module (language cps reify-primitives)
#:use-module (language cps renumber)
@@ -69,6 +70,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 prune-bailouts #:prune-bailouts? #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)))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index bc0da12..4f99483 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -53,8 +53,7 @@ index corresponds to MIN-LABEL, and so on."
;; 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)))
+ (avail-out (make-vector label-count #f)))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
@@ -71,9 +70,6 @@ index corresponds to MIN-LABEL, and so on."
(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)))
@@ -99,18 +95,7 @@ index corresponds to MIN-LABEL, and so on."
((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)
- )
+ ((and first? (<= n pred))
;; Avoid intersecting back-edges and cross-edges on
;; the first iteration.
(lp preds initialized?))
@@ -125,7 +110,7 @@ index corresponds to MIN-LABEL, and so on."
(bitvector-copy! out in)
;; Kill expressions that don't commute.
(cond
- ((causes-all-effects? fx &unknown-effects)
+ ((causes-all-effects? fx &all-effects)
;; Fast-path if this expression clobbers the world.
(intersect! out always-avail))
((effect-free? (exclude-effects fx &type-check))
@@ -151,7 +136,7 @@ index corresponds to MIN-LABEL, and so on."
(else
(if (or first? changed?)
(lp 0 #f #f)
- (values avail-in bailouts))))))))
+ avail-in)))))))
(define (compute-defs dfg min-label label-count)
(define (cont-defs k)
@@ -204,7 +189,7 @@ index corresponds to MIN-LABEL, and so on."
(values min-label label-count min-var var-count)))))
fun kentry 0 self 0))))
-(define (compute-idoms dfg bailouts min-label label-count)
+(define (compute-idoms dfg 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)))
@@ -218,8 +203,7 @@ index corresponds to MIN-LABEL, and so on."
(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)))))
+ (vector-ref idoms (label->idx pred)))
(match preds
(() min-label)
((pred . preds)
@@ -269,8 +253,9 @@ index corresponds to MIN-LABEL, and so on."
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))
+ (define (compute min-label label-count min-var var-count)
+ (let ((avail (compute-available-expressions dfg min-label label-count))
+ (idoms (compute-idoms dfg 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))
@@ -347,19 +332,11 @@ index corresponds to MIN-LABEL, and so on."
(_ #f))
(lp (1+ label))))
(values (compute-dom-edges idoms min-label)
- label-substs min-label var-substs min-var
- bailouts)))
+ label-substs min-label var-substs min-var)))
- (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))))))
+ (call-with-values (lambda () (compute-label-and-var-ranges fun)) compute))
-(define (apply-cse fun dfg doms label-substs min-label var-substs min-var
- bailouts)
+(define (apply-cse fun dfg doms label-substs min-label var-substs min-var)
(define (idx->label idx) (+ idx min-label))
(define (label->idx label) (- label min-label))
(define (idx->var idx) (+ idx min-var))
@@ -436,12 +413,7 @@ index corresponds to MIN-LABEL, and so on."
($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))
+ ,(let* ((exp (visit-exp* k exp))
(conts (append-map visit-dom-conts
(vector-ref doms (label->idx label)))))
(if (null? conts)
@@ -452,12 +424,11 @@ index corresponds to MIN-LABEL, and so on."
(($ $fun src meta free body)
($fun src meta (map subst-var free) ,(visit-entry-cont body)))))
-;; TODO: Bailout branches, truth values, and interprocedural CSE.
+;; TODO: 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))))
+ (lambda (doms label-substs min-label var-substs min-var)
+ (apply-cse fun dfg doms label-substs min-label var-substs min-var))))
(define (eliminate-common-subexpressions fun)
(call-with-values (lambda () (renumber fun))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 215ecfb..1725d28 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -49,7 +49,6 @@
&fluid
&fluid-environment
&prompt
- &bailout
&allocation
&car
&cdr
@@ -63,7 +62,6 @@
&no-effects
&all-effects
- &unknown-effects
effects-commute?
exclude-effects
@@ -118,10 +116,6 @@
;; stack.
&prompt
- ;; Indicates that an expression definitely causes a non-local,
- ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
- &bailout
-
;; Indicates that an expression may return a fresh object -- a
;; "causes" effect.
&allocation
@@ -182,7 +176,6 @@
(define-effects &all-effects
&fluid
&prompt
- &bailout
&allocation
&car
&cdr
@@ -204,13 +197,6 @@
(define-syntax &no-effects (identifier-syntax 0))
-;; An expression with unknown effects can cause any effect, except
-;; &bailout (which indicates certain bailout).
-;;
-(define-syntax &unknown-effects
- (identifier-syntax
- (logand &all-effects (lognot &bailout))))
-
(define-inlinable (cause effect)
(ash effect 1))
@@ -248,7 +234,7 @@
(begin
(hashq-set! *primitive-effects* 'name
(case-lambda* ((dfg . args) effects)
- (_ (cause &bailout))))
+ (_ (logior &all-effects (cause &all-effects)))))
...))
(define-syntax-rule (define-primitive-effects ((name . args) effects) ...)
@@ -292,12 +278,6 @@
(define-primitive-effects
((make-prompt-tag #:optional arg) (cause &allocation)))
-;; Bailout.
-(define-primitive-effects
- ((error . _) (logior (cause &bailout)))
- ((scm-error . _) (logior (cause &bailout)))
- ((throw . _) (logior (cause &bailout))))
-
;; Pairs.
(define-primitive-effects
((cons a b) (cause &allocation))
@@ -440,14 +420,14 @@
((cache-current-module! mod scope) (cause &box))
((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))
+ ((cached-module-box mod name public? 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 &unknown-effects (cause &unknown-effects)))))
+ (logior &all-effects (cause &all-effects)))))
(define (expression-effects exp dfg)
(match exp
@@ -458,7 +438,7 @@
(($ $prompt)
(cause &prompt))
((or ($ $call) ($ $callk))
- (logior &unknown-effects (cause &unknown-effects)))
+ (logior &all-effects (cause &all-effects)))
(($ $primcall name args)
(primitive-effects dfg name args))))
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
new file mode 100644
index 0000000..91afc18
--- /dev/null
+++ b/module/language/cps/prune-bailouts.scm
@@ -0,0 +1,98 @@
+;;; 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:
+;;;
+;;; A pass that prunes successors of expressions that bail out.
+;;;
+;;; Code:
+
+(define-module (language cps prune-bailouts)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:export (prune-bailouts))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
+ (build-cps-term
+ ($letconst (('module module-sym module)
+ ('name name-sym name)
+ ('public? public?-sym public?)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
+ ($primcall 'cached-module-box
+ (module-sym name-sym public?-sym bound?-sym))))))))
+
+(define (primitive-ref name k src)
+ (module-box #f '(guile) name #f #t
+ (lambda (box)
+ (build-cps-term
+ ($continue k src ($primcall 'box-ref (box)))))))
+
+(define (prune-bailouts* fun)
+ (define (visit-cont cont ktail)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body ktail))))
+ (($ $cont label ($ $kentry self tail clause))
+ (label ($kentry self ,tail
+ ,(and clause (visit-cont clause ktail)))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body ktail)
+ ,(and alternate (visit-cont alternate ktail)))))
+ (_ ,cont)))
+
+ (define (visit-term term ktail)
+ (rewrite-cps-term term
+ (($ $letrec names vars funs body)
+ ($letrec names vars (map prune-bailouts* funs)
+ ,(visit-term body ktail)))
+ (($ $letk conts body)
+ ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
+ ,(visit-term body ktail)))
+ (($ $continue k src exp)
+ ,(visit-exp k src exp ktail))))
+
+ (define (visit-exp k src exp ktail)
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k src ,(prune-bailouts* exp)))
+ (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
+ ,(if (eq? k ktail)
+ (build-cps-term ($continue k src ,exp))
+ (let-fresh (kprim kresult kreceive) (prim rest)
+ (build-cps-term
+ ($letk ((kresult ($kargs ('rest) (rest)
+ ($continue ktail src ($values ()))))
+ (kreceive ($kreceive '() 'rest kresult))
+ (kprim ($kargs ('prim) (prim)
+ ($continue kreceive src
+ ($call prim args)))))
+ ,(primitive-ref name kprim src))))))
+ (_ ($continue k src ,exp))))
+
+ (rewrite-cps-exp fun
+ (($ $fun src meta free
+ ($ $cont kentry ($ $kentry self ($ $cont ktail ($ $ktail)) clause)))
+ ($fun src meta free
+ (kentry ($kentry self (ktail ($ktail))
+ ,(and clause (visit-cont clause ktail))))))))
+
+(define (prune-bailouts fun)
+ (with-fresh-name-state fun
+ (prune-bailouts* fun)))
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index 4fb8f59..929f277 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
;;; Tree-il optimizer
-;; Copyright (C) 2009, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 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
@@ -35,10 +35,11 @@
(lambda (x e) x))
(_ peval)))
(cse (match (memq #:cse? opts)
- ((#:cse? #f _ ...)
- ;; Disable CSE.
- (lambda (x) x))
- (_ cse))))
+ ((#:cse? #t _ ...)
+ cse)
+ (_
+ ;; Disable Tree-IL CSE by default.
+ (lambda (x) x)))))
(fix-letrec
(verify-tree-il
(cse
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 355362a..7189862 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,7 +1,7 @@
;;; srfi-9.scm --- define-record-type
;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
-;; 2013 Free Software Foundation, Inc.
+;; 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
@@ -143,11 +143,11 @@
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
-(define (throw-bad-struct s who)
- #((definite-bailout? . #t))
- (throw 'wrong-type-arg who
- "Wrong type argument: ~S" (list s)
- (list s)))
+(define-syntax-rule (throw-bad-struct s who)
+ (let ((s* s))
+ (throw 'wrong-type-arg who
+ "Wrong type argument: ~S" (list s*)
+ (list s*))))
(define (make-copier-id type-name)
(datum->syntax type-name
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-888-g9e94cd9,
Andy Wingo <=