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 primitives)
27 #:use-module (language tree-il cse)
28 #:use-module (language tree-il peval)
29 #:use-module (language glil)
30 #:use-module (srfi srfi-13))
32 (define-syntax pass-if-cse
36 (let ((evaled (unparse-tree-il
41 (compile 'in #:from 'scheme #:to 'tree-il)
42 (current-module))))))))
46 ((@ (ice-9 pretty-print) pretty-print)
49 ((@ (ice-9 pretty-print) pretty-print)
52 ((@ (ice-9 pretty-print) pretty-print)
58 (with-test-prefix "cse"
60 ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
68 (((x y) #f #f #f () (_ _))
69 (primcall eq? (lexical x _) (lexical y _))))))
71 ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
77 (((x y) #f #f #f () (_ _))
79 (primcall eq? (lexical x _) (lexical y _)))))))
81 ;; (if TEST (not TEST) #f)
87 (and (eq? x y) (not (eq? x y))))
90 (((x y) #f #f #f () (_ _))
93 ;; (if TEST #f TEST) => (if TEST #f #f) => ...
96 (if (eq? x y) #f (eq? x y)))
99 (((x y) #f #f #f () (_ _))
102 ;; The same, but side-effecting primitives do not propagate.
105 (and (set-car! x y) (not (set-car! x y))))
108 (((x y) #f #f #f () (_ _))
109 (if (primcall set-car!
118 ;; Primitives that access mutable memory can propagate, as long as
119 ;; there is no intervening mutation.
122 (and (string-ref x y)
125 (not (string-ref x y)))))
128 (((x y) #f #f #f () (_ _))
129 (seq (primcall string-ref
134 ;; However, expressions with dependencies on effects do not propagate
138 (and (string-ref x y)
140 (and (string-ref x y) #t))))
143 (((x y) #f #f #f () (_ _))
144 (if (primcall string-ref
150 (if (primcall string-ref
157 ;; A mutation stops the propagation.
160 (and (string-ref x y)
163 (not (string-ref x y)))))
166 (((x y) #f #f #f () (_ _))
167 (if (primcall string-ref
170 (seq (primcall string-set!
179 ;; Predicates are only added to the database if they are in a
180 ;; predicate context.
183 (begin (eq? x y) (eq? x y)))
186 (((x y) #f #f #f () (_ _))
187 (primcall eq? (lexical x _) (lexical y _))))))
189 ;; Conditional bailouts do cause primitives to be added to the DB.
192 (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
195 (((x y) #f #f #f () (_ _))
196 (seq (if (primcall eq?
197 (lexical x _) (lexical y _))
199 (primcall throw (const foo)))
202 ;; A chain of tests in a conditional bailout add data to the DB
207 (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
209 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
214 (((x y) #f #f #f () (_ _))
215 (seq (if (if (primcall struct? (lexical x _))
217 (primcall struct-vtable
222 (primcall throw (const foo)))
223 (primcall struct-ref (lexical x _) (lexical y _)))))))
225 ;; Strict argument evaluation also adds info to the DB.
229 (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
232 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
238 (((x) #f #f #f () (_))
239 (let (z) (_) ((if (if (primcall struct? (lexical x _))
241 (primcall struct-vtable
245 (primcall struct-ref (lexical x _) (const 1))
246 (primcall throw (const foo))))
247 (primcall + (lexical z _)
248 (primcall struct-ref (lexical x _) (const 2))))))))
250 ;; Replacing named expressions with lexicals.
254 (let (x) (_) ((primcall car (toplevel y)))
255 (primcall cons (lexical x _) (lexical x _)))))