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 () (_ _)) | |
73 | (apply (primitive eq?) (lexical x _) (lexical y _)))))) | |
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 () (_ _)) | |
82 | (apply (primitive not) | |
83 | (apply (primitive eq?) (lexical x _) (lexical y _))))))) | |
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 () (_ _)) | |
113 | (if (apply (primitive set-car!) | |
114 | (lexical x _) | |
115 | (lexical y _)) | |
116 | (apply (primitive not) | |
117 | (apply (primitive set-car!) | |
118 | (lexical x _) | |
119 | (lexical y _))) | |
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 () (_ _)) | |
133 | (begin | |
134 | (apply (primitive string-ref) | |
135 | (lexical x _) | |
136 | (lexical y _)) | |
137 | (const #f)))))) | |
138 | ||
139 | ;; However, expressions with dependencies on effects do not propagate | |
140 | ;; through a lambda. | |
141 | (pass-if-cse | |
142 | (lambda (x y) | |
143 | (and (string-ref x y) | |
144 | (lambda () | |
145 | (and (string-ref x y) #t)))) | |
146 | (lambda _ | |
147 | (lambda-case | |
148 | (((x y) #f #f #f () (_ _)) | |
149 | (if (apply (primitive string-ref) | |
150 | (lexical x _) | |
151 | (lexical y _)) | |
152 | (lambda _ | |
153 | (lambda-case | |
154 | ((() #f #f #f () ()) | |
155 | (if (apply (primitive string-ref) | |
156 | (lexical x _) | |
157 | (lexical y _)) | |
158 | (const #t) | |
159 | (const #f))))) | |
160 | (const #f)))))) | |
161 | ||
162 | ;; A mutation stops the propagation. | |
163 | (pass-if-cse | |
164 | (lambda (x y) | |
165 | (and (string-ref x y) | |
166 | (begin | |
167 | (string-set! x #\!) | |
168 | (not (string-ref x y))))) | |
169 | (lambda _ | |
170 | (lambda-case | |
171 | (((x y) #f #f #f () (_ _)) | |
172 | (if (apply (primitive string-ref) | |
173 | (lexical x _) | |
174 | (lexical y _)) | |
175 | (begin | |
176 | (apply (primitive string-set!) | |
177 | (lexical x _) | |
178 | (const #\!)) | |
179 | (apply (primitive not) | |
180 | (apply (primitive string-ref) | |
181 | (lexical x _) | |
182 | (lexical y _)))) | |
183 | (const #f)))))) | |
184 | ||
185 | ;; Predicates are only added to the database if they are in a | |
186 | ;; predicate context. | |
187 | (pass-if-cse | |
188 | (lambda (x y) | |
189 | (begin (eq? x y) (eq? x y))) | |
190 | (lambda _ | |
191 | (lambda-case | |
192 | (((x y) #f #f #f () (_ _)) | |
193 | (apply (primitive eq?) (lexical x _) (lexical y _)))))) | |
194 | ||
195 | ;; Conditional bailouts do cause primitives to be added to the DB. | |
196 | (pass-if-cse | |
197 | (lambda (x y) | |
198 | (begin (unless (eq? x y) (throw 'foo)) (eq? x y))) | |
199 | (lambda _ | |
200 | (lambda-case | |
201 | (((x y) #f #f #f () (_ _)) | |
202 | (begin | |
203 | (if (apply (primitive eq?) | |
204 | (lexical x _) (lexical y _)) | |
205 | (void) | |
206 | (apply (primitive 'throw) (const 'foo))) | |
207 | (const #t)))))) | |
208 | ||
209 | ;; A chain of tests in a conditional bailout add data to the DB | |
210 | ;; correctly. | |
211 | (pass-if-cse | |
212 | (lambda (x y) | |
213 | (begin | |
214 | (unless (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
215 | (throw 'foo)) | |
216 | (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
217 | (struct-ref x y) | |
218 | (throw 'bar)))) | |
219 | (lambda _ | |
220 | (lambda-case | |
221 | (((x y) #f #f #f () (_ _)) | |
222 | (begin | |
4eaf64cd AW |
223 | (fix (failure) (_) |
224 | ((lambda _ | |
225 | (lambda-case | |
226 | ((() #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) | |
231 | (lexical x _)) | |
232 | (toplevel x-vtable)) | |
233 | (void) | |
234 | (apply (lexical failure _))) | |
235 | (apply (lexical failure _)))) | |
f66cbb99 AW |
236 | (apply (primitive struct-ref) (lexical x _) (lexical y _))))))) |
237 | ||
238 | ;; Strict argument evaluation also adds info to the DB. | |
239 | (pass-if-cse | |
240 | (lambda (x) | |
241 | ((lambda (z) | |
242 | (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
243 | (struct-ref x 2) | |
244 | (throw 'bar)))) | |
245 | (if (and (struct? x) (eq? (struct-vtable x) x-vtable)) | |
246 | (struct-ref x 1) | |
247 | (throw 'foo)))) | |
248 | ||
249 | (lambda _ | |
250 | (lambda-case | |
251 | (((x) #f #f #f () (_)) | |
4eaf64cd AW |
252 | (let (z) (_) |
253 | ((fix (failure) (_) | |
254 | ((lambda _ | |
255 | (lambda-case | |
256 | ((() #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) | |
261 | (lexical x _)) | |
262 | (toplevel x-vtable)) | |
263 | (apply (primitive struct-ref) (lexical x _) (const 1)) | |
264 | (apply (lexical failure _))) | |
265 | (apply (lexical failure _))))) | |
f66cbb99 | 266 | (apply (primitive +) (lexical z _) |
73001b06 AW |
267 | (apply (primitive struct-ref) (lexical x _) (const 2)))))))) |
268 | ||
269 | ;; Replacing named expressions with lexicals. | |
270 | (pass-if-cse | |
271 | (let ((x (car y))) | |
272 | (cons x (car y))) | |
273 | (let (x) (_) ((apply (primitive car) (toplevel y))) | |
274 | (apply (primitive cons) (lexical x _) (lexical x _))))) |