diff options
author | Andy Wingo <wingo@pobox.com> | 2014-04-06 11:08:05 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-04-06 11:12:29 +0200 |
commit | 85270a8c895f5912d688d764b686fdaeba0157d5 (patch) | |
tree | 7a9fac3436a37d3cd861d6d780ce0736e12fc76c | |
parent | d03c3c77950dafddec69e87c5f75bec4a4197a60 (diff) | |
download | guile-85270a8c895f5912d688d764b686fdaeba0157d5.tar.gz |
Remove old Tree-IL CSE pass
* module/language/tree-il/cse.scm: Delete.
* module/language/tree-il/optimize.scm: Remove use of Tree-IL CSE.
* module/Makefile.am: Remove language/tree-il/cse.scm.
* module/language/cps/compile-bytecode.scm: Rename CSE keyword to
#:cse?.
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/cse.scm | 546 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 15 |
4 files changed, 4 insertions, 560 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index b3b96d9c0..335e14c4b 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -47,7 +47,6 @@ ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm SOURCES = \ ice-9/boot-9.scm \ language/tree-il/peval.scm \ - language/tree-il/cse.scm \ system/vm/elf.scm \ ice-9/vlist.scm \ srfi/srfi-1.scm \ diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index a4d96adcd..77edf643b 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -71,7 +71,7 @@ (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-common-subexpressions #:cse? #t)) (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t)) (exp (run-pass exp simplify #:simplify? #t))) ;; Passes that are needed: diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm deleted file mode 100644 index d4cf68619..000000000 --- a/module/language/tree-il/cse.scm +++ /dev/null @@ -1,546 +0,0 @@ -;;; Common Subexpression Elimination (CSE) on Tree-IL - -;; 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 -;;;; 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 - -(define-module (language tree-il cse) - #:use-module (language tree-il) - #:use-module (language tree-il primitives) - #:use-module (language tree-il effects) - #:use-module (ice-9 vlist) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:export (cse)) - -;;; -;;; This pass eliminates common subexpressions in Tree-IL. It works -;;; best locally -- within a function -- so it is meant to be run after -;;; partial evaluation, which usually inlines functions and so opens up -;;; a bigger space for CSE to work. -;;; -;;; The algorithm traverses the tree of expressions, returning two -;;; values: the newly rebuilt tree, and a "database". The database is -;;; the set of expressions that will have been evaluated as part of -;;; evaluating an expression. For example, in: -;;; -;;; (1- (+ (if a b c) (* x y))) -;;; -;;; We can say that when it comes time to evaluate (1- <>), that the -;;; subexpressions +, x, y, and (* x y) must have been evaluated in -;;; values context. We know that a was evaluated in test context, but -;;; we don't know if it was true or false. -;;; -;;; The expressions in the database /dominate/ any subsequent -;;; expression: FOO dominates BAR if evaluation of BAR implies that any -;;; effects associated with FOO have already occured. -;;; -;;; When adding expressions to the database, we record the context in -;;; which they are evaluated. We treat expressions in test context -;;; specially: the presence of such an expression indicates that the -;;; expression is true. In this way we can elide duplicate predicates. -;;; -;;; Duplicate predicates are not common in code that users write, but -;;; can occur quite frequently in macro-generated code. -;;; -;;; For example: -;;; -;;; (and (foo? x) (foo-bar x)) -;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>)) -;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) -;;; (struct-ref x 1) -;;; (throw 'not-a-foo)) -;;; #f)) -;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>)) -;;; (struct-ref x 1) -;;; #f) -;;; -;;; A conditional bailout in effect context also has the effect of -;;; adding predicates to the database: -;;; -;;; (begin (foo-bar x) (foo-baz x)) -;;; => (begin -;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) -;;; (struct-ref x 1) -;;; (throw 'not-a-foo)) -;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) -;;; (struct-ref x 2) -;;; (throw 'not-a-foo))) -;;; => (begin -;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) -;;; (struct-ref x 1) -;;; (throw 'not-a-foo)) -;;; (struct-ref x 2)) -;;; -;;; When removing code, we have to ensure that the semantics of the -;;; source program and the residual program are the same. It's easy to -;;; ensure that they have the same value, because those manipulations -;;; are just algebraic, but the tricky thing is to ensure that the -;;; expressions exhibit the same ordering of effects. For that, we use -;;; the effects analysis of (language tree-il effects). We only -;;; eliminate code if the duplicate code commutes with all of the -;;; dominators on the path from the duplicate to the original. -;;; -;;; The implementation uses vhashes as the fundamental data structure. -;;; This can be seen as a form of global value numbering. This -;;; algorithm currently spends most of its time in vhash-assoc. I'm not -;;; sure whether that is due to our bad hash function in Guile 2.0, an -;;; inefficiency in vhashes, or what. Overall though the complexity -;;; should be linear, or N log N -- whatever vhash-assoc's complexity -;;; is. Walking the dominators is nonlinear, but that only happens when -;;; we've actually found a common subexpression so that should be OK. -;;; - -;; Logging helpers, as in peval. -;; -(define-syntax *logging* (identifier-syntax #f)) -;; (define %logging #f) -;; (define-syntax *logging* (identifier-syntax %logging)) -(define-syntax log - (syntax-rules (quote) - ((log 'event arg ...) - (if (and *logging* - (or (eq? *logging* #t) - (memq 'event *logging*))) - (log* 'event arg ...))))) -(define (log* event . args) - (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print)) - 'pretty-print))) - (pp `(log ,event . ,args)) - (newline) - (values))) - -;; A pre-pass on the source program to determine the set of assigned -;; lexicals. -;; -(define* (build-assigned-var-table exp #:optional (table vlist-null)) - (tree-il-fold - (lambda (exp res) - (match exp - (($ <lexical-set> src name gensym exp) - (vhash-consq gensym #t res)) - (_ res))) - (lambda (exp res) res) - table exp)) - -(define (boolean-valued-primitive? primitive) - (or (negate-primitive primitive) - (eq? primitive 'not) - (let ((chars (symbol->string primitive))) - (eqv? (string-ref chars (1- (string-length chars))) - #\?)))) - -(define (boolean-valued-expression? x ctx) - (match x - (($ <primcall> _ (? boolean-valued-primitive?)) #t) - (($ <const> _ (? boolean?)) #t) - (_ (eq? ctx 'test)))) - -(define (singly-valued-expression? x ctx) - (match x - (($ <const>) #t) - (($ <lexical-ref>) #t) - (($ <void>) #t) - (($ <lexical-ref>) #t) - (($ <primitive-ref>) #t) - (($ <module-ref>) #t) - (($ <toplevel-ref>) #t) - (($ <primcall> _ (? singly-valued-primitive?)) #t) - (($ <primcall> _ 'values (val)) #t) - (($ <lambda>) #t) - (_ (eq? ctx 'value)))) - -(define* (cse exp) - "Eliminate common subexpressions in EXP." - - (define assigned-lexical? - (let ((table (build-assigned-var-table exp))) - (lambda (sym) - (vhash-assq sym table)))) - - (define %compute-effects - (make-effects-analyzer assigned-lexical?)) - - (define (negate exp ctx) - (match exp - (($ <const> src x) - (make-const src (not x))) - (($ <void> src) - (make-const src #f)) - (($ <conditional> src test consequent alternate) - (make-conditional src test (negate consequent ctx) (negate alternate ctx))) - (($ <primcall> _ 'not - ((and x (? (cut boolean-valued-expression? <> ctx))))) - x) - (($ <primcall> src (and pred (? negate-primitive)) args) - (make-primcall src (negate-primitive pred) args)) - (_ - (make-primcall #f 'not (list exp))))) - - - (define (hasher n) - (lambda (x size) (hashq n size))) - - (define (add-to-db exp effects ctx db) - (let ((v (vector exp effects ctx)) - (h (tree-il-hash exp))) - (vhash-cons v h db (hasher h)))) - - (define (control-flow-boundary db) - (let ((h (hashq 'lambda most-positive-fixnum))) - (vhash-cons 'lambda h db (hasher h)))) - - (define (find-dominating-expression exp effects ctx db) - (define (entry-matches? v1 v2) - (match (if (vector? v1) v1 v2) - (#(exp* effects* ctx*) - (and (tree-il=? exp exp*) - (or (not ctx) (eq? ctx* ctx)))) - (_ #f))) - - (let ((len (vlist-length db)) - (h (tree-il-hash exp))) - (and (vhash-assoc #t db entry-matches? (hasher h)) - (let lp ((n 0)) - (and (< n len) - (match (vlist-ref db n) - (('lambda . h*) - ;; We assume that lambdas can escape and thus be - ;; called from anywhere. Thus code inside a lambda - ;; only has a dominating expression if it does not - ;; depend on any effects. - (and (not (depends-on-effects? effects &all-effects)) - (lp (1+ n)))) - ((#(exp* effects* ctx*) . h*) - (log 'walk (unparse-tree-il exp) effects - (unparse-tree-il exp*) effects* ctx*) - (or (and (= h h*) - (or (not ctx) (eq? ctx ctx*)) - (tree-il=? exp exp*)) - (and (effects-commute? effects effects*) - (lp (1+ n))))))))))) - - ;; Return #t if EXP is dominated by an instance of itself. In that - ;; case, we can exclude *type-check* effects, because the first - ;; expression already caused them if needed. - (define (has-dominating-effect? exp effects db) - (or (constant? effects) - (and - (effect-free? - (exclude-effects effects - (logior &zero-values - &allocation - &type-check))) - (find-dominating-expression exp effects #f db)))) - - (define (find-dominating-test exp effects db) - (and - (effect-free? - (exclude-effects effects (logior &allocation - &type-check))) - (match exp - (($ <const> src val) - (if (boolean? val) - exp - (make-const src (not (not val))))) - ;; For (not FOO), try to prove FOO, then negate the result. - (($ <primcall> src 'not (exp*)) - (match (find-dominating-test exp* effects db) - (($ <const> _ val) - (log 'inferring exp (not val)) - (make-const src (not val))) - (_ - #f))) - (_ - (cond - ((find-dominating-expression exp effects 'test db) - ;; We have an EXP fact, so we infer #t. - (log 'inferring exp #t) - (make-const (tree-il-src exp) #t)) - ((find-dominating-expression (negate exp 'test) effects 'test db) - ;; We have a (not EXP) fact, so we infer #f. - (log 'inferring exp #f) - (make-const (tree-il-src exp) #f)) - (else - ;; Otherwise we don't know. - #f)))))) - - (define (add-to-env exp name sym db env) - (let* ((v (vector exp name sym (vlist-length db))) - (h (tree-il-hash exp))) - (vhash-cons v h env (hasher h)))) - - (define (augment-env env names syms exps db) - (if (null? names) - env - (let ((name (car names)) (sym (car syms)) (exp (car exps))) - (augment-env (if (or (assigned-lexical? sym) - (lexical-ref? exp)) - env - (add-to-env exp name sym db env)) - (cdr names) (cdr syms) (cdr exps) db)))) - - (define (find-dominating-lexical exp effects env db) - (define (entry-matches? v1 v2) - (match (if (vector? v1) v1 v2) - (#(exp* name sym db) - (tree-il=? exp exp*)) - (_ #f))) - - (define (unroll db base n) - (or (zero? n) - (match (vlist-ref db base) - (('lambda . h*) - ;; See note in find-dominating-expression. - (and (not (depends-on-effects? effects &all-effects)) - (unroll db (1+ base) (1- n)))) - ((#(exp* effects* ctx*) . h*) - (and (effects-commute? effects effects*) - (unroll db (1+ base) (1- n))))))) - - (let ((h (tree-il-hash exp))) - (and (effect-free? (exclude-effects effects &type-check)) - (vhash-assoc exp env entry-matches? (hasher h)) - (let ((env-len (vlist-length env)) - (db-len (vlist-length db))) - (let lp ((n 0) (m 0)) - (and (< n env-len) - (match (vlist-ref env n) - ((#(exp* name sym db-len*) . h*) - (let ((niter (- (- db-len db-len*) m))) - (and (unroll db m niter) - (if (and (= h h*) (tree-il=? exp* exp)) - (make-lexical-ref (tree-il-src exp) name sym) - (lp (1+ n) (- db-len db-len*))))))))))))) - - (define (lookup-lexical sym env) - (let ((env-len (vlist-length env))) - (let lp ((n 0)) - (and (< n env-len) - (match (vlist-ref env n) - ((#(exp _ sym* _) . _) - (if (eq? sym sym*) - exp - (lp (1+ n))))))))) - - (define (intersection db+ db-) - (vhash-fold-right - (lambda (k h out) - (if (vhash-assoc k db- equal? (hasher h)) - (vhash-cons k h out (hasher h)) - out)) - vlist-null - db+)) - - (define (concat db1 db2) - (vhash-fold-right (lambda (k h tail) - (vhash-cons k h tail (hasher h))) - db2 db1)) - - (let visit ((exp exp) - (db vlist-null) ; dominating expressions: #(exp effects ctx) -> hash - (env vlist-null) ; named expressions: #(exp name sym db) -> hash - (ctx 'values)) ; test, effect, value, or values - - (define (parallel-visit exps db env ctx) - (let lp ((in exps) (out '()) (db* vlist-null)) - (if (pair? in) - (call-with-values (lambda () (visit (car in) db env ctx)) - (lambda (x db**) - (lp (cdr in) (cons x out) (concat db** db*)))) - (values (reverse out) db*)))) - - (define (compute-effects exp) - (%compute-effects exp (lambda (sym) (lookup-lexical sym env)))) - - (define (bailout? exp) - (causes-effects? (compute-effects exp) &definite-bailout)) - - (define (return exp db*) - (let ((effects (compute-effects exp))) - (cond - ((and (eq? ctx 'effect) - (not (lambda-case? exp)) - (or (effect-free? - (exclude-effects effects - (logior &zero-values - &allocation))) - (has-dominating-effect? exp effects db))) - (cond - ((void? exp) - (values exp db*)) - (else - (log 'elide ctx (unparse-tree-il exp)) - (values (make-void #f) db*)))) - ((and (boolean-valued-expression? exp ctx) - (find-dominating-test exp effects db)) - => (lambda (exp) - (log 'propagate-test ctx (unparse-tree-il exp)) - (values exp db*))) - ((and (singly-valued-expression? exp ctx) - (find-dominating-lexical exp effects env db)) - => (lambda (exp) - (log 'propagate-value ctx (unparse-tree-il exp)) - (values exp db*))) - ((and (constant? effects) (memq ctx '(value values))) - ;; Adds nothing to the db. - (values exp db*)) - (else - (log 'return ctx effects (unparse-tree-il exp) db*) - (values exp - (add-to-db exp effects ctx db*)))))) - - (log 'visit ctx (unparse-tree-il exp) db env) - - (match exp - (($ <const>) - (return exp vlist-null)) - (($ <void>) - (return exp vlist-null)) - (($ <lexical-ref> _ _ gensym) - (return exp vlist-null)) - (($ <lexical-set> src name gensym exp) - (let*-values (((exp db*) (visit exp db env 'value))) - (return (make-lexical-set src name gensym exp) - db*))) - (($ <let> src names gensyms vals body) - (let*-values (((vals db*) (parallel-visit vals db env 'value)) - ((body db**) (visit body (concat db* db) - (augment-env env names gensyms vals db) - ctx))) - (return (make-let src names gensyms vals body) - (concat db** db*)))) - (($ <letrec> src in-order? names gensyms vals body) - (let*-values (((vals db*) (parallel-visit vals db env 'value)) - ((body db**) (visit body (concat db* db) - (augment-env env names gensyms vals db) - ctx))) - (return (make-letrec src in-order? names gensyms vals body) - (concat db** db*)))) - (($ <fix> src names gensyms vals body) - (let*-values (((vals db*) (parallel-visit vals db env 'value)) - ((body db**) (visit body (concat db* db) env ctx))) - (return (make-fix src names gensyms vals body) - (concat db** db*)))) - (($ <let-values> src producer consumer) - (let*-values (((producer db*) (visit producer db env 'values)) - ((consumer db**) (visit consumer (concat db* db) env ctx))) - (return (make-let-values src producer consumer) - (concat db** db*)))) - (($ <toplevel-ref>) - (return exp vlist-null)) - (($ <module-ref>) - (return exp vlist-null)) - (($ <module-set> src mod name public? exp) - (let*-values (((exp db*) (visit exp db env 'value))) - (return (make-module-set src mod name public? exp) - db*))) - (($ <toplevel-define> src name exp) - (let*-values (((exp db*) (visit exp db env 'value))) - (return (make-toplevel-define src name exp) - db*))) - (($ <toplevel-set> src name exp) - (let*-values (((exp db*) (visit exp db env 'value))) - (return (make-toplevel-set src name exp) - db*))) - (($ <primitive-ref>) - (return exp vlist-null)) - (($ <conditional> src test consequent alternate) - (let*-values - (((test db+) (visit test db env 'test)) - ((converse db-) (visit (negate test 'test) db env 'test)) - ((consequent db++) (visit consequent (concat db+ db) env ctx)) - ((alternate db--) (visit alternate (concat db- db) env ctx))) - (match (make-conditional src test consequent alternate) - (($ <conditional> _ ($ <const> _ exp)) - (if exp - (return consequent (concat db++ db+)) - (return alternate (concat db-- db-)))) - ;; (if FOO A A) => (begin FOO A) - (($ <conditional> src _ - ($ <const> _ a) ($ <const> _ (? (cut equal? a <>)))) - (visit (make-seq #f test (make-const #f a)) - db env ctx)) - ;; (if FOO #t #f) => FOO for boolean-valued FOO. - (($ <conditional> src - (? (cut boolean-valued-expression? <> ctx)) - ($ <const> _ #t) ($ <const> _ #f)) - (return test db+)) - ;; (if FOO #f #t) => (not FOO) - (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t)) - (visit (negate test ctx) db env ctx)) - - ;; Allow "and"-like conditions to accumulate in test context. - ((and c ($ <conditional> _ _ _ ($ <const> _ #f))) - (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null))) - ((and c ($ <conditional> _ _ ($ <const> _ #f) _)) - (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null))) - - ;; Conditional bailouts turn expressions into predicates. - ((and c ($ <conditional> _ _ _ (? bailout?))) - (return c (concat db++ db+))) - ((and c ($ <conditional> _ _ (? bailout?) _)) - (return c (concat db-- db-))) - - (c - (return c (intersection (concat db++ db+) (concat db-- db-))))))) - (($ <primcall> src primitive args) - (let*-values (((args db*) (parallel-visit args db env 'value))) - (return (make-primcall src primitive args) db*))) - (($ <call> src proc args) - (let*-values (((proc db*) (visit proc db env 'value)) - ((args db**) (parallel-visit args db env 'value))) - (return (make-call src proc args) - (concat db** db*)))) - (($ <lambda> src meta body) - (let*-values (((body _) (if body - (visit body (control-flow-boundary db) - env 'values) - (values #f #f)))) - (return (make-lambda src meta body) - vlist-null))) - (($ <lambda-case> src req opt rest kw inits gensyms body alt) - (let*-values (((inits _) (parallel-visit inits db env 'value)) - ((body db*) (visit body db env ctx)) - ((alt _) (if alt - (visit alt db env ctx) - (values #f #f)))) - (return (make-lambda-case src req opt rest kw inits gensyms body alt) - (if alt vlist-null db*)))) - (($ <seq> src head tail) - (let*-values (((head db*) (visit head db env 'effect))) - (cond - ((void? head) - (visit tail db env ctx)) - (else - (let*-values (((tail db**) (visit tail (concat db* db) env ctx))) - (values (make-seq src head tail) - (concat db** db*))))))) - (($ <prompt> src escape-only? tag body handler) - (let*-values (((tag db*) (visit tag db env 'value)) - ((body _) (visit body (concat db* db) env - (if escape-only? ctx 'value))) - ((handler _) (visit handler (concat db* db) env 'value))) - (return (make-prompt src escape-only? tag body handler) - db*))) - (($ <abort> src tag args tail) - (let*-values (((tag db*) (visit tag db env 'value)) - ((args db**) (parallel-visit args db env 'value)) - ((tail db***) (visit tail db env 'value))) - (return (make-abort src tag args tail) - (concat db* (concat db** db***)))))))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 929f27766..d5d4f43a0 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -22,7 +22,6 @@ #:use-module (language tree-il) #:use-module (language tree-il primitives) #:use-module (language tree-il peval) - #:use-module (language tree-il cse) #:use-module (language tree-il fix-letrec) #:use-module (language tree-il debug) #:use-module (ice-9 match) @@ -33,16 +32,8 @@ ((#:partial-eval? #f _ ...) ;; Disable partial evaluation. (lambda (x e) x)) - (_ peval))) - (cse (match (memq #:cse? opts) - ((#:cse? #t _ ...) - cse) - (_ - ;; Disable Tree-IL CSE by default. - (lambda (x) x))))) + (_ peval)))) (fix-letrec (verify-tree-il - (cse - (verify-tree-il - (peval (expand-primitives (resolve-primitives x env)) - env))))))) + (peval (expand-primitives (resolve-primitives x env)) + env))))) |