1 ;;; Common Subexpression Elimination (CSE) on Tree-IL
3 ;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
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.
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.
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
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)
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.
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:
42 ;;; (1- (+ (if a b c) (* x y)))
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.
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.
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.
58 ;;; Duplicate predicates are not common in code that users write, but
59 ;;; can occur quite frequently in macro-generated code.
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>))
67 ;;; (throw 'not-a-foo))
69 ;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
73 ;;; A conditional bailout in effect context also has the effect of
74 ;;; adding predicates to the database:
76 ;;; (begin (foo-bar x) (foo-baz x))
78 ;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
80 ;;; (throw 'not-a-foo))
81 ;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
83 ;;; (throw 'not-a-foo)))
85 ;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
87 ;;; (throw 'not-a-foo))
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.
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.
109 ;; Logging helpers, as in peval.
111 (define-syntax *logging* (identifier-syntax #f))
112 ;; (define %logging #f)
113 ;; (define-syntax *logging* (identifier-syntax %logging))
115 (syntax-rules (quote)
116 ((log 'event arg ...)
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))
124 (pp `(log ,event . ,args))
128 ;; A pre-pass on the source program to determine the set of assigned
131 (define* (build-assigned-var-table exp #:optional (table vlist-null))
137 (($ <lexical-set> src name gensym exp)
138 (vhash-consq gensym #t res))
140 (lambda (exp res) res)
143 (define (boolean-valued-primitive? primitive)
144 (or (negate-primitive primitive)
146 (let ((chars (symbol->string primitive)))
147 (eqv? (string-ref chars (1- (string-length chars)))
150 (define (boolean-valued-expression? x ctx)
153 ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
154 (($ <const> _ (? boolean?)) #t)
155 (_ (eq? ctx 'test))))
158 "Eliminate common subexpressions in EXP."
160 (define assigned-lexical?
161 (let ((table (build-assigned-var-table exp)))
163 (vhash-assq sym table))))
165 (define compute-effects
166 (make-effects-analyzer assigned-lexical?))
168 (define (negate exp ctx)
171 (make-const src (not x)))
174 (($ <conditional> src test consequent alternate)
175 (make-conditional src test (negate consequent ctx) (negate alternate ctx)))
176 (($ <application> _ ($ <primitive-ref> _ 'not)
177 ((and x (? (cut boolean-valued-expression? <> ctx)))))
179 (($ <application> src
180 ($ <primitive-ref> _ (and pred (? negate-primitive)))
182 (make-application src
183 (make-primitive-ref #f (negate-primitive pred))
186 (make-application #f (make-primitive-ref #f 'not) (list exp)))))
189 (define (bailout? exp)
190 (causes-effects? (compute-effects exp) &definite-bailout))
192 (define (struct-nfields x)
193 (/ (string-length (symbol->string (struct-layout x))) 2))
195 (define hash-bits (logcount most-positive-fixnum))
196 (define hash-depth 4)
197 (define hash-width 3)
198 (define (hash-expression exp)
199 (define (hash-exp exp depth)
200 (define (rotate x bits)
201 (logior (ash x (- bits))
202 (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
204 (logxor h1 (rotate h2 8)))
205 (define (hash-struct s)
206 (let ((len (struct-nfields s))
207 (h (hashq (struct-vtable s) most-positive-fixnum)))
210 (let lp ((i (max (- len hash-width) 1)) (h h))
212 (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
214 (define (hash-list l)
215 (let ((h (hashq 'list most-positive-fixnum)))
218 (let lp ((l l) (width 0) (h h))
219 (if (< width hash-width)
220 (lp (cdr l) (1+ width)
221 (mix (hash-exp (car l) (1+ depth)) h))
224 ((struct? exp) (hash-struct exp))
225 ((list? exp) (hash-list exp))
226 (else (hash exp most-positive-fixnum))))
229 (define (expressions-equal? a b)
233 (eq? (struct-vtable a) (struct-vtable b))
234 ;; Assume that all structs are tree-il, so we skip over the
236 (let lp ((n (1- (struct-nfields a))))
238 (and (expressions-equal? (struct-ref a n) (struct-ref b n))
242 (expressions-equal? (car a) (car b))
243 (expressions-equal? (cdr a) (cdr b))))
248 (lambda (x size) (modulo n size)))
250 (define (add-to-db exp effects ctx db)
251 (let ((v (vector exp effects ctx))
252 (h (hash-expression exp)))
253 (vhash-cons v h db (hasher h))))
255 (define (control-flow-boundary db)
256 (let ((h (hashq 'lambda most-positive-fixnum)))
257 (vhash-cons 'lambda h db (hasher h))))
259 (define (find-dominating-expression exp effects ctx db)
260 (define (entry-matches? v1 v2)
261 (match (if (vector? v1) v1 v2)
262 (#(exp* effects* ctx*)
263 (and (expressions-equal? exp exp*)
264 (or (not ctx) (eq? ctx* ctx))))
267 (let ((len (vlist-length db))
268 (h (hash-expression exp)))
269 (and (vhash-assoc #t db entry-matches? (hasher h))
272 (match (vlist-ref db n)
274 ;; We assume that lambdas can escape and thus be
275 ;; called from anywhere. Thus code inside a lambda
276 ;; only has a dominating expression if it does not
277 ;; depend on any effects.
278 (and (not (depends-on-effects? effects &all-effects))
280 ((#(exp* effects* ctx*) . h*)
281 (log 'walk (unparse-tree-il exp) effects
282 (unparse-tree-il exp*) effects* ctx*)
284 (or (not ctx) (eq? ctx ctx*))
285 (expressions-equal? exp exp*))
286 (and (effects-commute? effects effects*)
289 ;; Return #t if EXP is dominated by an instance of itself. In that
290 ;; case, we can exclude *type-check* effects, because the first
291 ;; expression already caused them if needed.
292 (define (has-dominating-effect? exp effects db)
293 (or (constant? effects)
296 (exclude-effects effects
300 (find-dominating-expression exp effects #f db))))
302 (define (find-dominating-test exp effects db)
305 (exclude-effects effects (logior &allocation
311 (make-const src (not (not val)))))
312 ;; For (not FOO), try to prove FOO, then negate the result.
313 (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
314 (match (find-dominating-test exp* effects db)
316 (log 'inferring exp (not val))
317 (make-const src (not val)))
322 ((find-dominating-expression exp effects #f db)
323 ;; We have an EXP fact, so we infer #t.
324 (log 'inferring exp #t)
325 (make-const (tree-il-src exp) #t))
326 ((find-dominating-expression (negate exp 'test) effects #f db)
327 ;; We have a (not EXP) fact, so we infer #f.
328 (log 'inferring exp #f)
329 (make-const (tree-il-src exp) #f))
331 ;; Otherwise we don't know.
334 (define (add-to-env exp name sym db env)
335 (let* ((v (vector exp name sym (vlist-length db)))
336 (h (hash-expression exp)))
337 (vhash-cons v h env (hasher h))))
339 (define (augment-env env names syms exps db)
342 (let ((name (car names)) (sym (car syms)) (exp (car exps)))
343 (augment-env (if (or (assigned-lexical? sym)
346 (add-to-env exp name sym db env))
347 (cdr names) (cdr syms) (cdr exps) db))))
349 (define (find-dominating-lexical exp effects env db)
350 (define (entry-matches? v1 v2)
351 (match (if (vector? v1) v1 v2)
353 (expressions-equal? exp exp*))
356 (define (unroll db from to)
358 (match (vlist-ref db (1- from))
360 ;; See note in find-dominating-expression.
361 (and (not (depends-on-effects? effects &all-effects))
362 (unroll db (1- from) to)))
363 ((#(exp* effects* ctx*) . h*)
364 (and (effects-commute? effects effects*)
365 (unroll db (1- from) to))))))
367 (let ((h (hash-expression exp)))
368 (and (effect-free? (exclude-effects effects &type-check))
369 (vhash-assoc exp env entry-matches? (hasher h))
370 (let ((env-len (vlist-length env)))
371 (let lp ((n 0) (db-len (vlist-length db)))
373 (match (vlist-ref env n)
374 ((#(exp* name sym db-len*) . h*)
375 (and (unroll db db-len db-len*)
376 (if (and (= h h*) (expressions-equal? exp* exp))
377 (make-lexical-ref (tree-il-src exp) name sym)
378 (lp (1+ n) db-len*)))))))))))
380 (define (intersection db+ db-)
383 (if (vhash-assoc k db- equal? (hasher h))
384 (vhash-cons k h out (hasher h))
389 (define (concat db1 db2)
390 (vhash-fold-right (lambda (k h tail)
391 (vhash-cons k h tail (hasher h)))
394 (let visit ((exp exp)
395 (db vlist-null) ; dominating expressions: #(exp effects ctx) -> hash
396 (env vlist-null) ; named expressions: #(exp name sym db) -> hash
397 (ctx 'values)) ; test, effect, value, or values
399 (define (parallel-visit exps db env ctx)
400 (let lp ((in exps) (out '()) (db* vlist-null))
402 (call-with-values (lambda () (visit (car in) db env ctx))
404 (lp (cdr in) (cons x out) (concat db** db*))))
405 (values (reverse out) db*))))
407 (define (return exp db*)
408 (let ((effects (compute-effects exp)))
410 ((and (eq? ctx 'effect)
411 (not (lambda-case? exp))
413 (exclude-effects effects
416 (has-dominating-effect? exp effects db)))
417 (log 'elide ctx (unparse-tree-il exp))
418 (values (make-void #f) db*))
419 ((and (boolean-valued-expression? exp ctx)
420 (find-dominating-test exp effects db))
422 (log 'propagate-test ctx (unparse-tree-il exp))
424 ((and (eq? ctx 'value)
425 (find-dominating-lexical exp effects env db))
427 (log 'propagate-value ctx (unparse-tree-il exp))
429 ((and (constant? effects) (memq ctx '(value values)))
430 ;; Adds nothing to the db.
433 (log 'return ctx effects (unparse-tree-il exp) db*)
435 (add-to-db exp effects ctx db*))))))
437 (log 'visit ctx (unparse-tree-il exp) db env)
441 (return exp vlist-null))
443 (return exp vlist-null))
444 (($ <lexical-ref> _ _ gensym)
445 (return exp vlist-null))
446 (($ <lexical-set> src name gensym exp)
447 (let*-values (((exp db*) (visit exp db env 'value)))
448 (return (make-lexical-set src name gensym exp)
450 (($ <let> src names gensyms vals body)
451 (let*-values (((vals db*) (parallel-visit vals db env 'value))
452 ((body db**) (visit body (concat db* db)
453 (augment-env env names gensyms vals db)
455 (return (make-let src names gensyms vals body)
457 (($ <letrec> src in-order? names gensyms vals body)
458 (let*-values (((vals db*) (parallel-visit vals db env 'value))
459 ((body db**) (visit body (concat db* db)
460 (augment-env env names gensyms vals db)
462 (return (make-letrec src in-order? names gensyms vals body)
464 (($ <fix> src names gensyms vals body)
465 (let*-values (((vals db*) (parallel-visit vals db env 'value))
466 ((body db**) (visit body (concat db* db) env ctx)))
467 (return (make-fix src names gensyms vals body)
469 (($ <let-values> src producer consumer)
470 (let*-values (((producer db*) (visit producer db env 'values))
471 ((consumer db**) (visit consumer (concat db* db) env ctx)))
472 (return (make-let-values src producer consumer)
474 (($ <dynwind> src winder body unwinder)
475 (let*-values (((pre db*) (visit winder db env 'value))
476 ((body db**) (visit body (concat db* db) env ctx))
477 ((post db***) (visit unwinder db env 'value)))
478 (return (make-dynwind src pre body post)
479 (concat db* (concat db** db***)))))
480 (($ <dynlet> src fluids vals body)
481 (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
482 ((vals db**) (parallel-visit vals db env 'value))
483 ((body db***) (visit body (concat db** (concat db* db))
485 (return (make-dynlet src fluids vals body)
486 (concat db*** (concat db** db*)))))
487 (($ <dynref> src fluid)
488 (let*-values (((fluid db*) (visit fluid db env 'value)))
489 (return (make-dynref src fluid)
491 (($ <dynset> src fluid exp)
492 (let*-values (((fluid db*) (visit fluid db env 'value))
493 ((exp db**) (visit exp db env 'value)))
494 (return (make-dynset src fluid exp)
497 (return exp vlist-null))
499 (return exp vlist-null))
500 (($ <module-set> src mod name public? exp)
501 (let*-values (((exp db*) (visit exp db env 'value)))
502 (return (make-module-set src mod name public? exp)
504 (($ <toplevel-define> src name exp)
505 (let*-values (((exp db*) (visit exp db env 'value)))
506 (return (make-toplevel-define src name exp)
508 (($ <toplevel-set> src name exp)
509 (let*-values (((exp db*) (visit exp db env 'value)))
510 (return (make-toplevel-set src name exp)
513 (return exp vlist-null))
514 (($ <conditional> src test consequent alternate)
516 (((test db+) (visit test db env 'test))
517 ((converse db-) (visit (negate test 'test) db env 'test))
518 ((consequent db++) (visit consequent (concat db+ db) env ctx))
519 ((alternate db--) (visit alternate (concat db- db) env ctx)))
520 (match (make-conditional src test consequent alternate)
521 (($ <conditional> _ ($ <const> _ exp))
523 (return consequent (concat db++ db+))
524 (return alternate (concat db-- db-))))
525 ;; (if FOO A A) => (begin FOO A)
526 (($ <conditional> src _
527 ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
528 (visit (make-sequence #f (list test (make-const #f a)))
530 ;; (if FOO #t #f) => FOO for boolean-valued FOO.
531 (($ <conditional> src
532 (? (cut boolean-valued-expression? <> ctx))
533 ($ <const> _ #t) ($ <const> _ #f))
535 ;; (if FOO #f #t) => (not FOO)
536 (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t))
537 (visit (negate test ctx) db env ctx))
539 ;; Allow "and"-like conditions to accumulate in test context.
540 ((and c ($ <conditional> _ _ _ ($ <const> _ #f)))
541 (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null)))
542 ((and c ($ <conditional> _ _ ($ <const> _ #f) _))
543 (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null)))
545 ;; Conditional bailouts turn expressions into predicates.
546 ((and c ($ <conditional> _ _ _ (? bailout?)))
547 (return c (concat db++ db+)))
548 ((and c ($ <conditional> _ _ (? bailout?) _))
549 (return c (concat db-- db-)))
552 (return c (intersection (concat db++ db+) (concat db-- db-)))))))
553 (($ <application> src proc args)
554 (let*-values (((proc db*) (visit proc db env 'value))
555 ((args db**) (parallel-visit args db env 'value)))
556 (return (make-application src proc args)
558 (($ <lambda> src meta body)
559 (let*-values (((body _) (visit body (control-flow-boundary db)
561 (return (make-lambda src meta body)
563 (($ <lambda-case> src req opt rest kw inits gensyms body alt)
564 (let*-values (((inits _) (parallel-visit inits db env 'value))
565 ((body db*) (visit body db env ctx))
567 (visit alt db env ctx)
569 (return (make-lambda-case src req opt rest kw inits gensyms body alt)
570 (if alt vlist-null db*))))
571 (($ <sequence> src exps)
572 (let lp ((in exps) (out '()) (db* vlist-null))
575 (let*-values (((last db**) (visit last (concat db* db) env ctx)))
577 (return last (concat db** db*))
578 (return (make-sequence src (reverse (cons last out)))
579 (concat db** db*)))))
581 (let*-values (((head db**) (visit head (concat db* db) env 'effect)))
584 (lp (append (sequence-exps head) rest) out db*))
588 (lp rest (cons head out) (concat db** db*)))))))))
589 (($ <prompt> src tag body handler)
590 (let*-values (((tag db*) (visit tag db env 'value))
591 ((body _) (visit body (concat db* db) env ctx))
592 ((handler _) (visit handler (concat db* db) env ctx)))
593 (return (make-prompt src tag body handler)
595 (($ <abort> src tag args tail)
596 (let*-values (((tag db*) (visit tag db env 'value))
597 ((args db**) (parallel-visit args db env 'value))
598 ((tail db***) (visit tail db env 'value)))
599 (return (make-abort src tag args tail)
600 (concat db* (concat db** db***))))))))