--- /dev/null
- (($ <application> _
- ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+ ;;; 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) <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)
+ res)
+ (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
- (($ <application> _ ($ <primitive-ref> _ 'not)
++ (($ <primcall> _ (? boolean-valued-primitive?)) #t)
+ (($ <const> _ (? 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
+ (($ <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)))
- (($ <application> src
- ($ <primitive-ref> _ (and pred (? negate-primitive)))
- args)
- (make-application src
- (make-primitive-ref #f (negate-primitive pred))
- args))
++ (($ <primcall> _ 'not
+ ((and x (? (cut boolean-valued-expression? <> ctx)))))
+ x)
- (make-application #f (make-primitive-ref #f 'not) (list exp)))))
++ (($ <primcall> src (and pred (? negate-primitive)) args)
++ (make-primcall src (negate-primitive pred) args))
+ (_
- (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
++ (make-primcall #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
+ (($ <const> src val)
+ (if (boolean? val)
+ exp
+ (make-const src (not (not val)))))
+ ;; For (not FOO), try to prove FOO, then negate the result.
- (($ <dynwind> 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***)))))
++ (($ <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 #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
+ (($ <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*))))
- (visit (make-sequence #f (list test (make-const #f a)))
++ (($ <dynwind> src winder pre body post unwinder)
++ (let*-values (((winder db*) (visit winder db env 'value))
++ ((db**) db*)
++ ((unwinder db*) (visit unwinder db env 'value))
++ ((db**) (concat db* db**))
++ ((pre db*) (visit pre (concat db** db) env 'effect))
++ ((db**) (concat db* db**))
++ ((body db*) (visit body (concat db** db) env ctx))
++ ((db**) (concat db* db**))
++ ((post db*) (visit post (concat db** db) env 'effect))
++ ((db**) (concat db* db**)))
++ (return (make-dynwind src winder pre body post unwinder)
++ db**)))
+ (($ <dynlet> 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*)))))
+ (($ <dynref> src fluid)
+ (let*-values (((fluid db*) (visit fluid db env 'value)))
+ (return (make-dynref src fluid)
+ db*)))
+ (($ <dynset> 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*))))
+ (($ <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 <>))))
- (($ <application> src proc args)
++ (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-)))))))
- (return (make-application src proc args)
++ (($ <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)))
- (($ <sequence> 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*)))))))))
++ (return (make-call src proc args)
+ (concat db** db*))))
+ (($ <lambda> src meta body)
+ (let*-values (((body _) (visit body (control-flow-boundary db)
+ env 'values)))
+ (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 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*)))
+ (($ <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***))))))))
--- /dev/null
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
+ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
+ ;;;; Andy Wingo <wingo@pobox.com> --- 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)))))))
+
+ \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 not)
- (apply (primitive eq?) (lexical x _) (lexical y _)))))))
++ (primcall 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 () (_ _))
- (if (apply (primitive set-car!)
- (lexical x _)
- (lexical y _))
- (apply (primitive not)
- (apply (primitive set-car!)
- (lexical x _)
- (lexical y _)))
++ (primcall not
++ (primcall 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 () (_ _))
- (begin
- (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (const #f))))))
++ (if (primcall set-car!
++ (lexical x _)
++ (lexical y _))
++ (primcall not
++ (primcall 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 () (_ _))
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
++ (seq (primcall 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 _))
++ (if (primcall string-ref
++ (lexical x _)
++ (lexical y _))
+ (lambda _
+ (lambda-case
+ ((() #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 _))))
++ (if (primcall 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 () (_ _))
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
++ (if (primcall string-ref
++ (lexical x _)
++ (lexical y _))
++ (seq (primcall string-set!
++ (lexical x _)
++ (const #\!))
++ (primcall not
++ (primcall 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 () (_ _))
- (begin
- (if (apply (primitive eq?)
- (lexical x _) (lexical y _))
- (void)
- (apply (primitive 'throw) (const 'foo)))
- (const #t))))))
++ (primcall 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 (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 _)))))))
++ (seq (if (primcall eq?
++ (lexical x _) (lexical y _))
++ (void)
++ (primcall 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 () (_ _))
- (let (z) (_) ((if (if (apply (primitive struct?) (lexical x _))
- (apply (primitive eq?)
- (apply (primitive struct-vtable)
- (lexical x _))
- (toplevel x-vtable))
++ (seq (if (if (primcall struct? (lexical x _))
++ (primcall eq?
++ (primcall struct-vtable
++ (lexical x _))
++ (toplevel x-vtable))
++ (const #f))
++ (void)
++ (primcall throw (const foo)))
++ (primcall 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 () (_))
- (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)))))))))
++ (let (z) (_) ((if (if (primcall struct? (lexical x _))
++ (primcall eq?
++ (primcall struct-vtable
++ (lexical x _))
++ (toplevel x-vtable))
+ (const #f))
++ (primcall struct-ref (lexical x _) (const 1))
++ (primcall throw (const foo))))
++ (primcall + (lexical z _)
++ (primcall struct-ref (lexical x _) (const 2))))))))
++
++ ;; Replacing named expressions with lexicals.
++ (pass-if-cse
++ (let ((x (car y)))
++ (cons x (car y)))
++ (let (x) (_) ((primcall car (toplevel y)))
++ (primcall cons (lexical x _) (lexical x _)))))
HCoop / bpt / guile.git / commitdiff