Commit | Line | Data |
---|---|---|
f66cbb99 AW |
1 | ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- |
2 | ;;;; Andy Wingo <wingo@pobox.com> --- May 2009 | |
3 | ;;;; | |
403d78f9 | 4 | ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
f66cbb99 AW |
5 | ;;;; |
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. | |
10 | ;;;; | |
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. | |
15 | ;;;; | |
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 | |
19 | ||
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) | |
4eaf64cd | 26 | #:use-module (language tree-il canonicalize) |
f66cbb99 | 27 | #:use-module (language tree-il primitives) |
4eaf64cd | 28 | #:use-module (language tree-il fix-letrec) |
f66cbb99 AW |
29 | #:use-module (language tree-il cse) |
30 | #:use-module (language tree-il peval) | |
f66cbb99 AW |
31 | #:use-module (srfi srfi-13)) |
32 | ||
33 | (define-syntax pass-if-cse | |
34 | (syntax-rules () | |
35 | ((_ in pat) | |
36 | (pass-if 'in | |
37 | (let ((evaled (unparse-tree-il | |
403d78f9 AW |
38 | (canonicalize |
39 | (fix-letrec | |
4eaf64cd AW |
40 | (cse |
41 | (peval | |
25450a0d | 42 | (expand-primitives |
403d78f9 | 43 | (resolve-primitives |
4eaf64cd AW |
44 | (compile 'in #:from 'scheme #:to 'tree-il) |
45 | (current-module)))))))))) | |
f66cbb99 AW |
46 | (pmatch evaled |
47 | (pat #t) | |
48 | (_ (pk 'cse-mismatch) | |
49 | ((@ (ice-9 pretty-print) pretty-print) | |
50 | 'in) | |
51 | (newline) | |
52 | ((@ (ice-9 pretty-print) pretty-print) | |
53 | evaled) | |
54 | (newline) | |
55 | ((@ (ice-9 pretty-print) pretty-print) | |
56 | 'pat) | |
57 | (newline) | |
58 | #f))))))) | |
59 | ||
60 | \f | |
61 | (with-test-prefix "cse" | |
62 | ||
63 | ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is | |
64 | ;; boolean-valued. | |
65 | (pass-if-cse | |
66 | (lambda (x y) | |
67 | (and (eq? x y) | |
68 | (eq? x y))) | |
69 | (lambda _ | |
70 | (lambda-case | |
71 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a | 72 | (primcall eq? (lexical x _) (lexical y _)))))) |
f66cbb99 AW |
73 | |
74 | ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST). | |
75 | (pass-if-cse | |
76 | (lambda (x y) | |
77 | (if (eq? x y) #f #t)) | |
78 | (lambda _ | |
79 | (lambda-case | |
80 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a AW |
81 | (primcall not |
82 | (primcall eq? (lexical x _) (lexical y _))))))) | |
f66cbb99 AW |
83 | |
84 | ;; (if TEST (not TEST) #f) | |
85 | ;; => (if TEST #f #f) | |
86 | ;; => (begin TEST #f) | |
87 | ;; => #f | |
88 | (pass-if-cse | |
89 | (lambda (x y) | |
90 | (and (eq? x y) (not (eq? x y)))) | |
91 | (lambda _ | |
92 | (lambda-case | |
93 | (((x y) #f #f #f () (_ _)) | |
94 | (const #f))))) | |
95 | ||
96 | ;; (if TEST #f TEST) => (if TEST #f #f) => ... | |
97 | (pass-if-cse | |
98 | (lambda (x y) | |
99 | (if (eq? x y) #f (eq? x y))) | |
100 | (lambda _ | |
101 | (lambda-case | |
102 | (((x y) #f #f #f () (_ _)) | |
103 | (const #f))))) | |
104 | ||
105 | ;; The same, but side-effecting primitives do not propagate. | |
106 | (pass-if-cse | |
107 | (lambda (x y) | |
108 | (and (set-car! x y) (not (set-car! x y)))) | |
109 | (lambda _ | |
110 | (lambda-case | |
111 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a AW |
112 | (if (primcall set-car! |
113 | (lexical x _) | |
114 | (lexical y _)) | |
115 | (primcall not | |
116 | (primcall set-car! | |
117 | (lexical x _) | |
118 | (lexical y _))) | |
f66cbb99 AW |
119 | (const #f)))))) |
120 | ||
121 | ;; Primitives that access mutable memory can propagate, as long as | |
122 | ;; there is no intervening mutation. | |
123 | (pass-if-cse | |
124 | (lambda (x y) | |
125 | (and (string-ref x y) | |
126 | (begin | |
127 | (string-ref x y) | |
128 | (not (string-ref x y))))) | |
129 | (lambda _ | |
130 | (lambda-case | |
131 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a AW |
132 | (seq (primcall string-ref |
133 | (lexical x _) | |
134 | (lexical y _)) | |
135 | (const #f)))))) | |
f66cbb99 AW |
136 | |
137 | ;; However, expressions with dependencies on effects do not propagate | |
138 | ;; through a lambda. | |
139 | (pass-if-cse | |
140 | (lambda (x y) | |
141 | (and (string-ref x y) | |
142 | (lambda () | |
143 | (and (string-ref x y) #t)))) | |
144 | (lambda _ | |
145 | (lambda-case | |
146 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a AW |
147 | (if (primcall string-ref |
148 | (lexical x _) | |
149 | (lexical y _)) | |
f66cbb99 AW |
150 | (lambda _ |
151 | (lambda-case | |
152 | ((() #f #f #f () ()) | |
0ea5ba9a AW |
153 | (if (primcall string-ref |
154 | (lexical x _) | |
155 | (lexical y _)) | |
f66cbb99 AW |
156 | (const #t) |
157 | (const #f))))) | |
158 | (const #f)))))) | |
159 | ||
160 | ;; A mutation stops the propagation. | |
161 | (pass-if-cse | |
162 | (lambda (x y) | |
163 | (and (string-ref x y) | |
164 | (begin | |
165 | (string-set! x #\!) | |
166 | (not (string-ref x y))))) | |
167 | (lambda _ | |
168 | (lambda-case | |
169 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a AW |
170 | (if (primcall string-ref |
171 | (lexical x _) | |
172 | (lexical y _)) | |
173 | (seq (primcall string-set! | |
174 | (lexical x _) | |
175 | (const #\!)) | |
176 | (primcall not | |
177 | (primcall string-ref | |
178 | (lexical x _) | |
179 | (lexical y _)))) | |
f66cbb99 AW |
180 | (const #f)))))) |
181 | ||
182 | ;; Predicates are only added to the database if they are in a | |
183 | ;; predicate context. | |
184 | (pass-if-cse | |
185 | (lambda (x y) | |
186 | (begin (eq? x y) (eq? x y))) | |
187 | (lambda _ | |
188 | (lambda-case | |
189 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a | 190 | (primcall eq? (lexical x _) (lexical y _)))))) |
f66cbb99 AW |
191 | |
192 | ;; Conditional bailouts do cause primitives to be added to the DB. | |
193 | (pass-if-cse | |
194 | (lambda (x y) | |
195 | (begin (unless (eq? x y) (throw 'foo)) (eq? x y))) | |
196 | (lambda _ | |
197 | (lambda-case | |
198 | (((x y) #f #f #f () (_ _)) | |
0ea5ba9a AW |
199 | (seq (if (primcall eq? |
200 | (lexical x _) (lexical y _)) | |
201 | (void) | |
202 | (primcall throw (const foo))) | |
203 | (const #t)))))) | |
f66cbb99 AW |
204 | |
205 | ;; A chain of tests in a conditional bailout add data to the DB | |
206 | ;; correctly. | |
207 | (pass-if-cse | |
208 | (lambda (x y) | |
209 | (begin | |
210 | (unless (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
211 | (throw 'foo)) | |
212 | (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
213 | (struct-ref x y) | |
214 | (throw 'bar)))) | |
215 | (lambda _ | |
216 | (lambda-case | |
217 | (((x y) #f #f #f () (_ _)) | |
74bbb994 | 218 | (seq |
4eaf64cd AW |
219 | (fix (failure) (_) |
220 | ((lambda _ | |
221 | (lambda-case | |
222 | ((() #f #f #f () ()) | |
74bbb994 AW |
223 | (primcall throw (const foo)))))) |
224 | (if (primcall struct? (lexical x _)) | |
225 | (if (primcall eq? | |
226 | (primcall struct-vtable (lexical x _)) | |
227 | (toplevel x-vtable)) | |
4eaf64cd | 228 | (void) |
74bbb994 AW |
229 | (call (lexical failure _))) |
230 | (call (lexical failure _)))) | |
231 | (primcall struct-ref (lexical x _) (lexical y _))))))) | |
f66cbb99 AW |
232 | |
233 | ;; Strict argument evaluation also adds info to the DB. | |
234 | (pass-if-cse | |
235 | (lambda (x) | |
236 | ((lambda (z) | |
237 | (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
238 | (struct-ref x 2) | |
239 | (throw 'bar)))) | |
240 | (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
241 | (struct-ref x 1) | |
242 | (throw 'foo)))) | |
243 | ||
244 | (lambda _ | |
245 | (lambda-case | |
246 | (((x) #f #f #f () (_)) | |
4eaf64cd AW |
247 | (let (z) (_) |
248 | ((fix (failure) (_) | |
249 | ((lambda _ | |
250 | (lambda-case | |
251 | ((() #f #f #f () ()) | |
74bbb994 AW |
252 | (primcall throw (const foo)))))) |
253 | (if (primcall struct? (lexical x _)) | |
254 | (if (primcall eq? | |
255 | (primcall struct-vtable (lexical x _)) | |
256 | (toplevel x-vtable)) | |
257 | (primcall struct-ref (lexical x _) (const 1)) | |
258 | (call (lexical failure _))) | |
259 | (call (lexical failure _))))) | |
0ea5ba9a AW |
260 | (primcall + (lexical z _) |
261 | (primcall struct-ref (lexical x _) (const 2)))))))) | |
262 | ||
263 | ;; Replacing named expressions with lexicals. | |
264 | (pass-if-cse | |
265 | (let ((x (car y))) | |
266 | (cons x (car y))) | |
267 | (let (x) (_) ((primcall car (toplevel y))) | |
0dd7c540 | 268 | (primcall cons (lexical x _) (lexical x _)))) |
4d1ae112 AW |
269 | |
270 | ;; Dominating expressions only provide predicates when evaluated in | |
271 | ;; test context. | |
272 | (pass-if-cse | |
273 | (let ((t (car x))) | |
274 | (if (car x) | |
275 | 'one | |
276 | 'two)) | |
277 | ;; Actually this one should reduce in other ways, but this is the | |
278 | ;; current reduction: | |
0dd7c540 AW |
279 | (seq |
280 | (primcall car (toplevel x)) | |
281 | (if (primcall car (toplevel x)) | |
4d1ae112 | 282 | (const one) |
37081d5d AW |
283 | (const two)))) |
284 | ||
285 | (pass-if-cse | |
286 | (begin (cons 1 2 3) 4) | |
2aed2667 AW |
287 | (seq |
288 | (primcall cons (const 1) (const 2) (const 3)) | |
2c7b7e0f LC |
289 | (const 4))) |
290 | ||
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". | |
5d530700 AW |
294 | (procedure? |
295 | (compile '(lambda (v) | |
2c7b7e0f LC |
296 | (let ((failure (lambda () (bail-out 'match)))) |
297 | (if (and (pair? v) | |
298 | (null? (cdr v))) | |
299 | (let ((w foo) | |
300 | (x (cdr w))) | |
301 | (if (and (pair? x) (null? w)) | |
302 | #t | |
303 | (failure))) | |
304 | (failure)))) | |
5d530700 | 305 | #:from 'scheme)))) |