Commit | Line | Data |
---|---|---|
f66cbb99 AW |
1 | ;;; Common Subexpression Elimination (CSE) on Tree-IL |
2 | ||
19113f1c | 3 | ;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. |
f66cbb99 AW |
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 | |
f66cbb99 AW |
133 | (lambda (exp res) |
134 | (match exp | |
135 | (($ <lexical-set> src name gensym exp) | |
136 | (vhash-consq gensym #t res)) | |
137 | (_ res))) | |
138 | (lambda (exp res) res) | |
139 | table exp)) | |
140 | ||
141 | (define (boolean-valued-primitive? primitive) | |
142 | (or (negate-primitive primitive) | |
143 | (eq? primitive 'not) | |
144 | (let ((chars (symbol->string primitive))) | |
145 | (eqv? (string-ref chars (1- (string-length chars))) | |
146 | #\?)))) | |
147 | ||
148 | (define (boolean-valued-expression? x ctx) | |
149 | (match x | |
0ea5ba9a | 150 | (($ <primcall> _ (? boolean-valued-primitive?)) #t) |
f66cbb99 AW |
151 | (($ <const> _ (? boolean?)) #t) |
152 | (_ (eq? ctx 'test)))) | |
153 | ||
dc1ee620 AW |
154 | (define (singly-valued-expression? x ctx) |
155 | (match x | |
156 | (($ <const>) #t) | |
157 | (($ <lexical-ref>) #t) | |
158 | (($ <void>) #t) | |
159 | (($ <lexical-ref>) #t) | |
160 | (($ <primitive-ref>) #t) | |
161 | (($ <module-ref>) #t) | |
162 | (($ <toplevel-ref>) #t) | |
74bbb994 AW |
163 | (($ <primcall> _ (? singly-valued-primitive?)) #t) |
164 | (($ <primcall> _ 'values (val)) #t) | |
dc1ee620 AW |
165 | (($ <lambda>) #t) |
166 | (_ (eq? ctx 'value)))) | |
167 | ||
f66cbb99 AW |
168 | (define* (cse exp) |
169 | "Eliminate common subexpressions in EXP." | |
170 | ||
171 | (define assigned-lexical? | |
172 | (let ((table (build-assigned-var-table exp))) | |
173 | (lambda (sym) | |
174 | (vhash-assq sym table)))) | |
175 | ||
63216d80 | 176 | (define %compute-effects |
f66cbb99 AW |
177 | (make-effects-analyzer assigned-lexical?)) |
178 | ||
179 | (define (negate exp ctx) | |
180 | (match exp | |
181 | (($ <const> src x) | |
182 | (make-const src (not x))) | |
183 | (($ <void> src) | |
184 | (make-const src #f)) | |
185 | (($ <conditional> src test consequent alternate) | |
186 | (make-conditional src test (negate consequent ctx) (negate alternate ctx))) | |
0ea5ba9a | 187 | (($ <primcall> _ 'not |
f66cbb99 AW |
188 | ((and x (? (cut boolean-valued-expression? <> ctx))))) |
189 | x) | |
0ea5ba9a AW |
190 | (($ <primcall> src (and pred (? negate-primitive)) args) |
191 | (make-primcall src (negate-primitive pred) args)) | |
f66cbb99 | 192 | (_ |
0ea5ba9a | 193 | (make-primcall #f 'not (list exp))))) |
f66cbb99 AW |
194 | |
195 | ||
f66cbb99 AW |
196 | (define (hasher n) |
197 | (lambda (x size) (modulo n size))) | |
198 | ||
199 | (define (add-to-db exp effects ctx db) | |
200 | (let ((v (vector exp effects ctx)) | |
1fb39dc5 | 201 | (h (tree-il-hash exp))) |
f66cbb99 AW |
202 | (vhash-cons v h db (hasher h)))) |
203 | ||
204 | (define (control-flow-boundary db) | |
205 | (let ((h (hashq 'lambda most-positive-fixnum))) | |
206 | (vhash-cons 'lambda h db (hasher h)))) | |
207 | ||
208 | (define (find-dominating-expression exp effects ctx db) | |
209 | (define (entry-matches? v1 v2) | |
210 | (match (if (vector? v1) v1 v2) | |
211 | (#(exp* effects* ctx*) | |
1fb39dc5 | 212 | (and (tree-il=? exp exp*) |
f66cbb99 AW |
213 | (or (not ctx) (eq? ctx* ctx)))) |
214 | (_ #f))) | |
215 | ||
216 | (let ((len (vlist-length db)) | |
1fb39dc5 | 217 | (h (tree-il-hash exp))) |
f66cbb99 AW |
218 | (and (vhash-assoc #t db entry-matches? (hasher h)) |
219 | (let lp ((n 0)) | |
220 | (and (< n len) | |
221 | (match (vlist-ref db n) | |
222 | (('lambda . h*) | |
223 | ;; We assume that lambdas can escape and thus be | |
224 | ;; called from anywhere. Thus code inside a lambda | |
225 | ;; only has a dominating expression if it does not | |
226 | ;; depend on any effects. | |
227 | (and (not (depends-on-effects? effects &all-effects)) | |
228 | (lp (1+ n)))) | |
229 | ((#(exp* effects* ctx*) . h*) | |
230 | (log 'walk (unparse-tree-il exp) effects | |
231 | (unparse-tree-il exp*) effects* ctx*) | |
232 | (or (and (= h h*) | |
233 | (or (not ctx) (eq? ctx ctx*)) | |
1fb39dc5 | 234 | (tree-il=? exp exp*)) |
f66cbb99 AW |
235 | (and (effects-commute? effects effects*) |
236 | (lp (1+ n))))))))))) | |
237 | ||
238 | ;; Return #t if EXP is dominated by an instance of itself. In that | |
239 | ;; case, we can exclude *type-check* effects, because the first | |
240 | ;; expression already caused them if needed. | |
241 | (define (has-dominating-effect? exp effects db) | |
242 | (or (constant? effects) | |
243 | (and | |
244 | (effect-free? | |
245 | (exclude-effects effects | |
246 | (logior &zero-values | |
247 | &allocation | |
248 | &type-check))) | |
249 | (find-dominating-expression exp effects #f db)))) | |
250 | ||
251 | (define (find-dominating-test exp effects db) | |
252 | (and | |
253 | (effect-free? | |
254 | (exclude-effects effects (logior &allocation | |
255 | &type-check))) | |
256 | (match exp | |
257 | (($ <const> src val) | |
258 | (if (boolean? val) | |
259 | exp | |
260 | (make-const src (not (not val))))) | |
261 | ;; For (not FOO), try to prove FOO, then negate the result. | |
0ea5ba9a | 262 | (($ <primcall> src 'not (exp*)) |
f66cbb99 AW |
263 | (match (find-dominating-test exp* effects db) |
264 | (($ <const> _ val) | |
265 | (log 'inferring exp (not val)) | |
266 | (make-const src (not val))) | |
267 | (_ | |
268 | #f))) | |
269 | (_ | |
270 | (cond | |
4d1ae112 | 271 | ((find-dominating-expression exp effects 'test db) |
f66cbb99 AW |
272 | ;; We have an EXP fact, so we infer #t. |
273 | (log 'inferring exp #t) | |
274 | (make-const (tree-il-src exp) #t)) | |
4d1ae112 | 275 | ((find-dominating-expression (negate exp 'test) effects 'test db) |
f66cbb99 AW |
276 | ;; We have a (not EXP) fact, so we infer #f. |
277 | (log 'inferring exp #f) | |
278 | (make-const (tree-il-src exp) #f)) | |
279 | (else | |
280 | ;; Otherwise we don't know. | |
281 | #f)))))) | |
282 | ||
283 | (define (add-to-env exp name sym db env) | |
284 | (let* ((v (vector exp name sym (vlist-length db))) | |
1fb39dc5 | 285 | (h (tree-il-hash exp))) |
f66cbb99 AW |
286 | (vhash-cons v h env (hasher h)))) |
287 | ||
288 | (define (augment-env env names syms exps db) | |
289 | (if (null? names) | |
290 | env | |
291 | (let ((name (car names)) (sym (car syms)) (exp (car exps))) | |
292 | (augment-env (if (or (assigned-lexical? sym) | |
293 | (lexical-ref? exp)) | |
294 | env | |
295 | (add-to-env exp name sym db env)) | |
296 | (cdr names) (cdr syms) (cdr exps) db)))) | |
297 | ||
298 | (define (find-dominating-lexical exp effects env db) | |
299 | (define (entry-matches? v1 v2) | |
300 | (match (if (vector? v1) v1 v2) | |
301 | (#(exp* name sym db) | |
1fb39dc5 | 302 | (tree-il=? exp exp*)) |
f66cbb99 AW |
303 | (_ #f))) |
304 | ||
73001b06 AW |
305 | (define (unroll db base n) |
306 | (or (zero? n) | |
307 | (match (vlist-ref db base) | |
f66cbb99 AW |
308 | (('lambda . h*) |
309 | ;; See note in find-dominating-expression. | |
310 | (and (not (depends-on-effects? effects &all-effects)) | |
73001b06 | 311 | (unroll db (1+ base) (1- n)))) |
f66cbb99 AW |
312 | ((#(exp* effects* ctx*) . h*) |
313 | (and (effects-commute? effects effects*) | |
73001b06 | 314 | (unroll db (1+ base) (1- n))))))) |
f66cbb99 | 315 | |
1fb39dc5 | 316 | (let ((h (tree-il-hash exp))) |
f66cbb99 AW |
317 | (and (effect-free? (exclude-effects effects &type-check)) |
318 | (vhash-assoc exp env entry-matches? (hasher h)) | |
73001b06 AW |
319 | (let ((env-len (vlist-length env)) |
320 | (db-len (vlist-length db))) | |
321 | (let lp ((n 0) (m 0)) | |
f66cbb99 AW |
322 | (and (< n env-len) |
323 | (match (vlist-ref env n) | |
324 | ((#(exp* name sym db-len*) . h*) | |
2c7b7e0f LC |
325 | (let ((niter (- (- db-len db-len*) m))) |
326 | (and (unroll db m niter) | |
327 | (if (and (= h h*) (tree-il=? exp* exp)) | |
328 | (make-lexical-ref (tree-il-src exp) name sym) | |
329 | (lp (1+ n) (- db-len db-len*))))))))))))) | |
f66cbb99 | 330 | |
63216d80 AW |
331 | (define (lookup-lexical sym env) |
332 | (let ((env-len (vlist-length env))) | |
333 | (let lp ((n 0)) | |
334 | (and (< n env-len) | |
335 | (match (vlist-ref env n) | |
336 | ((#(exp _ sym* _) . _) | |
337 | (if (eq? sym sym*) | |
338 | exp | |
339 | (lp (1+ n))))))))) | |
340 | ||
f66cbb99 AW |
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 | ||
63216d80 AW |
368 | (define (compute-effects exp) |
369 | (%compute-effects exp (lambda (sym) (lookup-lexical sym env)))) | |
370 | ||
371 | (define (bailout? exp) | |
372 | (causes-effects? (compute-effects exp) &definite-bailout)) | |
373 | ||
f66cbb99 AW |
374 | (define (return exp db*) |
375 | (let ((effects (compute-effects exp))) | |
376 | (cond | |
377 | ((and (eq? ctx 'effect) | |
378 | (not (lambda-case? exp)) | |
379 | (or (effect-free? | |
380 | (exclude-effects effects | |
381 | (logior &zero-values | |
382 | &allocation))) | |
383 | (has-dominating-effect? exp effects db))) | |
73001b06 AW |
384 | (cond |
385 | ((void? exp) | |
386 | (values exp db*)) | |
387 | (else | |
388 | (log 'elide ctx (unparse-tree-il exp)) | |
389 | (values (make-void #f) db*)))) | |
f66cbb99 AW |
390 | ((and (boolean-valued-expression? exp ctx) |
391 | (find-dominating-test exp effects db)) | |
392 | => (lambda (exp) | |
393 | (log 'propagate-test ctx (unparse-tree-il exp)) | |
394 | (values exp db*))) | |
dc1ee620 | 395 | ((and (singly-valued-expression? exp ctx) |
f66cbb99 AW |
396 | (find-dominating-lexical exp effects env db)) |
397 | => (lambda (exp) | |
398 | (log 'propagate-value ctx (unparse-tree-il exp)) | |
399 | (values exp db*))) | |
400 | ((and (constant? effects) (memq ctx '(value values))) | |
401 | ;; Adds nothing to the db. | |
402 | (values exp db*)) | |
403 | (else | |
404 | (log 'return ctx effects (unparse-tree-il exp) db*) | |
405 | (values exp | |
406 | (add-to-db exp effects ctx db*)))))) | |
407 | ||
408 | (log 'visit ctx (unparse-tree-il exp) db env) | |
409 | ||
410 | (match exp | |
411 | (($ <const>) | |
412 | (return exp vlist-null)) | |
413 | (($ <void>) | |
414 | (return exp vlist-null)) | |
415 | (($ <lexical-ref> _ _ gensym) | |
416 | (return exp vlist-null)) | |
417 | (($ <lexical-set> src name gensym exp) | |
418 | (let*-values (((exp db*) (visit exp db env 'value))) | |
419 | (return (make-lexical-set src name gensym exp) | |
420 | db*))) | |
421 | (($ <let> src names gensyms vals body) | |
422 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
423 | ((body db**) (visit body (concat db* db) | |
424 | (augment-env env names gensyms vals db) | |
425 | ctx))) | |
426 | (return (make-let src names gensyms vals body) | |
427 | (concat db** db*)))) | |
428 | (($ <letrec> src in-order? names gensyms vals body) | |
429 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
430 | ((body db**) (visit body (concat db* db) | |
431 | (augment-env env names gensyms vals db) | |
432 | ctx))) | |
433 | (return (make-letrec src in-order? names gensyms vals body) | |
434 | (concat db** db*)))) | |
435 | (($ <fix> src names gensyms vals body) | |
436 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
437 | ((body db**) (visit body (concat db* db) env ctx))) | |
438 | (return (make-fix src names gensyms vals body) | |
439 | (concat db** db*)))) | |
440 | (($ <let-values> src producer consumer) | |
441 | (let*-values (((producer db*) (visit producer db env 'values)) | |
442 | ((consumer db**) (visit consumer (concat db* db) env ctx))) | |
443 | (return (make-let-values src producer consumer) | |
444 | (concat db** db*)))) | |
f66cbb99 AW |
445 | (($ <toplevel-ref>) |
446 | (return exp vlist-null)) | |
447 | (($ <module-ref>) | |
448 | (return exp vlist-null)) | |
449 | (($ <module-set> src mod name public? exp) | |
450 | (let*-values (((exp db*) (visit exp db env 'value))) | |
451 | (return (make-module-set src mod name public? exp) | |
452 | db*))) | |
453 | (($ <toplevel-define> src name exp) | |
454 | (let*-values (((exp db*) (visit exp db env 'value))) | |
455 | (return (make-toplevel-define src name exp) | |
456 | db*))) | |
457 | (($ <toplevel-set> src name exp) | |
458 | (let*-values (((exp db*) (visit exp db env 'value))) | |
459 | (return (make-toplevel-set src name exp) | |
460 | db*))) | |
461 | (($ <primitive-ref>) | |
462 | (return exp vlist-null)) | |
463 | (($ <conditional> src test consequent alternate) | |
464 | (let*-values | |
465 | (((test db+) (visit test db env 'test)) | |
466 | ((converse db-) (visit (negate test 'test) db env 'test)) | |
467 | ((consequent db++) (visit consequent (concat db+ db) env ctx)) | |
468 | ((alternate db--) (visit alternate (concat db- db) env ctx))) | |
469 | (match (make-conditional src test consequent alternate) | |
470 | (($ <conditional> _ ($ <const> _ exp)) | |
471 | (if exp | |
472 | (return consequent (concat db++ db+)) | |
473 | (return alternate (concat db-- db-)))) | |
474 | ;; (if FOO A A) => (begin FOO A) | |
475 | (($ <conditional> src _ | |
476 | ($ <const> _ a) ($ <const> _ (? (cut equal? a <>)))) | |
0ea5ba9a | 477 | (visit (make-seq #f test (make-const #f a)) |
f66cbb99 AW |
478 | db env ctx)) |
479 | ;; (if FOO #t #f) => FOO for boolean-valued FOO. | |
480 | (($ <conditional> src | |
481 | (? (cut boolean-valued-expression? <> ctx)) | |
482 | ($ <const> _ #t) ($ <const> _ #f)) | |
483 | (return test db+)) | |
484 | ;; (if FOO #f #t) => (not FOO) | |
485 | (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t)) | |
486 | (visit (negate test ctx) db env ctx)) | |
487 | ||
488 | ;; Allow "and"-like conditions to accumulate in test context. | |
489 | ((and c ($ <conditional> _ _ _ ($ <const> _ #f))) | |
490 | (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null))) | |
491 | ((and c ($ <conditional> _ _ ($ <const> _ #f) _)) | |
492 | (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null))) | |
493 | ||
494 | ;; Conditional bailouts turn expressions into predicates. | |
495 | ((and c ($ <conditional> _ _ _ (? bailout?))) | |
496 | (return c (concat db++ db+))) | |
497 | ((and c ($ <conditional> _ _ (? bailout?) _)) | |
498 | (return c (concat db-- db-))) | |
499 | ||
500 | (c | |
501 | (return c (intersection (concat db++ db+) (concat db-- db-))))))) | |
0ea5ba9a AW |
502 | (($ <primcall> src primitive args) |
503 | (let*-values (((args db*) (parallel-visit args db env 'value))) | |
504 | (return (make-primcall src primitive args) db*))) | |
505 | (($ <call> src proc args) | |
f66cbb99 AW |
506 | (let*-values (((proc db*) (visit proc db env 'value)) |
507 | ((args db**) (parallel-visit args db env 'value))) | |
0ea5ba9a | 508 | (return (make-call src proc args) |
f66cbb99 AW |
509 | (concat db** db*)))) |
510 | (($ <lambda> src meta body) | |
19113f1c AW |
511 | (let*-values (((body _) (if body |
512 | (visit body (control-flow-boundary db) | |
513 | env 'values) | |
514 | (values #f #f)))) | |
f66cbb99 AW |
515 | (return (make-lambda src meta body) |
516 | vlist-null))) | |
517 | (($ <lambda-case> src req opt rest kw inits gensyms body alt) | |
518 | (let*-values (((inits _) (parallel-visit inits db env 'value)) | |
519 | ((body db*) (visit body db env ctx)) | |
520 | ((alt _) (if alt | |
521 | (visit alt db env ctx) | |
522 | (values #f #f)))) | |
523 | (return (make-lambda-case src req opt rest kw inits gensyms body alt) | |
524 | (if alt vlist-null db*)))) | |
0ea5ba9a AW |
525 | (($ <seq> src head tail) |
526 | (let*-values (((head db*) (visit head db env 'effect))) | |
527 | (cond | |
528 | ((void? head) | |
529 | (visit tail db env ctx)) | |
530 | (else | |
531 | (let*-values (((tail db**) (visit tail (concat db* db) env ctx))) | |
532 | (values (make-seq src head tail) | |
533 | (concat db** db*))))))) | |
178a4092 | 534 | (($ <prompt> src escape-only? tag body handler) |
f66cbb99 | 535 | (let*-values (((tag db*) (visit tag db env 'value)) |
99983d54 AW |
536 | ((body _) (visit body (concat db* db) env |
537 | (if escape-only? ctx 'value))) | |
538 | ((handler _) (visit handler (concat db* db) env 'value))) | |
178a4092 | 539 | (return (make-prompt src escape-only? tag body handler) |
f66cbb99 AW |
540 | db*))) |
541 | (($ <abort> src tag args tail) | |
542 | (let*-values (((tag db*) (visit tag db env 'value)) | |
543 | ((args db**) (parallel-visit args db env 'value)) | |
544 | ((tail db***) (visit tail db env 'value))) | |
545 | (return (make-abort src tag args tail) | |
546 | (concat db* (concat db** db***)))))))) |