Commit | Line | Data |
---|---|---|
f66cbb99 AW |
1 | ;;; Common Subexpression Elimination (CSE) on Tree-IL |
2 | ||
3 | ;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. | |
4 | ||
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 3 of the License, or (at your option) any later version. | |
9 | ;;;; | |
10 | ;;;; This library is distributed in the hope that it will be useful, | |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | ;;;; Lesser General Public License for more details. | |
14 | ;;;; | |
15 | ;;;; You should have received a copy of the GNU Lesser General Public | |
16 | ;;;; License along with this library; if not, write to the Free Software | |
17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | (define-module (language tree-il cse) | |
20 | #:use-module (language tree-il) | |
21 | #:use-module (language tree-il primitives) | |
22 | #:use-module (language tree-il effects) | |
23 | #:use-module (ice-9 vlist) | |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (srfi srfi-1) | |
26 | #:use-module (srfi srfi-9) | |
27 | #:use-module (srfi srfi-11) | |
28 | #:use-module (srfi srfi-26) | |
29 | #:export (cse)) | |
30 | ||
31 | ;;; | |
32 | ;;; This pass eliminates common subexpressions in Tree-IL. It works | |
33 | ;;; best locally -- within a function -- so it is meant to be run after | |
34 | ;;; partial evaluation, which usually inlines functions and so opens up | |
35 | ;;; a bigger space for CSE to work. | |
36 | ;;; | |
37 | ;;; The algorithm traverses the tree of expressions, returning two | |
38 | ;;; values: the newly rebuilt tree, and a "database". The database is | |
39 | ;;; the set of expressions that will have been evaluated as part of | |
40 | ;;; evaluating an expression. For example, in: | |
41 | ;;; | |
42 | ;;; (1- (+ (if a b c) (* x y))) | |
43 | ;;; | |
44 | ;;; We can say that when it comes time to evaluate (1- <>), that the | |
45 | ;;; subexpressions +, x, y, and (* x y) must have been evaluated in | |
46 | ;;; values context. We know that a was evaluated in test context, but | |
47 | ;;; we don't know if it was true or false. | |
48 | ;;; | |
49 | ;;; The expressions in the database /dominate/ any subsequent | |
50 | ;;; expression: FOO dominates BAR if evaluation of BAR implies that any | |
51 | ;;; effects associated with FOO have already occured. | |
52 | ;;; | |
53 | ;;; When adding expressions to the database, we record the context in | |
54 | ;;; which they are evaluated. We treat expressions in test context | |
55 | ;;; specially: the presence of such an expression indicates that the | |
56 | ;;; expression is true. In this way we can elide duplicate predicates. | |
57 | ;;; | |
58 | ;;; Duplicate predicates are not common in code that users write, but | |
59 | ;;; can occur quite frequently in macro-generated code. | |
60 | ;;; | |
61 | ;;; For example: | |
62 | ;;; | |
63 | ;;; (and (foo? x) (foo-bar x)) | |
64 | ;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>)) | |
65 | ;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) | |
66 | ;;; (struct-ref x 1) | |
67 | ;;; (throw 'not-a-foo)) | |
68 | ;;; #f)) | |
69 | ;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>)) | |
70 | ;;; (struct-ref x 1) | |
71 | ;;; #f) | |
72 | ;;; | |
73 | ;;; A conditional bailout in effect context also has the effect of | |
74 | ;;; adding predicates to the database: | |
75 | ;;; | |
76 | ;;; (begin (foo-bar x) (foo-baz x)) | |
77 | ;;; => (begin | |
78 | ;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) | |
79 | ;;; (struct-ref x 1) | |
80 | ;;; (throw 'not-a-foo)) | |
81 | ;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) | |
82 | ;;; (struct-ref x 2) | |
83 | ;;; (throw 'not-a-foo))) | |
84 | ;;; => (begin | |
85 | ;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>)) | |
86 | ;;; (struct-ref x 1) | |
87 | ;;; (throw 'not-a-foo)) | |
88 | ;;; (struct-ref x 2)) | |
89 | ;;; | |
90 | ;;; When removing code, we have to ensure that the semantics of the | |
91 | ;;; source program and the residual program are the same. It's easy to | |
92 | ;;; ensure that they have the same value, because those manipulations | |
93 | ;;; are just algebraic, but the tricky thing is to ensure that the | |
94 | ;;; expressions exhibit the same ordering of effects. For that, we use | |
95 | ;;; the effects analysis of (language tree-il effects). We only | |
96 | ;;; eliminate code if the duplicate code commutes with all of the | |
97 | ;;; dominators on the path from the duplicate to the original. | |
98 | ;;; | |
99 | ;;; The implementation uses vhashes as the fundamental data structure. | |
100 | ;;; This can be seen as a form of global value numbering. This | |
101 | ;;; algorithm currently spends most of its time in vhash-assoc. I'm not | |
102 | ;;; sure whether that is due to our bad hash function in Guile 2.0, an | |
103 | ;;; inefficiency in vhashes, or what. Overall though the complexity | |
104 | ;;; should be linear, or N log N -- whatever vhash-assoc's complexity | |
105 | ;;; is. Walking the dominators is nonlinear, but that only happens when | |
106 | ;;; we've actually found a common subexpression so that should be OK. | |
107 | ;;; | |
108 | ||
109 | ;; Logging helpers, as in peval. | |
110 | ;; | |
111 | (define-syntax *logging* (identifier-syntax #f)) | |
112 | ;; (define %logging #f) | |
113 | ;; (define-syntax *logging* (identifier-syntax %logging)) | |
114 | (define-syntax log | |
115 | (syntax-rules (quote) | |
116 | ((log 'event arg ...) | |
117 | (if (and *logging* | |
118 | (or (eq? *logging* #t) | |
119 | (memq 'event *logging*))) | |
120 | (log* 'event arg ...))))) | |
121 | (define (log* event . args) | |
122 | (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print)) | |
123 | 'pretty-print))) | |
124 | (pp `(log ,event . ,args)) | |
125 | (newline) | |
126 | (values))) | |
127 | ||
128 | ;; A pre-pass on the source program to determine the set of assigned | |
129 | ;; lexicals. | |
130 | ;; | |
131 | (define* (build-assigned-var-table exp #:optional (table vlist-null)) | |
132 | (tree-il-fold | |
133 | (lambda (exp res) | |
134 | res) | |
135 | (lambda (exp res) | |
136 | (match exp | |
137 | (($ <lexical-set> src name gensym exp) | |
138 | (vhash-consq gensym #t res)) | |
139 | (_ res))) | |
140 | (lambda (exp res) res) | |
141 | table exp)) | |
142 | ||
143 | (define (boolean-valued-primitive? primitive) | |
144 | (or (negate-primitive primitive) | |
145 | (eq? primitive 'not) | |
146 | (let ((chars (symbol->string primitive))) | |
147 | (eqv? (string-ref chars (1- (string-length chars))) | |
148 | #\?)))) | |
149 | ||
150 | (define (boolean-valued-expression? x ctx) | |
151 | (match x | |
152 | (($ <application> _ | |
153 | ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t) | |
154 | (($ <const> _ (? boolean?)) #t) | |
155 | (_ (eq? ctx 'test)))) | |
156 | ||
dc1ee620 AW |
157 | (define (singly-valued-expression? x ctx) |
158 | (match x | |
159 | (($ <const>) #t) | |
160 | (($ <lexical-ref>) #t) | |
161 | (($ <void>) #t) | |
162 | (($ <lexical-ref>) #t) | |
163 | (($ <primitive-ref>) #t) | |
164 | (($ <module-ref>) #t) | |
165 | (($ <toplevel-ref>) #t) | |
166 | (($ <application> _ | |
167 | ($ <primitive-ref> _ (? singly-valued-primitive?))) #t) | |
168 | (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t) | |
169 | (($ <lambda>) #t) | |
170 | (_ (eq? ctx 'value)))) | |
171 | ||
f66cbb99 AW |
172 | (define* (cse exp) |
173 | "Eliminate common subexpressions in EXP." | |
174 | ||
175 | (define assigned-lexical? | |
176 | (let ((table (build-assigned-var-table exp))) | |
177 | (lambda (sym) | |
178 | (vhash-assq sym table)))) | |
179 | ||
180 | (define compute-effects | |
181 | (make-effects-analyzer assigned-lexical?)) | |
182 | ||
183 | (define (negate exp ctx) | |
184 | (match exp | |
185 | (($ <const> src x) | |
186 | (make-const src (not x))) | |
187 | (($ <void> src) | |
188 | (make-const src #f)) | |
189 | (($ <conditional> src test consequent alternate) | |
190 | (make-conditional src test (negate consequent ctx) (negate alternate ctx))) | |
191 | (($ <application> _ ($ <primitive-ref> _ 'not) | |
192 | ((and x (? (cut boolean-valued-expression? <> ctx))))) | |
193 | x) | |
194 | (($ <application> src | |
195 | ($ <primitive-ref> _ (and pred (? negate-primitive))) | |
196 | args) | |
197 | (make-application src | |
198 | (make-primitive-ref #f (negate-primitive pred)) | |
199 | args)) | |
200 | (_ | |
201 | (make-application #f (make-primitive-ref #f 'not) (list exp))))) | |
202 | ||
203 | ||
204 | (define (bailout? exp) | |
205 | (causes-effects? (compute-effects exp) &definite-bailout)) | |
206 | ||
f66cbb99 AW |
207 | (define (hasher n) |
208 | (lambda (x size) (modulo n size))) | |
209 | ||
210 | (define (add-to-db exp effects ctx db) | |
211 | (let ((v (vector exp effects ctx)) | |
1fb39dc5 | 212 | (h (tree-il-hash exp))) |
f66cbb99 AW |
213 | (vhash-cons v h db (hasher h)))) |
214 | ||
215 | (define (control-flow-boundary db) | |
216 | (let ((h (hashq 'lambda most-positive-fixnum))) | |
217 | (vhash-cons 'lambda h db (hasher h)))) | |
218 | ||
219 | (define (find-dominating-expression exp effects ctx db) | |
220 | (define (entry-matches? v1 v2) | |
221 | (match (if (vector? v1) v1 v2) | |
222 | (#(exp* effects* ctx*) | |
1fb39dc5 | 223 | (and (tree-il=? exp exp*) |
f66cbb99 AW |
224 | (or (not ctx) (eq? ctx* ctx)))) |
225 | (_ #f))) | |
226 | ||
227 | (let ((len (vlist-length db)) | |
1fb39dc5 | 228 | (h (tree-il-hash exp))) |
f66cbb99 AW |
229 | (and (vhash-assoc #t db entry-matches? (hasher h)) |
230 | (let lp ((n 0)) | |
231 | (and (< n len) | |
232 | (match (vlist-ref db n) | |
233 | (('lambda . h*) | |
234 | ;; We assume that lambdas can escape and thus be | |
235 | ;; called from anywhere. Thus code inside a lambda | |
236 | ;; only has a dominating expression if it does not | |
237 | ;; depend on any effects. | |
238 | (and (not (depends-on-effects? effects &all-effects)) | |
239 | (lp (1+ n)))) | |
240 | ((#(exp* effects* ctx*) . h*) | |
241 | (log 'walk (unparse-tree-il exp) effects | |
242 | (unparse-tree-il exp*) effects* ctx*) | |
243 | (or (and (= h h*) | |
244 | (or (not ctx) (eq? ctx ctx*)) | |
1fb39dc5 | 245 | (tree-il=? exp exp*)) |
f66cbb99 AW |
246 | (and (effects-commute? effects effects*) |
247 | (lp (1+ n))))))))))) | |
248 | ||
249 | ;; Return #t if EXP is dominated by an instance of itself. In that | |
250 | ;; case, we can exclude *type-check* effects, because the first | |
251 | ;; expression already caused them if needed. | |
252 | (define (has-dominating-effect? exp effects db) | |
253 | (or (constant? effects) | |
254 | (and | |
255 | (effect-free? | |
256 | (exclude-effects effects | |
257 | (logior &zero-values | |
258 | &allocation | |
259 | &type-check))) | |
260 | (find-dominating-expression exp effects #f db)))) | |
261 | ||
262 | (define (find-dominating-test exp effects db) | |
263 | (and | |
264 | (effect-free? | |
265 | (exclude-effects effects (logior &allocation | |
266 | &type-check))) | |
267 | (match exp | |
268 | (($ <const> src val) | |
269 | (if (boolean? val) | |
270 | exp | |
271 | (make-const src (not (not val))))) | |
272 | ;; For (not FOO), try to prove FOO, then negate the result. | |
273 | (($ <application> src ($ <primitive-ref> _ 'not) (exp*)) | |
274 | (match (find-dominating-test exp* effects db) | |
275 | (($ <const> _ val) | |
276 | (log 'inferring exp (not val)) | |
277 | (make-const src (not val))) | |
278 | (_ | |
279 | #f))) | |
280 | (_ | |
281 | (cond | |
282 | ((find-dominating-expression exp effects #f db) | |
283 | ;; We have an EXP fact, so we infer #t. | |
284 | (log 'inferring exp #t) | |
285 | (make-const (tree-il-src exp) #t)) | |
286 | ((find-dominating-expression (negate exp 'test) effects #f db) | |
287 | ;; We have a (not EXP) fact, so we infer #f. | |
288 | (log 'inferring exp #f) | |
289 | (make-const (tree-il-src exp) #f)) | |
290 | (else | |
291 | ;; Otherwise we don't know. | |
292 | #f)))))) | |
293 | ||
294 | (define (add-to-env exp name sym db env) | |
295 | (let* ((v (vector exp name sym (vlist-length db))) | |
1fb39dc5 | 296 | (h (tree-il-hash exp))) |
f66cbb99 AW |
297 | (vhash-cons v h env (hasher h)))) |
298 | ||
299 | (define (augment-env env names syms exps db) | |
300 | (if (null? names) | |
301 | env | |
302 | (let ((name (car names)) (sym (car syms)) (exp (car exps))) | |
303 | (augment-env (if (or (assigned-lexical? sym) | |
304 | (lexical-ref? exp)) | |
305 | env | |
306 | (add-to-env exp name sym db env)) | |
307 | (cdr names) (cdr syms) (cdr exps) db)))) | |
308 | ||
309 | (define (find-dominating-lexical exp effects env db) | |
310 | (define (entry-matches? v1 v2) | |
311 | (match (if (vector? v1) v1 v2) | |
312 | (#(exp* name sym db) | |
1fb39dc5 | 313 | (tree-il=? exp exp*)) |
f66cbb99 AW |
314 | (_ #f))) |
315 | ||
73001b06 AW |
316 | (define (unroll db base n) |
317 | (or (zero? n) | |
318 | (match (vlist-ref db base) | |
f66cbb99 AW |
319 | (('lambda . h*) |
320 | ;; See note in find-dominating-expression. | |
321 | (and (not (depends-on-effects? effects &all-effects)) | |
73001b06 | 322 | (unroll db (1+ base) (1- n)))) |
f66cbb99 AW |
323 | ((#(exp* effects* ctx*) . h*) |
324 | (and (effects-commute? effects effects*) | |
73001b06 | 325 | (unroll db (1+ base) (1- n))))))) |
f66cbb99 | 326 | |
1fb39dc5 | 327 | (let ((h (tree-il-hash exp))) |
f66cbb99 AW |
328 | (and (effect-free? (exclude-effects effects &type-check)) |
329 | (vhash-assoc exp env entry-matches? (hasher h)) | |
73001b06 AW |
330 | (let ((env-len (vlist-length env)) |
331 | (db-len (vlist-length db))) | |
332 | (let lp ((n 0) (m 0)) | |
f66cbb99 AW |
333 | (and (< n env-len) |
334 | (match (vlist-ref env n) | |
335 | ((#(exp* name sym db-len*) . h*) | |
73001b06 | 336 | (and (unroll db m (- db-len db-len*)) |
1fb39dc5 | 337 | (if (and (= h h*) (tree-il=? exp* exp)) |
f66cbb99 | 338 | (make-lexical-ref (tree-il-src exp) name sym) |
73001b06 | 339 | (lp (1+ n) (- db-len db-len*)))))))))))) |
f66cbb99 AW |
340 | |
341 | (define (intersection db+ db-) | |
342 | (vhash-fold-right | |
343 | (lambda (k h out) | |
344 | (if (vhash-assoc k db- equal? (hasher h)) | |
345 | (vhash-cons k h out (hasher h)) | |
346 | out)) | |
347 | vlist-null | |
348 | db+)) | |
349 | ||
350 | (define (concat db1 db2) | |
351 | (vhash-fold-right (lambda (k h tail) | |
352 | (vhash-cons k h tail (hasher h))) | |
353 | db2 db1)) | |
354 | ||
355 | (let visit ((exp exp) | |
356 | (db vlist-null) ; dominating expressions: #(exp effects ctx) -> hash | |
357 | (env vlist-null) ; named expressions: #(exp name sym db) -> hash | |
358 | (ctx 'values)) ; test, effect, value, or values | |
359 | ||
360 | (define (parallel-visit exps db env ctx) | |
361 | (let lp ((in exps) (out '()) (db* vlist-null)) | |
362 | (if (pair? in) | |
363 | (call-with-values (lambda () (visit (car in) db env ctx)) | |
364 | (lambda (x db**) | |
365 | (lp (cdr in) (cons x out) (concat db** db*)))) | |
366 | (values (reverse out) db*)))) | |
367 | ||
368 | (define (return exp db*) | |
369 | (let ((effects (compute-effects exp))) | |
370 | (cond | |
371 | ((and (eq? ctx 'effect) | |
372 | (not (lambda-case? exp)) | |
373 | (or (effect-free? | |
374 | (exclude-effects effects | |
375 | (logior &zero-values | |
376 | &allocation))) | |
377 | (has-dominating-effect? exp effects db))) | |
73001b06 AW |
378 | (cond |
379 | ((void? exp) | |
380 | (values exp db*)) | |
381 | (else | |
382 | (log 'elide ctx (unparse-tree-il exp)) | |
383 | (values (make-void #f) db*)))) | |
f66cbb99 AW |
384 | ((and (boolean-valued-expression? exp ctx) |
385 | (find-dominating-test exp effects db)) | |
386 | => (lambda (exp) | |
387 | (log 'propagate-test ctx (unparse-tree-il exp)) | |
388 | (values exp db*))) | |
dc1ee620 | 389 | ((and (singly-valued-expression? exp ctx) |
f66cbb99 AW |
390 | (find-dominating-lexical exp effects env db)) |
391 | => (lambda (exp) | |
392 | (log 'propagate-value ctx (unparse-tree-il exp)) | |
393 | (values exp db*))) | |
394 | ((and (constant? effects) (memq ctx '(value values))) | |
395 | ;; Adds nothing to the db. | |
396 | (values exp db*)) | |
397 | (else | |
398 | (log 'return ctx effects (unparse-tree-il exp) db*) | |
399 | (values exp | |
400 | (add-to-db exp effects ctx db*)))))) | |
401 | ||
402 | (log 'visit ctx (unparse-tree-il exp) db env) | |
403 | ||
404 | (match exp | |
405 | (($ <const>) | |
406 | (return exp vlist-null)) | |
407 | (($ <void>) | |
408 | (return exp vlist-null)) | |
409 | (($ <lexical-ref> _ _ gensym) | |
410 | (return exp vlist-null)) | |
411 | (($ <lexical-set> src name gensym exp) | |
412 | (let*-values (((exp db*) (visit exp db env 'value))) | |
413 | (return (make-lexical-set src name gensym exp) | |
414 | db*))) | |
415 | (($ <let> src names gensyms vals body) | |
416 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
417 | ((body db**) (visit body (concat db* db) | |
418 | (augment-env env names gensyms vals db) | |
419 | ctx))) | |
420 | (return (make-let src names gensyms vals body) | |
421 | (concat db** db*)))) | |
422 | (($ <letrec> src in-order? names gensyms vals body) | |
423 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
424 | ((body db**) (visit body (concat db* db) | |
425 | (augment-env env names gensyms vals db) | |
426 | ctx))) | |
427 | (return (make-letrec src in-order? names gensyms vals body) | |
428 | (concat db** db*)))) | |
429 | (($ <fix> src names gensyms vals body) | |
430 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
431 | ((body db**) (visit body (concat db* db) env ctx))) | |
432 | (return (make-fix src names gensyms vals body) | |
433 | (concat db** db*)))) | |
434 | (($ <let-values> src producer consumer) | |
435 | (let*-values (((producer db*) (visit producer db env 'values)) | |
436 | ((consumer db**) (visit consumer (concat db* db) env ctx))) | |
437 | (return (make-let-values src producer consumer) | |
438 | (concat db** db*)))) | |
439 | (($ <dynwind> src winder body unwinder) | |
440 | (let*-values (((pre db*) (visit winder db env 'value)) | |
441 | ((body db**) (visit body (concat db* db) env ctx)) | |
442 | ((post db***) (visit unwinder db env 'value))) | |
443 | (return (make-dynwind src pre body post) | |
444 | (concat db* (concat db** db***))))) | |
445 | (($ <dynlet> src fluids vals body) | |
446 | (let*-values (((fluids db*) (parallel-visit fluids db env 'value)) | |
447 | ((vals db**) (parallel-visit vals db env 'value)) | |
448 | ((body db***) (visit body (concat db** (concat db* db)) | |
449 | env ctx))) | |
450 | (return (make-dynlet src fluids vals body) | |
451 | (concat db*** (concat db** db*))))) | |
452 | (($ <dynref> src fluid) | |
453 | (let*-values (((fluid db*) (visit fluid db env 'value))) | |
454 | (return (make-dynref src fluid) | |
455 | db*))) | |
456 | (($ <dynset> src fluid exp) | |
457 | (let*-values (((fluid db*) (visit fluid db env 'value)) | |
458 | ((exp db**) (visit exp db env 'value))) | |
459 | (return (make-dynset src fluid exp) | |
460 | (concat db** db*)))) | |
461 | (($ <toplevel-ref>) | |
462 | (return exp vlist-null)) | |
463 | (($ <module-ref>) | |
464 | (return exp vlist-null)) | |
465 | (($ <module-set> src mod name public? exp) | |
466 | (let*-values (((exp db*) (visit exp db env 'value))) | |
467 | (return (make-module-set src mod name public? exp) | |
468 | db*))) | |
469 | (($ <toplevel-define> src name exp) | |
470 | (let*-values (((exp db*) (visit exp db env 'value))) | |
471 | (return (make-toplevel-define src name exp) | |
472 | db*))) | |
473 | (($ <toplevel-set> src name exp) | |
474 | (let*-values (((exp db*) (visit exp db env 'value))) | |
475 | (return (make-toplevel-set src name exp) | |
476 | db*))) | |
477 | (($ <primitive-ref>) | |
478 | (return exp vlist-null)) | |
479 | (($ <conditional> src test consequent alternate) | |
480 | (let*-values | |
481 | (((test db+) (visit test db env 'test)) | |
482 | ((converse db-) (visit (negate test 'test) db env 'test)) | |
483 | ((consequent db++) (visit consequent (concat db+ db) env ctx)) | |
484 | ((alternate db--) (visit alternate (concat db- db) env ctx))) | |
485 | (match (make-conditional src test consequent alternate) | |
486 | (($ <conditional> _ ($ <const> _ exp)) | |
487 | (if exp | |
488 | (return consequent (concat db++ db+)) | |
489 | (return alternate (concat db-- db-)))) | |
490 | ;; (if FOO A A) => (begin FOO A) | |
491 | (($ <conditional> src _ | |
492 | ($ <const> _ a) ($ <const> _ (? (cut equal? a <>)))) | |
493 | (visit (make-sequence #f (list test (make-const #f a))) | |
494 | db env ctx)) | |
495 | ;; (if FOO #t #f) => FOO for boolean-valued FOO. | |
496 | (($ <conditional> src | |
497 | (? (cut boolean-valued-expression? <> ctx)) | |
498 | ($ <const> _ #t) ($ <const> _ #f)) | |
499 | (return test db+)) | |
500 | ;; (if FOO #f #t) => (not FOO) | |
501 | (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t)) | |
502 | (visit (negate test ctx) db env ctx)) | |
503 | ||
504 | ;; Allow "and"-like conditions to accumulate in test context. | |
505 | ((and c ($ <conditional> _ _ _ ($ <const> _ #f))) | |
506 | (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null))) | |
507 | ((and c ($ <conditional> _ _ ($ <const> _ #f) _)) | |
508 | (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null))) | |
509 | ||
510 | ;; Conditional bailouts turn expressions into predicates. | |
511 | ((and c ($ <conditional> _ _ _ (? bailout?))) | |
512 | (return c (concat db++ db+))) | |
513 | ((and c ($ <conditional> _ _ (? bailout?) _)) | |
514 | (return c (concat db-- db-))) | |
515 | ||
516 | (c | |
517 | (return c (intersection (concat db++ db+) (concat db-- db-))))))) | |
518 | (($ <application> src proc args) | |
519 | (let*-values (((proc db*) (visit proc db env 'value)) | |
520 | ((args db**) (parallel-visit args db env 'value))) | |
521 | (return (make-application src proc args) | |
522 | (concat db** db*)))) | |
523 | (($ <lambda> src meta body) | |
524 | (let*-values (((body _) (visit body (control-flow-boundary db) | |
525 | env 'values))) | |
526 | (return (make-lambda src meta body) | |
527 | vlist-null))) | |
528 | (($ <lambda-case> src req opt rest kw inits gensyms body alt) | |
529 | (let*-values (((inits _) (parallel-visit inits db env 'value)) | |
530 | ((body db*) (visit body db env ctx)) | |
531 | ((alt _) (if alt | |
532 | (visit alt db env ctx) | |
533 | (values #f #f)))) | |
534 | (return (make-lambda-case src req opt rest kw inits gensyms body alt) | |
535 | (if alt vlist-null db*)))) | |
536 | (($ <sequence> src exps) | |
537 | (let lp ((in exps) (out '()) (db* vlist-null)) | |
538 | (match in | |
539 | ((last) | |
540 | (let*-values (((last db**) (visit last (concat db* db) env ctx))) | |
541 | (if (null? out) | |
542 | (return last (concat db** db*)) | |
543 | (return (make-sequence src (reverse (cons last out))) | |
544 | (concat db** db*))))) | |
545 | ((head . rest) | |
546 | (let*-values (((head db**) (visit head (concat db* db) env 'effect))) | |
547 | (cond | |
548 | ((sequence? head) | |
549 | (lp (append (sequence-exps head) rest) out db*)) | |
550 | ((void? head) | |
551 | (lp rest out db*)) | |
552 | (else | |
553 | (lp rest (cons head out) (concat db** db*))))))))) | |
554 | (($ <prompt> src tag body handler) | |
555 | (let*-values (((tag db*) (visit tag db env 'value)) | |
556 | ((body _) (visit body (concat db* db) env ctx)) | |
557 | ((handler _) (visit handler (concat db* db) env ctx))) | |
558 | (return (make-prompt src tag body handler) | |
559 | db*))) | |
560 | (($ <abort> src tag args tail) | |
561 | (let*-values (((tag db*) (visit tag db env 'value)) | |
562 | ((args db**) (parallel-visit args db env 'value)) | |
563 | ((tail db***) (visit tail db env 'value))) | |
564 | (return (make-abort src tag args tail) | |
565 | (concat db* (concat db** db***)))))))) |