diff options
author | Andy Wingo <wingo@pobox.com> | 2014-04-10 09:25:38 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-04-10 09:25:38 +0200 |
commit | 1e91d95704b9e59fc948c07e70082dd18806b2b4 (patch) | |
tree | bd555fc0c18799816728f18da26469d68de4b1a3 | |
parent | c0c93581c4a2cb65e1afa52c48b18a39e69cb4fb (diff) | |
download | guile-1e91d95704b9e59fc948c07e70082dd18806b2b4.tar.gz |
Remove tests for old Tree-IL CSE module
* test-suite/tests/cse.test: Remove.
* test-suite/Makefile.am:
-rw-r--r-- | test-suite/Makefile.am | 3 | ||||
-rw-r--r-- | test-suite/tests/cse.test | 305 |
2 files changed, 1 insertions, 307 deletions
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 4d08d06e9..05e713406 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, -## 2010, 2011, 2012, 2013 Software Foundation, Inc. +## 2010, 2011, 2012, 2013, 2014 Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -40,7 +40,6 @@ SCM_TESTS = tests/00-initial-env.test \ tests/continuations.test \ tests/coverage.test \ tests/cross-compilation.test \ - tests/cse.test \ tests/curried-definitions.test \ tests/dwarf.test \ tests/ecmascript.test \ diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test deleted file mode 100644 index 25e662624..000000000 --- a/test-suite/tests/cse.test +++ /dev/null @@ -1,305 +0,0 @@ -;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- -;;;; Andy Wingo <wingo@pobox.com> --- May 2009 -;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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 canonicalize) - #:use-module (language tree-il primitives) - #:use-module (language tree-il fix-letrec) - #:use-module (language tree-il cse) - #:use-module (language tree-il peval) - #:use-module (srfi srfi-13)) - -(define-syntax pass-if-cse - (syntax-rules () - ((_ in pat) - (pass-if 'in - (let ((evaled (unparse-tree-il - (canonicalize - (fix-letrec - (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 () (_ _)) - (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 () (_ _)) - (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 () (_ _)) - (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 () (_ _)) - (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 (primcall string-ref - (lexical x _) - (lexical y _)) - (lambda _ - (lambda-case - ((() #f #f #f () ()) - (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 () (_ _)) - (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 () (_ _)) - (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 () (_ _)) - (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 () (_ _)) - (seq - (fix (failure) (_) - ((lambda _ - (lambda-case - ((() #f #f #f () ()) - (primcall throw (const foo)))))) - (if (primcall struct? (lexical x _)) - (if (primcall eq? - (primcall struct-vtable (lexical x _)) - (toplevel x-vtable)) - (void) - (call (lexical failure _))) - (call (lexical failure _)))) - (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 () (_)) - (let (z) (_) - ((fix (failure) (_) - ((lambda _ - (lambda-case - ((() #f #f #f () ()) - (primcall throw (const foo)))))) - (if (primcall struct? (lexical x _)) - (if (primcall eq? - (primcall struct-vtable (lexical x _)) - (toplevel x-vtable)) - (primcall struct-ref (lexical x _) (const 1)) - (call (lexical failure _))) - (call (lexical failure _))))) - (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 _)))) - - ;; Dominating expressions only provide predicates when evaluated in - ;; test context. - (pass-if-cse - (let ((t (car x))) - (if (car x) - 'one - 'two)) - ;; Actually this one should reduce in other ways, but this is the - ;; current reduction: - (seq - (primcall car (toplevel x)) - (if (primcall car (toplevel x)) - (const one) - (const two)))) - - (pass-if-cse - (begin (cons 1 2 3) 4) - (seq - (primcall cons (const 1) (const 2) (const 3)) - (const 4))) - - (pass-if "http://bugs.gnu.org/12883" - ;; In 2.0.6, compiling this code would trigger an out-of-bounds - ;; vlist access in CSE's traversal of its "database". - (procedure? - (compile '(lambda (v) - (let ((failure (lambda () (bail-out 'match)))) - (if (and (pair? v) - (null? (cdr v))) - (let ((w foo) - (x (cdr w))) - (if (and (pair? x) (null? w)) - #t - (failure))) - (failure)))) - #:from 'scheme)))) |