From f66cbb99ee096186837536885d3436bb334df34d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 Apr 2012 15:23:15 -0700 Subject: [PATCH] new pass: cse * module/language/tree-il/cse.scm: New pass, some simple common subexpression elimination with effects analysis. * test-suite/tests/cse.test: New test. * test-suite/Makefile.am: * module/Makefile.am: Adapt. --- module/Makefile.am | 1 + module/language/tree-il/cse.scm | 600 ++++++++++++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/cse.test | 252 ++++++++++++++ 4 files changed, 854 insertions(+) create mode 100644 module/language/tree-il/cse.scm create mode 100644 test-suite/tests/cse.test diff --git a/module/Makefile.am b/module/Makefile.am index 661e7da08..b033f7bc6 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -103,6 +103,7 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/analyze.scm \ language/tree-il/inline.scm \ language/tree-il/compile-glil.scm \ + language/tree-il/cse.scm \ language/tree-il/debug.scm \ language/tree-il/spec.scm diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm new file mode 100644 index 000000000..3d8a7f8f4 --- /dev/null +++ b/module/language/tree-il/cse.scm @@ -0,0 +1,600 @@ +;;; Common Subexpression Elimination (CSE) on Tree-IL + +;; Copyright (C) 2011, 2012 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) )) +;;; (if (and (struct? x) (eq? (struct-vtable x) )) +;;; (struct-ref x 1) +;;; (throw 'not-a-foo)) +;;; #f)) +;;; => (if (and (struct? x) (eq? (struct-vtable x) )) +;;; (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) )) +;;; (struct-ref x 1) +;;; (throw 'not-a-foo)) +;;; (if (and (struct? x) (eq? (struct-vtable x) )) +;;; (struct-ref x 2) +;;; (throw 'not-a-foo))) +;;; => (begin +;;; (if (and (struct? x) (eq? (struct-vtable x) )) +;;; (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) + res) + (lambda (exp res) + (match exp + (($ 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 + (($ _ + ($ _ (? boolean-valued-primitive?))) #t) + (($ _ (? boolean?)) #t) + (_ (eq? ctx 'test)))) + +(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 + (($ src x) + (make-const src (not x))) + (($ src) + (make-const src #f)) + (($ src test consequent alternate) + (make-conditional src test (negate consequent ctx) (negate alternate ctx))) + (($ _ ($ _ 'not) + ((and x (? (cut boolean-valued-expression? <> ctx))))) + x) + (($ src + ($ _ (and pred (? negate-primitive))) + args) + (make-application src + (make-primitive-ref #f (negate-primitive pred)) + args)) + (_ + (make-application #f (make-primitive-ref #f 'not) (list exp))))) + + + (define (bailout? exp) + (causes-effects? (compute-effects exp) &definite-bailout)) + + (define (struct-nfields x) + (/ (string-length (symbol->string (struct-layout x))) 2)) + + (define hash-bits (logcount most-positive-fixnum)) + (define hash-depth 3) + (define hash-width 3) + (define (hash-expression exp) + (define (hash-exp exp depth) + (define (rotate x bits) + (logior (ash x (- bits)) + (ash (logand x (1- (ash 1 bits))) (- hash-bits bits)))) + (define (mix h1 h2) + (logxor h1 (rotate h2 8))) + (define (hash-struct s) + (let ((len (struct-nfields s)) + (h (hashq (struct-vtable s) most-positive-fixnum))) + (if (zero? depth) + h + (let lp ((i (max (- len hash-width) 1)) (h h)) + (if (< i len) + (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h)) + h))))) + (define (hash-list l) + (let ((h (hashq 'list most-positive-fixnum))) + (if (zero? depth) + h + (let lp ((l l) (width 0) (h h)) + (if (< width hash-width) + (lp (cdr l) (1+ width) + (mix (hash-exp (car l) (1+ depth)) h)) + h))))) + (cond + ((struct? exp) (hash-struct exp)) + ((list? exp) (hash-list exp)) + (else (hash exp most-positive-fixnum)))) + (hash-exp exp 0)) + + (define (expressions-equal? a b) + (cond + ((struct? a) + (and (struct? b) + (eq? (struct-vtable a) (struct-vtable b)) + ;; Assume that all structs are tree-il, so we skip over the + ;; src slot. + (let lp ((n (1- (struct-nfields a)))) + (or (zero? n) + (and (expressions-equal? (struct-ref a n) (struct-ref b n)) + (lp (1- n))))))) + ((pair? a) + (and (pair? b) + (expressions-equal? (car a) (car b)) + (expressions-equal? (cdr a) (cdr b)))) + (else + (equal? a b)))) + + (define (hasher n) + (lambda (x size) (modulo n size))) + + (define (add-to-db exp effects ctx db) + (let ((v (vector exp effects ctx)) + (h (hash-expression 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 (expressions-equal? exp exp*) + (or (not ctx) (eq? ctx* ctx)))) + (_ #f))) + + (let ((len (vlist-length db)) + (h (hash-expression 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*)) + (expressions-equal? 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 + (($ src val) + (if (boolean? val) + exp + (make-const src (not (not val))))) + ;; For (not FOO), try to prove FOO, then negate the result. + (($ src ($ _ 'not) (exp*)) + (match (find-dominating-test exp* effects db) + (($ _ val) + (log 'inferring exp (not val)) + (make-const src (not val))) + (_ + #f))) + (_ + (cond + ((find-dominating-expression exp effects #f 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 #f 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 (hash-expression 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) + (expressions-equal? exp exp*)) + (_ #f))) + + (define (unroll db from to) + (or (<= from to) + (match (vlist-ref db (1- from)) + (('lambda . h*) + ;; See note in find-dominating-expression. + (and (not (depends-on-effects? effects &all-effects)) + (unroll db (1- from) to))) + ((#(exp* effects* ctx*) . h*) + (and (effects-commute? effects effects*) + (unroll db (1- from) to)))))) + + (let ((h (hash-expression exp))) + (and (effect-free? (exclude-effects effects &type-check)) + (vhash-assoc exp env entry-matches? (hasher h)) + (let ((env-len (vlist-length env))) + (let lp ((n 0) (db-len (vlist-length db))) + (and (< n env-len) + (match (vlist-ref env n) + ((#(exp* name sym db-len*) . h*) + (and (unroll db db-len db-len*) + (if (and (= h h*) (expressions-equal? exp* exp)) + (make-lexical-ref (tree-il-src exp) name sym) + (lp (1+ n) db-len*))))))))))) + + (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 (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))) + (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 (eq? ctx 'value) + (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 + (($ ) + (return exp vlist-null)) + (($ ) + (return exp vlist-null)) + (($ _ _ gensym) + (return exp vlist-null)) + (($ src name gensym exp) + (let*-values (((exp db*) (visit exp db env 'value))) + (return (make-lexical-set src name gensym exp) + db*))) + (($ 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*)))) + (($ 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*)))) + (($ 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*)))) + (($ 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*)))) + (($ src winder body unwinder) + (let*-values (((pre db*) (visit winder db env 'value)) + ((body db**) (visit body (concat db* db) env ctx)) + ((post db***) (visit unwinder db env 'value))) + (return (make-dynwind src pre body post) + (concat db* (concat db** db***))))) + (($ src fluids vals body) + (let*-values (((fluids db*) (parallel-visit fluids db env 'value)) + ((vals db**) (parallel-visit vals db env 'value)) + ((body db***) (visit body (concat db** (concat db* db)) + env ctx))) + (return (make-dynlet src fluids vals body) + (concat db*** (concat db** db*))))) + (($ src fluid) + (let*-values (((fluid db*) (visit fluid db env 'value))) + (return (make-dynref src fluid) + db*))) + (($ src fluid exp) + (let*-values (((fluid db*) (visit fluid db env 'value)) + ((exp db**) (visit exp db env 'value))) + (return (make-dynset src fluid exp) + (concat db** db*)))) + (($ ) + (return exp vlist-null)) + (($ ) + (return exp vlist-null)) + (($ src mod name public? exp) + (let*-values (((exp db*) (visit exp db env 'value))) + (return (make-module-set src mod name public? exp) + db*))) + (($ src name exp) + (let*-values (((exp db*) (visit exp db env 'value))) + (return (make-toplevel-define src name exp) + db*))) + (($ src name exp) + (let*-values (((exp db*) (visit exp db env 'value))) + (return (make-toplevel-set src name exp) + db*))) + (($ ) + (return exp vlist-null)) + (($ 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) + (($ _ ($ _ exp)) + (if exp + (return consequent (concat db++ db+)) + (return alternate (concat db-- db-)))) + ;; (if FOO A A) => (begin FOO A) + (($ src _ + ($ _ a) ($ _ (? (cut equal? a <>)))) + (visit (make-sequence #f (list test (make-const #f a))) + db env ctx)) + ;; (if FOO #t #f) => FOO for boolean-valued FOO. + (($ src + (? (cut boolean-valued-expression? <> ctx)) + ($ _ #t) ($ _ #f)) + (return test db+)) + ;; (if FOO #f #t) => (not FOO) + (($ src _ ($ _ #f) ($ _ #t)) + (visit (negate test ctx) db env ctx)) + + ;; Allow "and"-like conditions to accumulate in test context. + ((and c ($ _ _ _ ($ _ #f))) + (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null))) + ((and c ($ _ _ ($ _ #f) _)) + (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null))) + + ;; Conditional bailouts turn expressions into predicates. + ((and c ($ _ _ _ (? bailout?))) + (return c (concat db++ db+))) + ((and c ($ _ _ (? bailout?) _)) + (return c (concat db-- db-))) + + (c + (return c (intersection (concat db++ db+) (concat db-- db-))))))) + (($ src proc args) + (let*-values (((proc db*) (visit proc db env 'value)) + ((args db**) (parallel-visit args db env 'value))) + (return (make-application src proc args) + (concat db** db*)))) + (($ src meta body) + (let*-values (((body _) (visit body (control-flow-boundary db) + env 'values))) + (return (make-lambda src meta body) + vlist-null))) + (($ 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*)))) + (($ src exps) + (let lp ((in exps) (out '()) (db* vlist-null)) + (match in + ((last) + (let*-values (((last db**) (visit last (concat db* db) env ctx))) + (if (null? out) + (return last (concat db** db*)) + (return (make-sequence src (reverse (cons last out))) + (concat db** db*))))) + ((head . rest) + (let*-values (((head db**) (visit head (concat db* db) env 'effect))) + (cond + ((sequence? head) + (lp (append (sequence-exps head) rest) out db*)) + ((void? head) + (lp rest out db*)) + (else + (lp rest (cons head out) (concat db** db*))))))))) + (($ src tag body handler) + (let*-values (((tag db*) (visit tag db env 'value)) + ((body _) (visit body (concat db* db) env ctx)) + ((handler _) (visit handler (concat db* db) env ctx))) + (return (make-prompt src tag body handler) + db*))) + (($ 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/test-suite/Makefile.am b/test-suite/Makefile.am index 054a94b54..168e79901 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -39,6 +39,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/control.test \ tests/continuations.test \ tests/coverage.test \ + tests/cse.test \ tests/curried-definitions.test \ tests/ecmascript.test \ tests/elisp.test \ diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test new file mode 100644 index 000000000..7195a4dd6 --- /dev/null +++ b/test-suite/tests/cse.test @@ -0,0 +1,252 @@ +;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- +;;;; Andy Wingo --- May 2009 +;;;; +;;;; Copyright (C) 2009, 2010, 2011, 2012 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 (test-suite tree-il) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system base pmatch) + #:use-module (system base message) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language tree-il cse) + #:use-module (language tree-il peval) + #:use-module (language glil) + #:use-module (srfi srfi-13)) + +(define-syntax pass-if-cse + (syntax-rules () + ((_ in pat) + (pass-if 'in + (let ((evaled (unparse-tree-il + (cse + (peval + (expand-primitives! + (resolve-primitives! + (compile 'in #:from 'scheme #:to 'tree-il) + (current-module)))))))) + (pmatch evaled + (pat #t) + (_ (pk 'cse-mismatch) + ((@ (ice-9 pretty-print) pretty-print) + 'in) + (newline) + ((@ (ice-9 pretty-print) pretty-print) + evaled) + (newline) + ((@ (ice-9 pretty-print) pretty-print) + 'pat) + (newline) + #f))))))) + + +(with-test-prefix "cse" + + ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is + ;; boolean-valued. + (pass-if-cse + (lambda (x y) + (and (eq? x y) + (eq? x y))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (apply (primitive eq?) (lexical x _) (lexical y _)))))) + + ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST). + (pass-if-cse + (lambda (x y) + (if (eq? x y) #f #t)) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (apply (primitive not) + (apply (primitive eq?) (lexical x _) (lexical y _))))))) + + ;; (if TEST (not TEST) #f) + ;; => (if TEST #f #f) + ;; => (begin TEST #f) + ;; => #f + (pass-if-cse + (lambda (x y) + (and (eq? x y) (not (eq? x y)))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (const #f))))) + + ;; (if TEST #f TEST) => (if TEST #f #f) => ... + (pass-if-cse + (lambda (x y) + (if (eq? x y) #f (eq? x y))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (const #f))))) + + ;; The same, but side-effecting primitives do not propagate. + (pass-if-cse + (lambda (x y) + (and (set-car! x y) (not (set-car! x y)))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (if (apply (primitive set-car!) + (lexical x _) + (lexical y _)) + (apply (primitive not) + (apply (primitive set-car!) + (lexical x _) + (lexical y _))) + (const #f)))))) + + ;; Primitives that access mutable memory can propagate, as long as + ;; there is no intervening mutation. + (pass-if-cse + (lambda (x y) + (and (string-ref x y) + (begin + (string-ref x y) + (not (string-ref x y))))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (begin + (apply (primitive string-ref) + (lexical x _) + (lexical y _)) + (const #f)))))) + + ;; However, expressions with dependencies on effects do not propagate + ;; through a lambda. + (pass-if-cse + (lambda (x y) + (and (string-ref x y) + (lambda () + (and (string-ref x y) #t)))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (if (apply (primitive string-ref) + (lexical x _) + (lexical y _)) + (lambda _ + (lambda-case + ((() #f #f #f () ()) + (if (apply (primitive string-ref) + (lexical x _) + (lexical y _)) + (const #t) + (const #f))))) + (const #f)))))) + + ;; A mutation stops the propagation. + (pass-if-cse + (lambda (x y) + (and (string-ref x y) + (begin + (string-set! x #\!) + (not (string-ref x y))))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (if (apply (primitive string-ref) + (lexical x _) + (lexical y _)) + (begin + (apply (primitive string-set!) + (lexical x _) + (const #\!)) + (apply (primitive not) + (apply (primitive string-ref) + (lexical x _) + (lexical y _)))) + (const #f)))))) + + ;; Predicates are only added to the database if they are in a + ;; predicate context. + (pass-if-cse + (lambda (x y) + (begin (eq? x y) (eq? x y))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (apply (primitive eq?) (lexical x _) (lexical y _)))))) + + ;; Conditional bailouts do cause primitives to be added to the DB. + (pass-if-cse + (lambda (x y) + (begin (unless (eq? x y) (throw 'foo)) (eq? x y))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (begin + (if (apply (primitive eq?) + (lexical x _) (lexical y _)) + (void) + (apply (primitive 'throw) (const 'foo))) + (const #t)))))) + + ;; A chain of tests in a conditional bailout add data to the DB + ;; correctly. + (pass-if-cse + (lambda (x y) + (begin + (unless (and (struct? x) (eq? (struct-vtable x) x-vtable)) + (throw 'foo)) + (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) + (struct-ref x y) + (throw 'bar)))) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + (begin + (if (if (apply (primitive struct?) (lexical x _)) + (apply (primitive eq?) + (apply (primitive struct-vtable) + (lexical x _)) + (toplevel x-vtable)) + (const #f)) + (void) + (apply (primitive 'throw) (const 'foo))) + (apply (primitive struct-ref) (lexical x _) (lexical y _))))))) + + ;; Strict argument evaluation also adds info to the DB. + (pass-if-cse + (lambda (x) + ((lambda (z) + (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) + (struct-ref x 2) + (throw 'bar)))) + (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) + (struct-ref x 1) + (throw 'foo)))) + + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (let (z) (_) ((if (if (apply (primitive struct?) (lexical x _)) + (apply (primitive eq?) + (apply (primitive struct-vtable) + (lexical x _)) + (toplevel x-vtable)) + (const #f)) + (apply (primitive struct-ref) (lexical x _) (const 1)) + (apply (primitive 'throw) (const 'foo)))) + (apply (primitive +) (lexical z _) + (apply (primitive struct-ref) (lexical x _) (const 2))))))))) -- 2.20.1