1 ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
4 ;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
6 ;;;; This library is free software; you can redistribute it and/or
7 ;;;; modify it under the terms of the GNU Lesser General Public
8 ;;;; License as published by the Free Software Foundation; either
9 ;;;; version 3 of the License, or (at your option) any later version.
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;;; Lesser General Public License for more details.
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free Software
18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite tree-il)
21 #:use-module (test-suite lib)
22 #:use-module (system base compile)
23 #:use-module (system base pmatch)
24 #:use-module (system base message)
25 #:use-module (language tree-il)
26 #:use-module (language tree-il canonicalize)
27 #:use-module (language tree-il primitives)
28 #:use-module (language tree-il fix-letrec)
29 #:use-module (language tree-il cse)
30 #:use-module (language tree-il peval)
31 #:use-module (language glil)
32 #:use-module (srfi srfi-13))
34 (define-syntax pass-if-cse
38 (let ((evaled (unparse-tree-il
45 (compile 'in #:from 'scheme #:to 'tree-il)
46 (current-module))))))))))
50 ((@ (ice-9 pretty-print) pretty-print)
53 ((@ (ice-9 pretty-print) pretty-print)
56 ((@ (ice-9 pretty-print) pretty-print)
62 (with-test-prefix "cse"
64 ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
72 (((x y) #f #f #f () (_ _))
73 (primcall eq? (lexical x _) (lexical y _))))))
75 ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
81 (((x y) #f #f #f () (_ _))
83 (primcall eq? (lexical x _) (lexical y _)))))))
85 ;; (if TEST (not TEST) #f)
91 (and (eq? x y) (not (eq? x y))))
94 (((x y) #f #f #f () (_ _))
97 ;; (if TEST #f TEST) => (if TEST #f #f) => ...
100 (if (eq? x y) #f (eq? x y)))
103 (((x y) #f #f #f () (_ _))
106 ;; The same, but side-effecting primitives do not propagate.
109 (and (set-car! x y) (not (set-car! x y))))
112 (((x y) #f #f #f () (_ _))
113 (if (primcall set-car!
122 ;; Primitives that access mutable memory can propagate, as long as
123 ;; there is no intervening mutation.
126 (and (string-ref x y)
129 (not (string-ref x y)))))
132 (((x y) #f #f #f () (_ _))
133 (seq (primcall string-ref
138 ;; However, expressions with dependencies on effects do not propagate
142 (and (string-ref x y)
144 (and (string-ref x y) #t))))
147 (((x y) #f #f #f () (_ _))
148 (if (primcall string-ref
154 (if (primcall string-ref
161 ;; A mutation stops the propagation.
164 (and (string-ref x y)
167 (not (string-ref x y)))))
170 (((x y) #f #f #f () (_ _))
171 (if (primcall string-ref
174 (seq (primcall string-set!
183 ;; Predicates are only added to the database if they are in a
184 ;; predicate context.
187 (begin (eq? x y) (eq? x y)))
190 (((x y) #f #f #f () (_ _))
191 (primcall eq? (lexical x _) (lexical y _))))))
193 ;; Conditional bailouts do cause primitives to be added to the DB.
196 (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
199 (((x y) #f #f #f () (_ _))
200 (seq (if (primcall eq?
201 (lexical x _) (lexical y _))
203 (primcall throw (const foo)))
206 ;; A chain of tests in a conditional bailout add data to the DB
211 (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
213 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
218 (((x y) #f #f #f () (_ _))
224 (primcall throw (const foo))))))
225 (if (primcall struct? (lexical x _))
227 (primcall struct-vtable (lexical x _))
230 (call (lexical failure _)))
231 (call (lexical failure _))))
232 (primcall struct-ref (lexical x _) (lexical y _)))))))
234 ;; Strict argument evaluation also adds info to the DB.
238 (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
241 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
247 (((x) #f #f #f () (_))
253 (primcall throw (const foo))))))
254 (if (primcall struct? (lexical x _))
256 (primcall struct-vtable (lexical x _))
258 (primcall struct-ref (lexical x _) (const 1))
259 (call (lexical failure _)))
260 (call (lexical failure _)))))
261 (primcall + (lexical z _)
262 (primcall struct-ref (lexical x _) (const 2))))))))
264 ;; Replacing named expressions with lexicals.
268 (let (x) (_) ((primcall car (toplevel y)))
269 (primcall cons (lexical x _) (lexical x _))))
271 ;; Dominating expressions only provide predicates when evaluated in
278 ;; Actually this one should reduce in other ways, but this is the
279 ;; current reduction:
281 (primcall car (toplevel x))
282 (if (primcall car (toplevel x))