summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2014-04-10 09:25:38 +0200
committerAndy Wingo <wingo@pobox.com>2014-04-10 09:25:38 +0200
commit1e91d95704b9e59fc948c07e70082dd18806b2b4 (patch)
treebd555fc0c18799816728f18da26469d68de4b1a3
parentc0c93581c4a2cb65e1afa52c48b18a39e69cb4fb (diff)
downloadguile-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.am3
-rw-r--r--test-suite/tests/cse.test305
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))))