diff options
Diffstat (limited to 'test-suite/tests/cse.test')
-rw-r--r-- | test-suite/tests/cse.test | 252 |
1 files changed, 252 insertions, 0 deletions
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 <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))))))) + + +(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))))))))) |