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 (apply (primitive eq?) (lexical x _) (lexical y _))))))
75 ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
81 (((x y) #f #f #f () (_ _))
82 (apply (primitive not)
83 (apply (primitive 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 (apply (primitive set-car!)
116 (apply (primitive not)
117 (apply (primitive 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 () (_ _))
134 (apply (primitive string-ref)
139 ;; However, expressions with dependencies on effects do not propagate
143 (and (string-ref x y)
145 (and (string-ref x y) #t))))
148 (((x y) #f #f #f () (_ _))
149 (if (apply (primitive string-ref)
155 (if (apply (primitive string-ref)
162 ;; A mutation stops the propagation.
165 (and (string-ref x y)
168 (not (string-ref x y)))))
171 (((x y) #f #f #f () (_ _))
172 (if (apply (primitive string-ref)
176 (apply (primitive string-set!)
179 (apply (primitive not)
180 (apply (primitive string-ref)
185 ;; Predicates are only added to the database if they are in a
186 ;; predicate context.
189 (begin (eq? x y) (eq? x y)))
192 (((x y) #f #f #f () (_ _))
193 (apply (primitive eq?) (lexical x _) (lexical y _))))))
195 ;; Conditional bailouts do cause primitives to be added to the DB.
198 (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
201 (((x y) #f #f #f () (_ _))
203 (if (apply (primitive eq?)
204 (lexical x _) (lexical y _))
206 (apply (primitive 'throw) (const 'foo)))
209 ;; A chain of tests in a conditional bailout add data to the DB
214 (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
216 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
221 (((x y) #f #f #f () (_ _))
227 (apply (primitive throw) (const foo))))))
228 (if (apply (primitive struct?) (lexical x _))
229 (if (apply (primitive eq?)
230 (apply (primitive struct-vtable)
234 (apply (lexical failure _)))
235 (apply (lexical failure _))))
236 (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
238 ;; Strict argument evaluation also adds info to the DB.
242 (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
245 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
251 (((x) #f #f #f () (_))
257 (apply (primitive throw) (const foo))))))
258 (if (apply (primitive struct?) (lexical x _))
259 (if (apply (primitive eq?)
260 (apply (primitive struct-vtable)
263 (apply (primitive struct-ref) (lexical x _) (const 1))
264 (apply (lexical failure _)))
265 (apply (lexical failure _)))))
266 (apply (primitive +) (lexical z _)
267 (apply (primitive struct-ref) (lexical x _) (const 2))))))))
269 ;; Replacing named expressions with lexicals.
273 (let (x) (_) ((apply (primitive car) (toplevel y)))
274 (apply (primitive cons) (lexical x _) (lexical x _))))
276 ;; Dominating expressions only provide predicates when evaluated in
283 ;; Actually this one should reduce in other ways, but this is the
284 ;; current reduction:
286 (apply (primitive car) (toplevel x))
287 (if (apply (primitive car) (toplevel x))
292 (begin (cons 1 2 3) 4)
294 (apply (primitive cons) (const 1) (const 2) (const 3))