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