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, 2013 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 (srfi srfi-13))
33 (define-syntax pass-if-cse
37 (let ((evaled (unparse-tree-il
44 (compile 'in #:from 'scheme #:to 'tree-il)
45 (current-module))))))))))
49 ((@ (ice-9 pretty-print) pretty-print)
52 ((@ (ice-9 pretty-print) pretty-print)
55 ((@ (ice-9 pretty-print) pretty-print)
61 (with-test-prefix "cse"
63 ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
71 (((x y) #f #f #f () (_ _))
72 (primcall eq? (lexical x _) (lexical y _))))))
74 ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
80 (((x y) #f #f #f () (_ _))
82 (primcall eq? (lexical x _) (lexical y _)))))))
84 ;; (if TEST (not TEST) #f)
90 (and (eq? x y) (not (eq? x y))))
93 (((x y) #f #f #f () (_ _))
96 ;; (if TEST #f TEST) => (if TEST #f #f) => ...
99 (if (eq? x y) #f (eq? x y)))
102 (((x y) #f #f #f () (_ _))
105 ;; The same, but side-effecting primitives do not propagate.
108 (and (set-car! x y) (not (set-car! x y))))
111 (((x y) #f #f #f () (_ _))
112 (if (primcall set-car!
121 ;; Primitives that access mutable memory can propagate, as long as
122 ;; there is no intervening mutation.
125 (and (string-ref x y)
128 (not (string-ref x y)))))
131 (((x y) #f #f #f () (_ _))
132 (seq (primcall string-ref
137 ;; However, expressions with dependencies on effects do not propagate
141 (and (string-ref x y)
143 (and (string-ref x y) #t))))
146 (((x y) #f #f #f () (_ _))
147 (if (primcall string-ref
153 (if (primcall string-ref
160 ;; A mutation stops the propagation.
163 (and (string-ref x y)
166 (not (string-ref x y)))))
169 (((x y) #f #f #f () (_ _))
170 (if (primcall string-ref
173 (seq (primcall string-set!
182 ;; Predicates are only added to the database if they are in a
183 ;; predicate context.
186 (begin (eq? x y) (eq? x y)))
189 (((x y) #f #f #f () (_ _))
190 (primcall eq? (lexical x _) (lexical y _))))))
192 ;; Conditional bailouts do cause primitives to be added to the DB.
195 (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
198 (((x y) #f #f #f () (_ _))
199 (seq (if (primcall eq?
200 (lexical x _) (lexical y _))
202 (primcall throw (const foo)))
205 ;; A chain of tests in a conditional bailout add data to the DB
210 (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
212 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
217 (((x y) #f #f #f () (_ _))
223 (primcall throw (const foo))))))
224 (if (primcall struct? (lexical x _))
226 (primcall struct-vtable (lexical x _))
229 (call (lexical failure _)))
230 (call (lexical failure _))))
231 (primcall struct-ref (lexical x _) (lexical y _)))))))
233 ;; Strict argument evaluation also adds info to the DB.
237 (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
240 (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
246 (((x) #f #f #f () (_))
252 (primcall throw (const foo))))))
253 (if (primcall struct? (lexical x _))
255 (primcall struct-vtable (lexical x _))
257 (primcall struct-ref (lexical x _) (const 1))
258 (call (lexical failure _)))
259 (call (lexical failure _)))))
260 (primcall + (lexical z _)
261 (primcall struct-ref (lexical x _) (const 2))))))))
263 ;; Replacing named expressions with lexicals.
267 (let (x) (_) ((primcall car (toplevel y)))
268 (primcall cons (lexical x _) (lexical x _))))
270 ;; Dominating expressions only provide predicates when evaluated in
277 ;; Actually this one should reduce in other ways, but this is the
278 ;; current reduction:
280 (primcall car (toplevel x))
281 (if (primcall car (toplevel x))
286 (begin (cons 1 2 3) 4)
288 (primcall cons (const 1) (const 2) (const 3))
291 (pass-if "http://bugs.gnu.org/12883"
292 ;; In 2.0.6, compiling this code would trigger an out-of-bounds
293 ;; vlist access in CSE's traversal of its "database".
295 (compile '(lambda (v)
296 (let ((failure (lambda () (bail-out 'match))))
301 (if (and (pair? x) (null? w))