| 1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
| 2 | |
| 3 | ;; Copyright (C) 2013, 2014 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 | ;;; Commentary: |
| 20 | ;;; |
| 21 | ;;; Common subexpression elimination for CPS. |
| 22 | ;;; |
| 23 | ;;; Code: |
| 24 | |
| 25 | (define-module (language cps cse) |
| 26 | #:use-module (ice-9 match) |
| 27 | #:use-module (srfi srfi-1) |
| 28 | #:use-module (language cps) |
| 29 | #:use-module (language cps dfg) |
| 30 | #:use-module (language cps effects-analysis) |
| 31 | #:use-module (language cps renumber) |
| 32 | #:export (eliminate-common-subexpressions)) |
| 33 | |
| 34 | (define (compute-always-available-expressions effects) |
| 35 | "Return the set of continuations whose values are always available |
| 36 | within their dominance frontier. This is the case for effects that have |
| 37 | no dependencies and which cause no effects besides &type-check." |
| 38 | (let ((out (make-bitvector (vector-length effects) #f))) |
| 39 | (let lp ((n 0)) |
| 40 | (cond |
| 41 | ((< n (vector-length effects)) |
| 42 | (when (zero? (exclude-effects (vector-ref effects n) &type-check)) |
| 43 | (bitvector-set! out n #t)) |
| 44 | (lp (1+ n))) |
| 45 | (else out))))) |
| 46 | |
| 47 | (define (compute-available-expressions dfg min-label label-count) |
| 48 | "Compute and return the continuations that may be reached if flow |
| 49 | reaches a continuation N. Returns a vector of bitvectors, whose first |
| 50 | index corresponds to MIN-LABEL, and so on." |
| 51 | (let* ((effects (compute-effects dfg min-label label-count)) |
| 52 | (always-avail (compute-always-available-expressions effects)) |
| 53 | ;; Vector of bitvectors, indicating that at a continuation N, |
| 54 | ;; the values from continuations M... are available. |
| 55 | (avail-in (make-vector label-count #f)) |
| 56 | (avail-out (make-vector label-count #f))) |
| 57 | |
| 58 | (define (label->idx label) (- label min-label)) |
| 59 | (define (idx->label idx) (+ idx min-label)) |
| 60 | |
| 61 | (let lp ((n 0)) |
| 62 | (when (< n label-count) |
| 63 | (let ((in (make-bitvector label-count #f)) |
| 64 | (out (make-bitvector label-count #f))) |
| 65 | (vector-set! avail-in n in) |
| 66 | (vector-set! avail-out n out) |
| 67 | (lp (1+ n))))) |
| 68 | |
| 69 | (let ((tmp (make-bitvector label-count #f))) |
| 70 | (define (bitvector-copy! dst src) |
| 71 | (bitvector-fill! dst #f) |
| 72 | (bit-set*! dst src #t)) |
| 73 | (define (intersect! dst src) |
| 74 | (bitvector-copy! tmp src) |
| 75 | (bit-invert! tmp) |
| 76 | (bit-set*! dst tmp #f)) |
| 77 | (let lp ((n 0) (first? #t) (changed? #f)) |
| 78 | (cond |
| 79 | ((< n label-count) |
| 80 | (let* ((in (vector-ref avail-in n)) |
| 81 | (prev-count (bit-count #t in)) |
| 82 | (out (vector-ref avail-out n)) |
| 83 | (fx (vector-ref effects n))) |
| 84 | ;; Intersect avail-out from predecessors into "in". |
| 85 | (let lp ((preds (lookup-predecessors (idx->label n) dfg)) |
| 86 | (initialized? #f)) |
| 87 | (match preds |
| 88 | (() #t) |
| 89 | ((pred . preds) |
| 90 | (let ((pred (label->idx pred))) |
| 91 | (cond |
| 92 | ((and first? (<= n pred)) |
| 93 | ;; Avoid intersecting back-edges and cross-edges on |
| 94 | ;; the first iteration. |
| 95 | (lp preds initialized?)) |
| 96 | (else |
| 97 | (if initialized? |
| 98 | (intersect! in (vector-ref avail-out pred)) |
| 99 | (bitvector-copy! in (vector-ref avail-out pred))) |
| 100 | (lp preds #t))))))) |
| 101 | (let ((new-count (bit-count #t in))) |
| 102 | (unless (= prev-count new-count) |
| 103 | ;; Copy "in" to "out". |
| 104 | (bitvector-copy! out in) |
| 105 | ;; Kill expressions that don't commute. |
| 106 | (cond |
| 107 | ((causes-all-effects? fx &all-effects) |
| 108 | ;; Fast-path if this expression clobbers the world. |
| 109 | (intersect! out always-avail)) |
| 110 | ((effect-free? (exclude-effects fx &type-check)) |
| 111 | ;; Fast-path if this expression clobbers nothing. |
| 112 | #t) |
| 113 | (else |
| 114 | ;; Loop of sadness. |
| 115 | (bitvector-copy! tmp out) |
| 116 | (bit-set*! tmp always-avail #f) |
| 117 | (let lp ((i 0)) |
| 118 | (let ((i (bit-position #t tmp i))) |
| 119 | (when i |
| 120 | (unless (effects-commute? (vector-ref effects i) fx) |
| 121 | (bitvector-set! out i #f)) |
| 122 | (lp (1+ i)))))))) |
| 123 | ;; Unless this expression allocates a fresh object or |
| 124 | ;; changes the current fluid environment, mark expressions |
| 125 | ;; that match it as available for elimination. |
| 126 | (unless (causes-effects? fx (logior &fluid-environment |
| 127 | &allocation)) |
| 128 | (bitvector-set! out n #t)) |
| 129 | (lp (1+ n) first? (or changed? (not (= prev-count new-count))))))) |
| 130 | (else |
| 131 | (if (or first? changed?) |
| 132 | (lp 0 #f #f) |
| 133 | avail-in))))))) |
| 134 | |
| 135 | (define (compute-truthy-expressions dfg min-label label-count) |
| 136 | "Compute a \"truth map\", indicating which expressions can be shown to |
| 137 | be true and/or false at each of LABEL-COUNT expressions in DFG, starting |
| 138 | from MIN-LABEL. Returns a vector of bitvectors, each bitvector twice as |
| 139 | long as LABEL-COUNT. The first half of the bitvector indicates labels |
| 140 | that may be true, and the second half those that may be false. It could |
| 141 | be that both true and false proofs are available." |
| 142 | (let ((boolv (make-vector label-count #f))) |
| 143 | (define (label->idx label) (- label min-label)) |
| 144 | (define (idx->label idx) (+ idx min-label)) |
| 145 | (define (true-idx idx) idx) |
| 146 | (define (false-idx idx) (+ idx label-count)) |
| 147 | |
| 148 | (let lp ((n 0)) |
| 149 | (when (< n label-count) |
| 150 | (let ((bool (make-bitvector (* label-count 2) #f))) |
| 151 | (vector-set! boolv n bool) |
| 152 | (lp (1+ n))))) |
| 153 | |
| 154 | (let ((tmp (make-bitvector (* label-count 2) #f))) |
| 155 | (define (bitvector-copy! dst src) |
| 156 | (bitvector-fill! dst #f) |
| 157 | (bit-set*! dst src #t)) |
| 158 | (define (intersect! dst src) |
| 159 | (bitvector-copy! tmp src) |
| 160 | (bit-invert! tmp) |
| 161 | (bit-set*! dst tmp #f)) |
| 162 | (let lp ((n 0) (first? #t) (changed? #f)) |
| 163 | (cond |
| 164 | ((< n label-count) |
| 165 | (let* ((label (idx->label n)) |
| 166 | (bool (vector-ref boolv n)) |
| 167 | (prev-count (bit-count #t bool))) |
| 168 | ;; Intersect truthiness from all predecessors. |
| 169 | (let lp ((preds (lookup-predecessors label dfg)) |
| 170 | (initialized? #f)) |
| 171 | (match preds |
| 172 | (() #t) |
| 173 | ((pred . preds) |
| 174 | (let ((pidx (label->idx pred))) |
| 175 | (cond |
| 176 | ((and first? (<= n pidx)) |
| 177 | ;; Avoid intersecting back-edges and cross-edges on |
| 178 | ;; the first iteration. |
| 179 | (lp preds initialized?)) |
| 180 | (else |
| 181 | (if initialized? |
| 182 | (intersect! bool (vector-ref boolv pidx)) |
| 183 | (bitvector-copy! bool (vector-ref boolv pidx))) |
| 184 | (match (lookup-predecessors pred dfg) |
| 185 | ((test) |
| 186 | (let ((tidx (label->idx test))) |
| 187 | (match (lookup-cont pred dfg) |
| 188 | (($ $kif kt kf) |
| 189 | (when (eqv? kt label) |
| 190 | (bitvector-set! bool (true-idx tidx) #t)) |
| 191 | (when (eqv? kf label) |
| 192 | (bitvector-set! bool (false-idx tidx) #t))) |
| 193 | (_ #t)))) |
| 194 | (_ #t)) |
| 195 | (lp preds #t))))))) |
| 196 | (lp (1+ n) first? |
| 197 | (or changed? |
| 198 | (not (= prev-count (bit-count #t bool))))))) |
| 199 | (else |
| 200 | (if (or first? changed?) |
| 201 | (lp 0 #f #f) |
| 202 | boolv))))))) |
| 203 | |
| 204 | (define (compute-defs dfg min-label label-count) |
| 205 | (define (cont-defs k) |
| 206 | (match (lookup-cont k dfg) |
| 207 | (($ $kargs names vars) vars) |
| 208 | (_ '()))) |
| 209 | (define (idx->label idx) (+ idx min-label)) |
| 210 | (let ((defs (make-vector label-count '()))) |
| 211 | (let lp ((n 0)) |
| 212 | (when (< n label-count) |
| 213 | (vector-set! |
| 214 | defs |
| 215 | n |
| 216 | (match (lookup-cont (idx->label n) dfg) |
| 217 | (($ $kargs _ _ body) |
| 218 | (match (find-call body) |
| 219 | (($ $continue k) (cont-defs k)))) |
| 220 | (($ $kreceive arity kargs) |
| 221 | (cont-defs kargs)) |
| 222 | (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) |
| 223 | syms) |
| 224 | (($ $kif) '()) |
| 225 | (($ $kfun src meta self) (list self)) |
| 226 | (($ $ktail) '()))) |
| 227 | (lp (1+ n)))) |
| 228 | defs)) |
| 229 | |
| 230 | (define (compute-label-and-var-ranges fun) |
| 231 | (match fun |
| 232 | (($ $cont kfun ($ $kfun src meta self)) |
| 233 | ((make-local-cont-folder min-label label-count min-var var-count) |
| 234 | (lambda (k cont min-label label-count min-var var-count) |
| 235 | (let ((min-label (min k min-label)) |
| 236 | (label-count (1+ label-count))) |
| 237 | (match cont |
| 238 | (($ $kargs names vars body) |
| 239 | (let lp ((body body) |
| 240 | (min-var (fold min min-var vars)) |
| 241 | (var-count (+ var-count (length vars)))) |
| 242 | (match body |
| 243 | (($ $letrec names vars funs body) |
| 244 | (lp body |
| 245 | (fold min min-var vars) |
| 246 | (+ var-count (length vars)))) |
| 247 | (($ $letk conts body) (lp body min-var var-count)) |
| 248 | (_ (values min-label label-count min-var var-count))))) |
| 249 | (($ $kfun src meta self) |
| 250 | (values min-label label-count (min self min-var) (1+ var-count))) |
| 251 | (_ |
| 252 | (values min-label label-count min-var var-count))))) |
| 253 | fun kfun 0 self 0)))) |
| 254 | |
| 255 | (define (compute-idoms dfg min-label label-count) |
| 256 | (define (label->idx label) (- label min-label)) |
| 257 | (define (idx->label idx) (+ idx min-label)) |
| 258 | (let ((idoms (make-vector label-count #f))) |
| 259 | (define (common-idom d0 d1) |
| 260 | ;; We exploit the fact that a reverse post-order is a topological |
| 261 | ;; sort, and so the idom of a node is always numerically less than |
| 262 | ;; the node itself. |
| 263 | (cond |
| 264 | ((= d0 d1) d0) |
| 265 | ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1)))) |
| 266 | (else (common-idom (vector-ref idoms (label->idx d0)) d1)))) |
| 267 | (define (compute-idom preds) |
| 268 | (define (has-idom? pred) |
| 269 | (vector-ref idoms (label->idx pred))) |
| 270 | (match preds |
| 271 | (() min-label) |
| 272 | ((pred . preds) |
| 273 | (if (has-idom? pred) |
| 274 | (let lp ((idom pred) (preds preds)) |
| 275 | (match preds |
| 276 | (() idom) |
| 277 | ((pred . preds) |
| 278 | (lp (if (has-idom? pred) |
| 279 | (common-idom idom pred) |
| 280 | idom) |
| 281 | preds)))) |
| 282 | (compute-idom preds))))) |
| 283 | ;; This is the iterative O(n^2) fixpoint algorithm, originally from |
| 284 | ;; Allen and Cocke ("Graph-theoretic constructs for program flow |
| 285 | ;; analysis", 1972). See the discussion in Cooper, Harvey, and |
| 286 | ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. |
| 287 | (let iterate ((n 0) (changed? #f)) |
| 288 | (cond |
| 289 | ((< n label-count) |
| 290 | (let ((idom (vector-ref idoms n)) |
| 291 | (idom* (compute-idom (lookup-predecessors (idx->label n) dfg)))) |
| 292 | (cond |
| 293 | ((eqv? idom idom*) |
| 294 | (iterate (1+ n) changed?)) |
| 295 | (else |
| 296 | (vector-set! idoms n idom*) |
| 297 | (iterate (1+ n) #t))))) |
| 298 | (changed? |
| 299 | (iterate 0 #f)) |
| 300 | (else idoms))))) |
| 301 | |
| 302 | ;; Compute a vector containing, for each node, a list of the nodes that |
| 303 | ;; it immediately dominates. These are the "D" edges in the DJ tree. |
| 304 | (define (compute-dom-edges idoms min-label) |
| 305 | (define (label->idx label) (- label min-label)) |
| 306 | (define (idx->label idx) (+ idx min-label)) |
| 307 | (define (vector-push! vec idx val) |
| 308 | (let ((v vec) (i idx)) |
| 309 | (vector-set! v i (cons val (vector-ref v i))))) |
| 310 | (let ((doms (make-vector (vector-length idoms) '()))) |
| 311 | (let lp ((n 0)) |
| 312 | (when (< n (vector-length idoms)) |
| 313 | (let ((idom (vector-ref idoms n))) |
| 314 | (vector-push! doms (label->idx idom) (idx->label n))) |
| 315 | (lp (1+ n)))) |
| 316 | doms)) |
| 317 | |
| 318 | (define (compute-equivalent-subexpressions fun dfg) |
| 319 | (define (compute min-label label-count min-var var-count) |
| 320 | (let ((avail (compute-available-expressions dfg min-label label-count)) |
| 321 | (idoms (compute-idoms dfg min-label label-count)) |
| 322 | (defs (compute-defs dfg min-label label-count)) |
| 323 | (var-substs (make-vector var-count #f)) |
| 324 | (equiv-labels (make-vector label-count #f)) |
| 325 | (equiv-set (make-hash-table))) |
| 326 | (define (idx->label idx) (+ idx min-label)) |
| 327 | (define (label->idx label) (- label min-label)) |
| 328 | (define (idx->var idx) (+ idx min-var)) |
| 329 | (define (var->idx var) (- var min-var)) |
| 330 | |
| 331 | (define (for-each/2 f l1 l2) |
| 332 | (unless (= (length l1) (length l2)) |
| 333 | (error "bad lengths" l1 l2)) |
| 334 | (let lp ((l1 l1) (l2 l2)) |
| 335 | (when (pair? l1) |
| 336 | (f (car l1) (car l2)) |
| 337 | (lp (cdr l1) (cdr l2))))) |
| 338 | |
| 339 | (define (subst-var var) |
| 340 | ;; It could be that the var is free in this function; if so, its |
| 341 | ;; name will be less than min-var. |
| 342 | (let ((idx (var->idx var))) |
| 343 | (if (<= 0 idx) |
| 344 | (vector-ref var-substs idx) |
| 345 | var))) |
| 346 | |
| 347 | (define (compute-exp-key exp) |
| 348 | (match exp |
| 349 | (($ $void) 'void) |
| 350 | (($ $const val) (cons 'const val)) |
| 351 | (($ $prim name) (cons 'prim name)) |
| 352 | (($ $fun free body) #f) |
| 353 | (($ $call proc args) #f) |
| 354 | (($ $callk k proc args) #f) |
| 355 | (($ $primcall name args) |
| 356 | (cons* 'primcall name (map subst-var args))) |
| 357 | (($ $values args) #f) |
| 358 | (($ $prompt escape? tag handler) #f))) |
| 359 | |
| 360 | ;; The initial substs vector is the identity map. |
| 361 | (let lp ((var min-var)) |
| 362 | (when (< (var->idx var) var-count) |
| 363 | (vector-set! var-substs (var->idx var) var) |
| 364 | (lp (1+ var)))) |
| 365 | |
| 366 | ;; Traverse the labels in fun in forward order, which will visit |
| 367 | ;; dominators first. |
| 368 | (let lp ((label min-label)) |
| 369 | (when (< (label->idx label) label-count) |
| 370 | (match (lookup-cont label dfg) |
| 371 | (($ $kargs names vars body) |
| 372 | (match (find-call body) |
| 373 | (($ $continue k src exp) |
| 374 | (let* ((exp-key (compute-exp-key exp)) |
| 375 | (equiv (hash-ref equiv-set exp-key '())) |
| 376 | (avail (vector-ref avail (label->idx label)))) |
| 377 | (let lp ((candidates equiv)) |
| 378 | (match candidates |
| 379 | (() |
| 380 | ;; No matching expressions. Add our expression |
| 381 | ;; to the equivalence set, if appropriate. |
| 382 | (when exp-key |
| 383 | (hash-set! equiv-set exp-key (cons label equiv)))) |
| 384 | ((candidate . candidates) |
| 385 | (cond |
| 386 | ((not (bitvector-ref avail (label->idx candidate))) |
| 387 | ;; This expression isn't available here; try |
| 388 | ;; the next one. |
| 389 | (lp candidates)) |
| 390 | (else |
| 391 | ;; Yay, a match. Mark expression as equivalent. |
| 392 | (vector-set! equiv-labels (label->idx label) |
| 393 | candidate) |
| 394 | ;; If we dominate the successor, mark vars |
| 395 | ;; for substitution. |
| 396 | (when (= label (vector-ref idoms (label->idx k))) |
| 397 | (for-each/2 |
| 398 | (lambda (var subst-var) |
| 399 | (vector-set! var-substs (var->idx var) subst-var)) |
| 400 | (vector-ref defs (label->idx label)) |
| 401 | (vector-ref defs (label->idx candidate))))))))))))) |
| 402 | (_ #f)) |
| 403 | (lp (1+ label)))) |
| 404 | (values (compute-dom-edges idoms min-label) |
| 405 | equiv-labels defs min-label var-substs min-var))) |
| 406 | |
| 407 | (call-with-values (lambda () (compute-label-and-var-ranges fun)) compute)) |
| 408 | |
| 409 | (define (apply-cse fun dfg |
| 410 | doms equiv-labels defs min-label var-substs min-var boolv) |
| 411 | (define (idx->label idx) (+ idx min-label)) |
| 412 | (define (label->idx label) (- label min-label)) |
| 413 | (define (idx->var idx) (+ idx min-var)) |
| 414 | (define (var->idx var) (- var min-var)) |
| 415 | (define (true-idx idx) idx) |
| 416 | (define (false-idx idx) (+ idx (vector-length equiv-labels))) |
| 417 | |
| 418 | (define (subst-var var) |
| 419 | ;; It could be that the var is free in this function; if so, |
| 420 | ;; its name will be less than min-var. |
| 421 | (let ((idx (var->idx var))) |
| 422 | (if (<= 0 idx) |
| 423 | (vector-ref var-substs idx) |
| 424 | var))) |
| 425 | |
| 426 | (define (visit-fun-cont cont) |
| 427 | (rewrite-cps-cont cont |
| 428 | (($ $cont label ($ $kargs names vars body)) |
| 429 | (label ($kargs names vars ,(visit-term body label)))) |
| 430 | (($ $cont label ($ $kfun src meta self tail clause)) |
| 431 | (label ($kfun src meta self ,tail |
| 432 | ,(and clause (visit-fun-cont clause))))) |
| 433 | (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) |
| 434 | (label ($kclause ,arity ,(visit-cont kbody body) |
| 435 | ,(and alternate (visit-fun-cont alternate))))))) |
| 436 | |
| 437 | (define (visit-cont label cont) |
| 438 | (rewrite-cps-cont cont |
| 439 | (($ $kargs names vars body) |
| 440 | (label ($kargs names vars ,(visit-term body label)))) |
| 441 | (_ (label ,cont)))) |
| 442 | |
| 443 | (define (visit-term term label) |
| 444 | (define (visit-exp exp) |
| 445 | ;; We shouldn't see $fun here. |
| 446 | (rewrite-cps-exp exp |
| 447 | ((or ($ $void) ($ $const) ($ $prim)) ,exp) |
| 448 | (($ $call proc args) |
| 449 | ($call (subst-var proc) ,(map subst-var args))) |
| 450 | (($ $callk k proc args) |
| 451 | ($callk k (subst-var proc) ,(map subst-var args))) |
| 452 | (($ $primcall name args) |
| 453 | ($primcall name ,(map subst-var args))) |
| 454 | (($ $values args) |
| 455 | ($values ,(map subst-var args))) |
| 456 | (($ $prompt escape? tag handler) |
| 457 | ($prompt escape? (subst-var tag) handler)))) |
| 458 | |
| 459 | (define (visit-exp* k src exp) |
| 460 | (match exp |
| 461 | (($ $fun free body) |
| 462 | (build-cps-term |
| 463 | ($continue k src |
| 464 | ($fun (map subst-var free) ,(cse body dfg))))) |
| 465 | (_ |
| 466 | (cond |
| 467 | ((vector-ref equiv-labels (label->idx label)) |
| 468 | => (lambda (equiv) |
| 469 | (let* ((eidx (label->idx equiv)) |
| 470 | (vars (vector-ref defs eidx))) |
| 471 | (rewrite-cps-term (lookup-cont k dfg) |
| 472 | (($ $kif kt kf) |
| 473 | ,(let* ((bool (vector-ref boolv (label->idx label))) |
| 474 | (t (bitvector-ref bool (true-idx eidx))) |
| 475 | (f (bitvector-ref bool (false-idx eidx)))) |
| 476 | (if (eqv? t f) |
| 477 | (build-cps-term |
| 478 | ($continue k src ,(visit-exp exp))) |
| 479 | (build-cps-term |
| 480 | ($continue (if t kt kf) src ($values ())))))) |
| 481 | (($ $kargs) |
| 482 | ($continue k src ($values vars))) |
| 483 | ;; There is no point in adding a case for $ktail, as |
| 484 | ;; only $values, $call, or $callk can continue to |
| 485 | ;; $ktail. |
| 486 | (_ |
| 487 | ($continue k src ,(visit-exp exp))))))) |
| 488 | (else |
| 489 | (build-cps-term |
| 490 | ($continue k src ,(visit-exp exp)))))))) |
| 491 | |
| 492 | (define (visit-dom-conts label) |
| 493 | (let ((cont (lookup-cont label dfg))) |
| 494 | (match cont |
| 495 | (($ $ktail) '()) |
| 496 | (($ $kargs) (list (visit-cont label cont))) |
| 497 | (else |
| 498 | (cons (visit-cont label cont) |
| 499 | (append-map visit-dom-conts |
| 500 | (vector-ref doms (label->idx label)))))))) |
| 501 | |
| 502 | (rewrite-cps-term term |
| 503 | (($ $letk conts body) |
| 504 | ,(visit-term body label)) |
| 505 | (($ $letrec names syms funs body) |
| 506 | ($letrec names syms |
| 507 | (map (lambda (fun) |
| 508 | (rewrite-cps-exp fun |
| 509 | (($ $fun free body) |
| 510 | ($fun (map subst-var free) ,(cse body dfg))))) |
| 511 | funs) |
| 512 | ,(visit-term body label))) |
| 513 | (($ $continue k src exp) |
| 514 | ,(let ((conts (append-map visit-dom-conts |
| 515 | (vector-ref doms (label->idx label))))) |
| 516 | (if (null? conts) |
| 517 | (visit-exp* k src exp) |
| 518 | (build-cps-term |
| 519 | ($letk ,conts ,(visit-exp* k src exp)))))))) |
| 520 | |
| 521 | (visit-fun-cont fun)) |
| 522 | |
| 523 | (define (cse fun dfg) |
| 524 | (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg)) |
| 525 | (lambda (doms equiv-labels defs min-label var-substs min-var) |
| 526 | (apply-cse fun dfg doms equiv-labels defs min-label var-substs min-var |
| 527 | (compute-truthy-expressions dfg |
| 528 | min-label (vector-length doms)))))) |
| 529 | |
| 530 | (define (eliminate-common-subexpressions fun) |
| 531 | (call-with-values (lambda () (renumber fun)) |
| 532 | (lambda (fun nlabels nvars) |
| 533 | (cse fun (compute-dfg fun))))) |