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 | ||
63216d80 | 180 | (define %compute-effects |
f66cbb99 AW |
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 | ||
f66cbb99 AW |
204 | (define (hasher n) |
205 | (lambda (x size) (modulo n size))) | |
206 | ||
207 | (define (add-to-db exp effects ctx db) | |
208 | (let ((v (vector exp effects ctx)) | |
1fb39dc5 | 209 | (h (tree-il-hash exp))) |
f66cbb99 AW |
210 | (vhash-cons v h db (hasher h)))) |
211 | ||
212 | (define (control-flow-boundary db) | |
213 | (let ((h (hashq 'lambda most-positive-fixnum))) | |
214 | (vhash-cons 'lambda h db (hasher h)))) | |
215 | ||
216 | (define (find-dominating-expression exp effects ctx db) | |
217 | (define (entry-matches? v1 v2) | |
218 | (match (if (vector? v1) v1 v2) | |
219 | (#(exp* effects* ctx*) | |
1fb39dc5 | 220 | (and (tree-il=? exp exp*) |
f66cbb99 AW |
221 | (or (not ctx) (eq? ctx* ctx)))) |
222 | (_ #f))) | |
223 | ||
224 | (let ((len (vlist-length db)) | |
1fb39dc5 | 225 | (h (tree-il-hash exp))) |
f66cbb99 AW |
226 | (and (vhash-assoc #t db entry-matches? (hasher h)) |
227 | (let lp ((n 0)) | |
228 | (and (< n len) | |
229 | (match (vlist-ref db n) | |
230 | (('lambda . h*) | |
231 | ;; We assume that lambdas can escape and thus be | |
232 | ;; called from anywhere. Thus code inside a lambda | |
233 | ;; only has a dominating expression if it does not | |
234 | ;; depend on any effects. | |
235 | (and (not (depends-on-effects? effects &all-effects)) | |
236 | (lp (1+ n)))) | |
237 | ((#(exp* effects* ctx*) . h*) | |
238 | (log 'walk (unparse-tree-il exp) effects | |
239 | (unparse-tree-il exp*) effects* ctx*) | |
240 | (or (and (= h h*) | |
241 | (or (not ctx) (eq? ctx ctx*)) | |
1fb39dc5 | 242 | (tree-il=? exp exp*)) |
f66cbb99 AW |
243 | (and (effects-commute? effects effects*) |
244 | (lp (1+ n))))))))))) | |
245 | ||
246 | ;; Return #t if EXP is dominated by an instance of itself. In that | |
247 | ;; case, we can exclude *type-check* effects, because the first | |
248 | ;; expression already caused them if needed. | |
249 | (define (has-dominating-effect? exp effects db) | |
250 | (or (constant? effects) | |
251 | (and | |
252 | (effect-free? | |
253 | (exclude-effects effects | |
254 | (logior &zero-values | |
255 | &allocation | |
256 | &type-check))) | |
257 | (find-dominating-expression exp effects #f db)))) | |
258 | ||
259 | (define (find-dominating-test exp effects db) | |
260 | (and | |
261 | (effect-free? | |
262 | (exclude-effects effects (logior &allocation | |
263 | &type-check))) | |
264 | (match exp | |
265 | (($ <const> src val) | |
266 | (if (boolean? val) | |
267 | exp | |
268 | (make-const src (not (not val))))) | |
269 | ;; For (not FOO), try to prove FOO, then negate the result. | |
270 | (($ <application> src ($ <primitive-ref> _ 'not) (exp*)) | |
271 | (match (find-dominating-test exp* effects db) | |
272 | (($ <const> _ val) | |
273 | (log 'inferring exp (not val)) | |
274 | (make-const src (not val))) | |
275 | (_ | |
276 | #f))) | |
277 | (_ | |
278 | (cond | |
4d1ae112 | 279 | ((find-dominating-expression exp effects 'test db) |
f66cbb99 AW |
280 | ;; We have an EXP fact, so we infer #t. |
281 | (log 'inferring exp #t) | |
282 | (make-const (tree-il-src exp) #t)) | |
4d1ae112 | 283 | ((find-dominating-expression (negate exp 'test) effects 'test db) |
f66cbb99 AW |
284 | ;; We have a (not EXP) fact, so we infer #f. |
285 | (log 'inferring exp #f) | |
286 | (make-const (tree-il-src exp) #f)) | |
287 | (else | |
288 | ;; Otherwise we don't know. | |
289 | #f)))))) | |
290 | ||
291 | (define (add-to-env exp name sym db env) | |
292 | (let* ((v (vector exp name sym (vlist-length db))) | |
1fb39dc5 | 293 | (h (tree-il-hash exp))) |
f66cbb99 AW |
294 | (vhash-cons v h env (hasher h)))) |
295 | ||
296 | (define (augment-env env names syms exps db) | |
297 | (if (null? names) | |
298 | env | |
299 | (let ((name (car names)) (sym (car syms)) (exp (car exps))) | |
300 | (augment-env (if (or (assigned-lexical? sym) | |
301 | (lexical-ref? exp)) | |
302 | env | |
303 | (add-to-env exp name sym db env)) | |
304 | (cdr names) (cdr syms) (cdr exps) db)))) | |
305 | ||
306 | (define (find-dominating-lexical exp effects env db) | |
307 | (define (entry-matches? v1 v2) | |
308 | (match (if (vector? v1) v1 v2) | |
309 | (#(exp* name sym db) | |
1fb39dc5 | 310 | (tree-il=? exp exp*)) |
f66cbb99 AW |
311 | (_ #f))) |
312 | ||
73001b06 AW |
313 | (define (unroll db base n) |
314 | (or (zero? n) | |
315 | (match (vlist-ref db base) | |
f66cbb99 AW |
316 | (('lambda . h*) |
317 | ;; See note in find-dominating-expression. | |
318 | (and (not (depends-on-effects? effects &all-effects)) | |
73001b06 | 319 | (unroll db (1+ base) (1- n)))) |
f66cbb99 AW |
320 | ((#(exp* effects* ctx*) . h*) |
321 | (and (effects-commute? effects effects*) | |
73001b06 | 322 | (unroll db (1+ base) (1- n))))))) |
f66cbb99 | 323 | |
1fb39dc5 | 324 | (let ((h (tree-il-hash exp))) |
f66cbb99 AW |
325 | (and (effect-free? (exclude-effects effects &type-check)) |
326 | (vhash-assoc exp env entry-matches? (hasher h)) | |
73001b06 AW |
327 | (let ((env-len (vlist-length env)) |
328 | (db-len (vlist-length db))) | |
329 | (let lp ((n 0) (m 0)) | |
f66cbb99 AW |
330 | (and (< n env-len) |
331 | (match (vlist-ref env n) | |
332 | ((#(exp* name sym db-len*) . h*) | |
2c7b7e0f LC |
333 | (let ((niter (- (- db-len db-len*) m))) |
334 | (and (unroll db m niter) | |
335 | (if (and (= h h*) (tree-il=? exp* exp)) | |
336 | (make-lexical-ref (tree-il-src exp) name sym) | |
337 | (lp (1+ n) (- db-len db-len*))))))))))))) | |
f66cbb99 | 338 | |
63216d80 AW |
339 | (define (lookup-lexical sym env) |
340 | (let ((env-len (vlist-length env))) | |
341 | (let lp ((n 0)) | |
342 | (and (< n env-len) | |
343 | (match (vlist-ref env n) | |
344 | ((#(exp _ sym* _) . _) | |
345 | (if (eq? sym sym*) | |
346 | exp | |
347 | (lp (1+ n))))))))) | |
348 | ||
f66cbb99 AW |
349 | (define (intersection db+ db-) |
350 | (vhash-fold-right | |
351 | (lambda (k h out) | |
352 | (if (vhash-assoc k db- equal? (hasher h)) | |
353 | (vhash-cons k h out (hasher h)) | |
354 | out)) | |
355 | vlist-null | |
356 | db+)) | |
357 | ||
358 | (define (concat db1 db2) | |
359 | (vhash-fold-right (lambda (k h tail) | |
360 | (vhash-cons k h tail (hasher h))) | |
361 | db2 db1)) | |
362 | ||
363 | (let visit ((exp exp) | |
364 | (db vlist-null) ; dominating expressions: #(exp effects ctx) -> hash | |
365 | (env vlist-null) ; named expressions: #(exp name sym db) -> hash | |
366 | (ctx 'values)) ; test, effect, value, or values | |
367 | ||
368 | (define (parallel-visit exps db env ctx) | |
369 | (let lp ((in exps) (out '()) (db* vlist-null)) | |
370 | (if (pair? in) | |
371 | (call-with-values (lambda () (visit (car in) db env ctx)) | |
372 | (lambda (x db**) | |
373 | (lp (cdr in) (cons x out) (concat db** db*)))) | |
374 | (values (reverse out) db*)))) | |
375 | ||
63216d80 AW |
376 | (define (compute-effects exp) |
377 | (%compute-effects exp (lambda (sym) (lookup-lexical sym env)))) | |
378 | ||
379 | (define (bailout? exp) | |
380 | (causes-effects? (compute-effects exp) &definite-bailout)) | |
381 | ||
f66cbb99 AW |
382 | (define (return exp db*) |
383 | (let ((effects (compute-effects exp))) | |
384 | (cond | |
385 | ((and (eq? ctx 'effect) | |
386 | (not (lambda-case? exp)) | |
387 | (or (effect-free? | |
388 | (exclude-effects effects | |
389 | (logior &zero-values | |
390 | &allocation))) | |
391 | (has-dominating-effect? exp effects db))) | |
73001b06 AW |
392 | (cond |
393 | ((void? exp) | |
394 | (values exp db*)) | |
395 | (else | |
396 | (log 'elide ctx (unparse-tree-il exp)) | |
397 | (values (make-void #f) db*)))) | |
f66cbb99 AW |
398 | ((and (boolean-valued-expression? exp ctx) |
399 | (find-dominating-test exp effects db)) | |
400 | => (lambda (exp) | |
401 | (log 'propagate-test ctx (unparse-tree-il exp)) | |
402 | (values exp db*))) | |
dc1ee620 | 403 | ((and (singly-valued-expression? exp ctx) |
f66cbb99 AW |
404 | (find-dominating-lexical exp effects env db)) |
405 | => (lambda (exp) | |
406 | (log 'propagate-value ctx (unparse-tree-il exp)) | |
407 | (values exp db*))) | |
408 | ((and (constant? effects) (memq ctx '(value values))) | |
409 | ;; Adds nothing to the db. | |
410 | (values exp db*)) | |
411 | (else | |
412 | (log 'return ctx effects (unparse-tree-il exp) db*) | |
413 | (values exp | |
414 | (add-to-db exp effects ctx db*)))))) | |
415 | ||
416 | (log 'visit ctx (unparse-tree-il exp) db env) | |
417 | ||
418 | (match exp | |
419 | (($ <const>) | |
420 | (return exp vlist-null)) | |
421 | (($ <void>) | |
422 | (return exp vlist-null)) | |
423 | (($ <lexical-ref> _ _ gensym) | |
424 | (return exp vlist-null)) | |
425 | (($ <lexical-set> src name gensym exp) | |
426 | (let*-values (((exp db*) (visit exp db env 'value))) | |
427 | (return (make-lexical-set src name gensym exp) | |
428 | db*))) | |
429 | (($ <let> src names gensyms vals body) | |
430 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
431 | ((body db**) (visit body (concat db* db) | |
432 | (augment-env env names gensyms vals db) | |
433 | ctx))) | |
434 | (return (make-let src names gensyms vals body) | |
435 | (concat db** db*)))) | |
436 | (($ <letrec> src in-order? names gensyms vals body) | |
437 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
438 | ((body db**) (visit body (concat db* db) | |
439 | (augment-env env names gensyms vals db) | |
440 | ctx))) | |
441 | (return (make-letrec src in-order? names gensyms vals body) | |
442 | (concat db** db*)))) | |
443 | (($ <fix> src names gensyms vals body) | |
444 | (let*-values (((vals db*) (parallel-visit vals db env 'value)) | |
445 | ((body db**) (visit body (concat db* db) env ctx))) | |
446 | (return (make-fix src names gensyms vals body) | |
447 | (concat db** db*)))) | |
448 | (($ <let-values> src producer consumer) | |
449 | (let*-values (((producer db*) (visit producer db env 'values)) | |
450 | ((consumer db**) (visit consumer (concat db* db) env ctx))) | |
451 | (return (make-let-values src producer consumer) | |
452 | (concat db** db*)))) | |
453 | (($ <dynwind> src winder body unwinder) | |
454 | (let*-values (((pre db*) (visit winder db env 'value)) | |
455 | ((body db**) (visit body (concat db* db) env ctx)) | |
456 | ((post db***) (visit unwinder db env 'value))) | |
457 | (return (make-dynwind src pre body post) | |
458 | (concat db* (concat db** db***))))) | |
459 | (($ <dynlet> src fluids vals body) | |
460 | (let*-values (((fluids db*) (parallel-visit fluids db env 'value)) | |
461 | ((vals db**) (parallel-visit vals db env 'value)) | |
462 | ((body db***) (visit body (concat db** (concat db* db)) | |
463 | env ctx))) | |
464 | (return (make-dynlet src fluids vals body) | |
465 | (concat db*** (concat db** db*))))) | |
466 | (($ <dynref> src fluid) | |
467 | (let*-values (((fluid db*) (visit fluid db env 'value))) | |
468 | (return (make-dynref src fluid) | |
469 | db*))) | |
470 | (($ <dynset> src fluid exp) | |
471 | (let*-values (((fluid db*) (visit fluid db env 'value)) | |
472 | ((exp db**) (visit exp db env 'value))) | |
473 | (return (make-dynset src fluid exp) | |
474 | (concat db** db*)))) | |
475 | (($ <toplevel-ref>) | |
476 | (return exp vlist-null)) | |
477 | (($ <module-ref>) | |
478 | (return exp vlist-null)) | |
479 | (($ <module-set> src mod name public? exp) | |
480 | (let*-values (((exp db*) (visit exp db env 'value))) | |
481 | (return (make-module-set src mod name public? exp) | |
482 | db*))) | |
483 | (($ <toplevel-define> src name exp) | |
484 | (let*-values (((exp db*) (visit exp db env 'value))) | |
485 | (return (make-toplevel-define src name exp) | |
486 | db*))) | |
487 | (($ <toplevel-set> src name exp) | |
488 | (let*-values (((exp db*) (visit exp db env 'value))) | |
489 | (return (make-toplevel-set src name exp) | |
490 | db*))) | |
491 | (($ <primitive-ref>) | |
492 | (return exp vlist-null)) | |
493 | (($ <conditional> src test consequent alternate) | |
494 | (let*-values | |
495 | (((test db+) (visit test db env 'test)) | |
496 | ((converse db-) (visit (negate test 'test) db env 'test)) | |
497 | ((consequent db++) (visit consequent (concat db+ db) env ctx)) | |
498 | ((alternate db--) (visit alternate (concat db- db) env ctx))) | |
499 | (match (make-conditional src test consequent alternate) | |
500 | (($ <conditional> _ ($ <const> _ exp)) | |
501 | (if exp | |
502 | (return consequent (concat db++ db+)) | |
503 | (return alternate (concat db-- db-)))) | |
504 | ;; (if FOO A A) => (begin FOO A) | |
505 | (($ <conditional> src _ | |
506 | ($ <const> _ a) ($ <const> _ (? (cut equal? a <>)))) | |
507 | (visit (make-sequence #f (list test (make-const #f a))) | |
508 | db env ctx)) | |
509 | ;; (if FOO #t #f) => FOO for boolean-valued FOO. | |
510 | (($ <conditional> src | |
511 | (? (cut boolean-valued-expression? <> ctx)) | |
512 | ($ <const> _ #t) ($ <const> _ #f)) | |
513 | (return test db+)) | |
514 | ;; (if FOO #f #t) => (not FOO) | |
515 | (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t)) | |
516 | (visit (negate test ctx) db env ctx)) | |
517 | ||
518 | ;; Allow "and"-like conditions to accumulate in test context. | |
519 | ((and c ($ <conditional> _ _ _ ($ <const> _ #f))) | |
520 | (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null))) | |
521 | ((and c ($ <conditional> _ _ ($ <const> _ #f) _)) | |
522 | (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null))) | |
523 | ||
524 | ;; Conditional bailouts turn expressions into predicates. | |
525 | ((and c ($ <conditional> _ _ _ (? bailout?))) | |
526 | (return c (concat db++ db+))) | |
527 | ((and c ($ <conditional> _ _ (? bailout?) _)) | |
528 | (return c (concat db-- db-))) | |
529 | ||
530 | (c | |
531 | (return c (intersection (concat db++ db+) (concat db-- db-))))))) | |
532 | (($ <application> src proc args) | |
533 | (let*-values (((proc db*) (visit proc db env 'value)) | |
534 | ((args db**) (parallel-visit args db env 'value))) | |
535 | (return (make-application src proc args) | |
536 | (concat db** db*)))) | |
537 | (($ <lambda> src meta body) | |
538 | (let*-values (((body _) (visit body (control-flow-boundary db) | |
539 | env 'values))) | |
540 | (return (make-lambda src meta body) | |
541 | vlist-null))) | |
542 | (($ <lambda-case> src req opt rest kw inits gensyms body alt) | |
543 | (let*-values (((inits _) (parallel-visit inits db env 'value)) | |
544 | ((body db*) (visit body db env ctx)) | |
545 | ((alt _) (if alt | |
546 | (visit alt db env ctx) | |
547 | (values #f #f)))) | |
548 | (return (make-lambda-case src req opt rest kw inits gensyms body alt) | |
549 | (if alt vlist-null db*)))) | |
550 | (($ <sequence> src exps) | |
551 | (let lp ((in exps) (out '()) (db* vlist-null)) | |
552 | (match in | |
553 | ((last) | |
554 | (let*-values (((last db**) (visit last (concat db* db) env ctx))) | |
555 | (if (null? out) | |
556 | (return last (concat db** db*)) | |
557 | (return (make-sequence src (reverse (cons last out))) | |
558 | (concat db** db*))))) | |
559 | ((head . rest) | |
560 | (let*-values (((head db**) (visit head (concat db* db) env 'effect))) | |
561 | (cond | |
562 | ((sequence? head) | |
563 | (lp (append (sequence-exps head) rest) out db*)) | |
564 | ((void? head) | |
565 | (lp rest out db*)) | |
566 | (else | |
567 | (lp rest (cons head out) (concat db** db*))))))))) | |
568 | (($ <prompt> src tag body handler) | |
569 | (let*-values (((tag db*) (visit tag db env 'value)) | |
570 | ((body _) (visit body (concat db* db) env ctx)) | |
571 | ((handler _) (visit handler (concat db* db) env ctx))) | |
572 | (return (make-prompt src tag body handler) | |
573 | db*))) | |
574 | (($ <abort> src tag args tail) | |
575 | (let*-values (((tag db*) (visit tag db env 'value)) | |
576 | ((args db**) (parallel-visit args db env 'value)) | |
577 | ((tail db***) (visit tail db env 'value))) | |
578 | (return (make-abort src tag args tail) | |
579 | (concat db* (concat db** db***)))))))) |