[bpt/guile.git] / module / language / cps / simplify.scm

;;; Continuation-passing style (CPS) intermediate language (IL)

;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; The fundamental lambda calculus reductions, like beta and eta
;;; reduction and so on.  Pretty lame currently.
;;;
;;; Code:

(define-module (language cps simplify)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (language cps)
  #:use-module (language cps dfg)
  #:use-module (language cps renumber)
  #:export (simplify))

(define (compute-eta-reductions fun)
  (let ((table (make-hash-table)))
    (define (visit-cont cont)
      (match cont
        (($ $cont sym ($ $kargs names syms body))
         (visit-term body sym syms))
        (($ $cont sym ($ $kfun src meta self tail clause))
         (when clause (visit-cont clause)))
        (($ $cont sym ($ $kclause arity body alternate))
         (visit-cont body)
         (when alternate (visit-cont alternate)))
        (($ $cont sym _) #f)))
    (define (visit-term term term-k term-args)
      (match term
        (($ $letk conts body)
         (for-each visit-cont conts)
         (visit-term body term-k term-args))
        (($ $letrec names syms funs body)
         (for-each visit-fun funs)
         (visit-term body term-k term-args))
        (($ $continue k src ($ $values args))
         (when (and (equal? term-args args) (not (eq? k term-k)))
           (hashq-set! table term-k k)))
        (($ $continue k src (and fun ($ $fun)))
         (visit-fun fun))
        (($ $continue k src _)
         #f)))
    (define (visit-fun fun)
      (match fun
        (($ $fun free body)
         (visit-cont body))))
    (visit-cont fun)
    table))

(define (eta-reduce fun)
  (let ((table (compute-eta-reductions fun))
        (dfg (compute-dfg fun)))
    (define (reduce* k scope values?)
      (match (hashq-ref table k)
        (#f k)
        (k* 
         (if (and (continuation-bound-in? k* scope dfg)
                  (or values?
                      (match (lookup-cont k* dfg)
                        (($ $kargs) #t)
                        (_ #f))))
             (reduce* k* scope values?)
             k))))
    (define (reduce k scope)
      (reduce* k scope #f))
    (define (reduce-values k scope)
      (reduce* k scope #t))
    (define (reduce-const k src scope const)
      (let lp ((k k) (seen '()) (const const))
        (match (lookup-cont k dfg)
          (($ $kargs (_) (arg) term)
           (match (find-call term)
             (($ $continue k* src* ($ $values (arg*)))
              (and (eqv? arg arg*)
                   (not (memq k* seen))
                   (lp k* (cons k seen) const)))
             (($ $continue k* src* ($ $primcall 'not (arg*)))
              (and (eqv? arg arg*)
                   (not (memq k* seen))
                   (lp k* (cons k seen) (not const))))
             (($ $continue k* src* ($ $branch kt ($ $values (arg*))))
              (and (eqv? arg arg*)
                   (let ((k* (if const kt k*)))
                     (and (continuation-bound-in? k* scope dfg)
                          (build-cps-term
                            ($continue k* src ($values ())))))))
             (_
              (and (continuation-bound-in? k scope dfg)
                   (build-cps-term
                     ($continue k src ($const const)))))))
          (_ #f))))
    (define (visit-cont cont scope)
      (rewrite-cps-cont cont
        (($ $cont sym ($ $kargs names syms body))
         (sym ($kargs names syms ,(visit-term body sym))))
        (($ $cont sym ($ $kfun src meta self tail clause))
         (sym ($kfun src meta self ,tail
                ,(and clause (visit-cont clause sym)))))
        (($ $cont sym ($ $kclause arity body alternate))
         (sym ($kclause ,arity ,(visit-cont body sym)
                        ,(and alternate (visit-cont alternate sym)))))
        (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
         (sym ($kreceive req rest (reduce kargs scope))))))
    (define (visit-term term scope)
      (rewrite-cps-term term
        (($ $letk conts body)
         ($letk ,(map (cut visit-cont <> scope) conts)
           ,(visit-term body scope)))
        (($ $letrec names syms funs body)
         ($letrec names syms (map visit-fun funs)
           ,(visit-term body scope)))
        (($ $continue k src ($ $values args))
         ($continue (reduce-values k scope) src ($values args)))
        (($ $continue k src (and fun ($ $fun)))
         ($continue (reduce k scope) src ,(visit-fun fun)))
        (($ $continue k src ($ $const const))
         ,(let ((k (reduce k scope)))
            (or (reduce-const k src scope const)
                (build-cps-term ($continue k src ($const const))))))
        (($ $continue k src exp)
         ($continue (reduce k scope) src ,exp))))
    (define (visit-fun fun)
      (rewrite-cps-exp fun
        (($ $fun free body)
         ($fun free ,(visit-cont body #f)))))
    (visit-cont fun #f)))

(define (compute-beta-reductions fun)
  ;; A continuation's body can be inlined in place of a $values
  ;; expression if the continuation is a $kargs.  It should only be
  ;; inlined if it is used only once, and not recursively.
  (let ((var-table (make-hash-table))
        (k-table (make-hash-table))
        (dfg (compute-dfg fun)))
    (define (visit-cont cont)
      (match cont
        (($ $cont sym ($ $kargs names syms body))
         (visit-term body))
        (($ $cont sym ($ $kfun src meta self tail clause))
         (when clause (visit-cont clause)))
        (($ $cont sym ($ $kclause arity body alternate))
         (visit-cont body)
         (when alternate (visit-cont alternate)))
        (($ $cont sym (or ($ $ktail) ($ $kreceive)))
         #f)))
    (define (visit-term term)
      (match term
        (($ $letk conts body)
         (for-each visit-cont conts)
         (visit-term body))
        (($ $letrec names syms funs body)
         (for-each visit-fun funs)
         (visit-term body))
        (($ $continue k src ($ $values args))
         (match (lookup-cont k dfg)
           (($ $kargs names syms body)
            (match (lookup-predecessors k dfg)
              ((_)
               ;; There is only one use, and it is this use.  We assume
               ;; it's not recursive, as there would to be some other
               ;; use for control flow to reach this loop.  Store the k
               ;; -> body mapping in the table.  Also store the
               ;; substitutions for the variables bound by the inlined
               ;; continuation.
               (for-each (cut hashq-set! var-table <> <>) syms args)
               (hashq-set! k-table k body))
              (_ #f)))
           (_ #f)))
        (($ $continue k src (and fun ($ $fun)))
         (visit-fun fun))
        (($ $continue k src _)
         #f)))
    (define (visit-fun fun)
      (match fun
        (($ $fun free body)
         (visit-cont body))))
    (visit-cont fun)
    (values var-table k-table)))

(define (beta-reduce fun)
  (let-values (((var-table k-table) (compute-beta-reductions fun)))
    (define (subst var)
      (cond ((hashq-ref var-table var) => subst)
            (else var)))
    (define (must-visit-cont cont)
      (or (visit-cont cont)
          (error "continuation must not be inlined" cont)))
    (define (visit-cont cont)
      (match cont
        (($ $cont sym cont)
         (and (not (hashq-ref k-table sym))
              (rewrite-cps-cont cont
                (($ $kargs names syms body)
                 (sym ($kargs names syms ,(visit-term body))))
                (($ $kfun src meta self tail clause)
                 (sym ($kfun src meta self ,tail
                        ,(and clause (must-visit-cont clause)))))
                (($ $kclause arity body alternate)
                 (sym ($kclause ,arity ,(must-visit-cont body)
                                ,(and alternate (must-visit-cont alternate)))))
                (($ $kreceive)
                 (sym ,cont)))))))
    (define (visit-term term)
      (match term
        (($ $letk conts body)
         (match (filter-map visit-cont conts)
           (() (visit-term body))
           (conts (build-cps-term
                    ($letk ,conts ,(visit-term body))))))
        (($ $letrec names syms funs body)
         (build-cps-term
           ($letrec names syms (map visit-fun funs)
                    ,(visit-term body))))
        (($ $continue k src exp)
         (cond
          ((hashq-ref k-table k) => visit-term)
          (else
           (build-cps-term ($continue k src ,(visit-exp exp))))))))
    (define (visit-exp exp)
      (match exp
        ((or ($ $const) ($ $prim)) exp)
        (($ $fun) (visit-fun exp))
        (($ $call proc args)
         (let ((args (map subst args)))
           (build-cps-exp ($call (subst proc) args))))
        (($ $callk k proc args)
         (let ((args (map subst args)))
           (build-cps-exp ($callk k (subst proc) args))))
        (($ $primcall name args)
         (let ((args (map subst args)))
           (build-cps-exp ($primcall name args))))
        (($ $values args)
         (let ((args (map subst args)))
           (build-cps-exp ($values args))))
        (($ $branch kt exp)
         (build-cps-exp ($branch kt ,(visit-exp exp))))
        (($ $prompt escape? tag handler)
         (build-cps-exp ($prompt escape? (subst tag) handler)))))
    (define (visit-fun fun)
      (rewrite-cps-exp fun
        (($ $fun free body)
         ($fun (map subst free) ,(must-visit-cont body)))))
    (must-visit-cont fun)))

;; Rewrite the scope tree to reflect the dominator tree.  Precondition:
;; the fun has been renumbered, its min-label is 0, and its labels are
;; packed.
(define (redominate fun)
  (let* ((dfg (compute-dfg fun))
         (idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
         (doms (compute-dom-edges idoms 0)))
    (define (visit-fun-cont cont)
      (rewrite-cps-cont cont
        (($ $cont label ($ $kfun src meta self tail clause))
         (label ($kfun src meta self ,tail
                  ,(and clause (visit-fun-cont clause)))))
        (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
         (label ($kclause ,arity ,(visit-cont kbody body)
                          ,(and alternate (visit-fun-cont alternate)))))))

    (define (visit-cont label cont)
      (rewrite-cps-cont cont
        (($ $kargs names vars body)
         (label ($kargs names vars ,(visit-term body label))))
        (_ (label ,cont))))

    (define (visit-exp k src exp)
      (rewrite-cps-term exp
        (($ $fun free body)
         ($continue k src ($fun free ,(visit-fun-cont body))))
        (_
         ($continue k src ,exp))))

    (define (visit-term term label)
      (define (visit-dom-conts label)
        (let ((cont (lookup-cont label dfg)))
          (match cont
            (($ $ktail) '())
            (($ $kargs) (list (visit-cont label cont)))
            (else
             (cons (visit-cont label cont)
                   (visit-dom-conts* (vector-ref doms label)))))))

      (define (visit-dom-conts* labels)
        (match labels
          (() '())
          ((label . labels)
           (append (visit-dom-conts label)
                   (visit-dom-conts* labels)))))

      (rewrite-cps-term term
        (($ $letk conts body)
         ,(visit-term body label))
        (($ $letrec names syms funs body)
         ($letrec names syms (let lp ((funs funs))
                               (match funs
                                 (() '())
                                 ((($ $fun free body) . funs)
                                  (cons (build-cps-exp
                                          ($fun free ,(visit-fun-cont body)))
                                        (lp funs)))))
           ,(visit-term body label)))
        (($ $continue k src exp)
         ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
            (if (null? conts)
                (visit-exp k src exp)
                (build-cps-term
                  ($letk ,conts ,(visit-exp k src exp))))))))

    (visit-fun-cont fun)))

(define (simplify fun)
  ;; Renumbering prunes continuations that are made unreachable by
  ;; eta/beta reductions.
  (redominate (renumber (eta-reduce (beta-reduce fun)))))
Commit	Line	Data
22a79b55 AW	1	;;; Continuation-passing style (CPS) intermediate language (IL)
22a79b55 AW	2
a9ec16f9	3	;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
22a79b55 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	;;; Commentary:
	20	;;;
	21	;;; The fundamental lambda calculus reductions, like beta and eta
	22	;;; reduction and so on. Pretty lame currently.
	23	;;;
	24	;;; Code:
	25
	26	(define-module (language cps simplify)
	27	#:use-module (ice-9 match)
	28	#:use-module (srfi srfi-1)
b9e601d2	29	#:use-module (srfi srfi-11)
22a79b55 AW	30	#:use-module (srfi srfi-26)
	31	#:use-module (language cps)
	32	#:use-module (language cps dfg)
c79c02d6	33	#:use-module (language cps renumber)
22a79b55 AW	34	#:export (simplify))
22a79b55 AW	35
4b3d7a2b AW	36	(define (compute-eta-reductions fun)
	37	(let ((table (make-hash-table)))
	38	(define (visit-cont cont)
	39	(match cont
	40	(($ $cont sym ($ $kargs names syms body))
	41	(visit-term body sym syms))
8320f504	42	(($ $cont sym ($ $kfun src meta self tail clause))
90dce16d AW	43	(when clause (visit-cont clause)))
	44	(($ $cont sym ($ $kclause arity body alternate))
	45	(visit-cont body)
	46	(when alternate (visit-cont alternate)))
4b3d7a2b AW	47	(($ $cont sym _) #f)))
	48	(define (visit-term term term-k term-args)
	49	(match term
	50	(($ $letk conts body)
	51	(for-each visit-cont conts)
	52	(visit-term body term-k term-args))
	53	(($ $letrec names syms funs body)
	54	(for-each visit-fun funs)
	55	(visit-term body term-k term-args))
	56	(($ $continue k src ($ $values args))
	57	(when (and (equal? term-args args) (not (eq? k term-k)))
	58	(hashq-set! table term-k k)))
	59	(($ $continue k src (and fun ($ $fun)))
	60	(visit-fun fun))
	61	(($ $continue k src _)
	62	#f)))
	63	(define (visit-fun fun)
	64	(match fun
24b611e8	65	(($ $fun free body)
4b3d7a2b	66	(visit-cont body))))
a0329d01	67	(visit-cont fun)
4b3d7a2b AW	68	table))
4b3d7a2b AW	69
22a79b55 AW	70	(define (eta-reduce fun)
22a79b55 AW	71	(let ((table (compute-eta-reductions fun))
a0329d01	72	(dfg (compute-dfg fun)))
22a79b55 AW	73	(define (reduce* k scope values?)
	74	(match (hashq-ref table k)
	75	(#f k)
	76	(k*
	77	(if (and (continuation-bound-in? k* scope dfg)
	78	(or values?
fbdb69b2	79	(match (lookup-cont k* dfg)
22a79b55 AW	80	(($ $kargs) #t)
	81	(_ #f))))
	82	(reduce* k* scope values?)
	83	k))))
	84	(define (reduce k scope)
	85	(reduce* k scope #f))
	86	(define (reduce-values k scope)
	87	(reduce* k scope #t))
b9a5bac6 AW	88	(define (reduce-const k src scope const)
	89	(let lp ((k k) (seen '()) (const const))
	90	(match (lookup-cont k dfg)
	91	(($ $kargs (_) (arg) term)
	92	(match (find-call term)
	93	(($ $continue k* src* ($ $values (arg*)))
	94	(and (eqv? arg arg*)
	95	(not (memq k* seen))
	96	(lp k* (cons k seen) const)))
	97	(($ $continue k* src* ($ $primcall 'not (arg*)))
	98	(and (eqv? arg arg*)
	99	(not (memq k* seen))
	100	(lp k* (cons k seen) (not const))))
	101	(($ $continue k* src* ($ $branch kt ($ $values (arg*))))
	102	(and (eqv? arg arg*)
	103	(let ((k* (if const kt k*)))
	104	(and (continuation-bound-in? k* scope dfg)
	105	(build-cps-term
	106	($continue k* src ($values ())))))))
	107	(_
	108	(and (continuation-bound-in? k scope dfg)
	109	(build-cps-term
	110	($continue k src ($const const)))))))
	111	(_ #f))))
22a79b55 AW	112	(define (visit-cont cont scope)
	113	(rewrite-cps-cont cont
	114	(($ $cont sym ($ $kargs names syms body))
	115	(sym ($kargs names syms ,(visit-term body sym))))
8320f504 AW	116	(($ $cont sym ($ $kfun src meta self tail clause))
8320f504 AW	117	(sym ($kfun src meta self ,tail
24b611e8	118	,(and clause (visit-cont clause sym)))))
90dce16d AW	119	(($ $cont sym ($ $kclause arity body alternate))
	120	(sym ($kclause ,arity ,(visit-cont body sym)
	121	,(and alternate (visit-cont alternate sym)))))
36527695	122	(($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
59258f7c	123	(sym ($kreceive req rest (reduce kargs scope))))))
22a79b55 AW	124	(define (visit-term term scope)
	125	(rewrite-cps-term term
	126	(($ $letk conts body)
	127	($letk ,(map (cut visit-cont <> scope) conts)
	128	,(visit-term body scope)))
	129	(($ $letrec names syms funs body)
	130	($letrec names syms (map visit-fun funs)
b9a5bac6	131	,(visit-term body scope)))
22a79b55 AW	132	(($ $continue k src ($ $values args))
	133	($continue (reduce-values k scope) src ($values args)))
	134	(($ $continue k src (and fun ($ $fun)))
	135	($continue (reduce k scope) src ,(visit-fun fun)))
b9a5bac6 AW	136	(($ $continue k src ($ $const const))
	137	,(let ((k (reduce k scope)))
	138	(or (reduce-const k src scope const)
	139	(build-cps-term ($continue k src ($const const))))))
22a79b55 AW	140	(($ $continue k src exp)
	141	($continue (reduce k scope) src ,exp))))
	142	(define (visit-fun fun)
4b3d7a2b	143	(rewrite-cps-exp fun
24b611e8 AW	144	(($ $fun free body)
24b611e8 AW	145	($fun free ,(visit-cont body #f)))))
a0329d01	146	(visit-cont fun #f)))
22a79b55 AW	147
	148	(define (compute-beta-reductions fun)
	149	;; A continuation's body can be inlined in place of a $values
	150	;; expression if the continuation is a $kargs. It should only be
	151	;; inlined if it is used only once, and not recursively.
b9e601d2 AW	152	(let ((var-table (make-hash-table))
b9e601d2 AW	153	(k-table (make-hash-table))
a0329d01	154	(dfg (compute-dfg fun)))
22a79b55 AW	155	(define (visit-cont cont)
	156	(match cont
	157	(($ $cont sym ($ $kargs names syms body))
	158	(visit-term body))
8320f504	159	(($ $cont sym ($ $kfun src meta self tail clause))
90dce16d AW	160	(when clause (visit-cont clause)))
	161	(($ $cont sym ($ $kclause arity body alternate))
	162	(visit-cont body)
	163	(when alternate (visit-cont alternate)))
59258f7c	164	(($ $cont sym (or ($ $ktail) ($ $kreceive)))
22a79b55 AW	165	#f)))
	166	(define (visit-term term)
	167	(match term
	168	(($ $letk conts body)
	169	(for-each visit-cont conts)
	170	(visit-term body))
	171	(($ $letrec names syms funs body)
	172	(for-each visit-fun funs)
	173	(visit-term body))
	174	(($ $continue k src ($ $values args))
fbdb69b2	175	(match (lookup-cont k dfg)
22a79b55 AW	176	(($ $kargs names syms body)
	177	(match (lookup-predecessors k dfg)
	178	((_)
	179	;; There is only one use, and it is this use. We assume
	180	;; it's not recursive, as there would to be some other
	181	;; use for control flow to reach this loop. Store the k
	182	;; -> body mapping in the table. Also store the
	183	;; substitutions for the variables bound by the inlined
	184	;; continuation.
b9e601d2 AW	185	(for-each (cut hashq-set! var-table <> <>) syms args)
b9e601d2 AW	186	(hashq-set! k-table k body))
22a79b55 AW	187	(_ #f)))
	188	(_ #f)))
	189	(($ $continue k src (and fun ($ $fun)))
	190	(visit-fun fun))
	191	(($ $continue k src _)
	192	#f)))
	193	(define (visit-fun fun)
	194	(match fun
24b611e8	195	(($ $fun free body)
22a79b55	196	(visit-cont body))))
a0329d01	197	(visit-cont fun)
b9e601d2	198	(values var-table k-table)))
22a79b55 AW	199
22a79b55 AW	200	(define (beta-reduce fun)
b9e601d2	201	(let-values (((var-table k-table) (compute-beta-reductions fun)))
22a79b55	202	(define (subst var)
b9e601d2	203	(cond ((hashq-ref var-table var) => subst)
22a79b55 AW	204	(else var)))
	205	(define (must-visit-cont cont)
	206	(or (visit-cont cont)
	207	(error "continuation must not be inlined" cont)))
	208	(define (visit-cont cont)
	209	(match cont
	210	(($ $cont sym cont)
b9e601d2	211	(and (not (hashq-ref k-table sym))
22a79b55 AW	212	(rewrite-cps-cont cont
	213	(($ $kargs names syms body)
	214	(sym ($kargs names syms ,(visit-term body))))
8320f504 AW	215	(($ $kfun src meta self tail clause)
8320f504 AW	216	(sym ($kfun src meta self ,tail
90dce16d AW	217	,(and clause (must-visit-cont clause)))))
	218	(($ $kclause arity body alternate)
	219	(sym ($kclause ,arity ,(must-visit-cont body)
	220	,(and alternate (must-visit-cont alternate)))))
59258f7c	221	(($ $kreceive)
22a79b55 AW	222	(sym ,cont)))))))
	223	(define (visit-term term)
	224	(match term
	225	(($ $letk conts body)
	226	(match (filter-map visit-cont conts)
	227	(() (visit-term body))
	228	(conts (build-cps-term
	229	($letk ,conts ,(visit-term body))))))
	230	(($ $letrec names syms funs body)
	231	(build-cps-term
	232	($letrec names syms (map visit-fun funs)
	233	,(visit-term body))))
	234	(($ $continue k src exp)
	235	(cond
b9e601d2	236	((hashq-ref k-table k) => visit-term)
22a79b55	237	(else
92805e21 AW	238	(build-cps-term ($continue k src ,(visit-exp exp))))))))
	239	(define (visit-exp exp)
	240	(match exp
a9ec16f9	241	((or ($ $const) ($ $prim)) exp)
92805e21 AW	242	(($ $fun) (visit-fun exp))
	243	(($ $call proc args)
	244	(let ((args (map subst args)))
	245	(build-cps-exp ($call (subst proc) args))))
	246	(($ $callk k proc args)
	247	(let ((args (map subst args)))
	248	(build-cps-exp ($callk k (subst proc) args))))
	249	(($ $primcall name args)
	250	(let ((args (map subst args)))
	251	(build-cps-exp ($primcall name args))))
	252	(($ $values args)
	253	(let ((args (map subst args)))
	254	(build-cps-exp ($values args))))
	255	(($ $branch kt exp)
	256	(build-cps-exp ($branch kt ,(visit-exp exp))))
	257	(($ $prompt escape? tag handler)
	258	(build-cps-exp ($prompt escape? (subst tag) handler)))))
22a79b55 AW	259	(define (visit-fun fun)
22a79b55 AW	260	(rewrite-cps-exp fun
24b611e8 AW	261	(($ $fun free body)
24b611e8 AW	262	($fun (map subst free) ,(must-visit-cont body)))))
a0329d01	263	(must-visit-cont fun)))
22a79b55	264
44954194 AW	265	;; Rewrite the scope tree to reflect the dominator tree. Precondition:
	266	;; the fun has been renumbered, its min-label is 0, and its labels are
	267	;; packed.
	268	(define (redominate fun)
	269	(let* ((dfg (compute-dfg fun))
	270	(idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
	271	(doms (compute-dom-edges idoms 0)))
	272	(define (visit-fun-cont cont)
	273	(rewrite-cps-cont cont
	274	(($ $cont label ($ $kfun src meta self tail clause))
	275	(label ($kfun src meta self ,tail
	276	,(and clause (visit-fun-cont clause)))))
	277	(($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
	278	(label ($kclause ,arity ,(visit-cont kbody body)
	279	,(and alternate (visit-fun-cont alternate)))))))
	280
	281	(define (visit-cont label cont)
	282	(rewrite-cps-cont cont
	283	(($ $kargs names vars body)
	284	(label ($kargs names vars ,(visit-term body label))))
	285	(_ (label ,cont))))
	286
	287	(define (visit-exp k src exp)
	288	(rewrite-cps-term exp
	289	(($ $fun free body)
	290	($continue k src ($fun free ,(visit-fun-cont body))))
	291	(_
	292	($continue k src ,exp))))
	293
	294	(define (visit-term term label)
	295	(define (visit-dom-conts label)
	296	(let ((cont (lookup-cont label dfg)))
	297	(match cont
	298	(($ $ktail) '())
	299	(($ $kargs) (list (visit-cont label cont)))
	300	(else
	301	(cons (visit-cont label cont)
	302	(visit-dom-conts* (vector-ref doms label)))))))
	303
	304	(define (visit-dom-conts* labels)
	305	(match labels
	306	(() '())
	307	((label . labels)
	308	(append (visit-dom-conts label)
	309	(visit-dom-conts* labels)))))
	310
	311	(rewrite-cps-term term
	312	(($ $letk conts body)
	313	,(visit-term body label))
	314	(($ $letrec names syms funs body)
	315	($letrec names syms (let lp ((funs funs))
	316	(match funs
	317	(() '())
	318	((($ $fun free body) . funs)
	319	(cons (build-cps-exp
	320	($fun free ,(visit-fun-cont body)))
	321	(lp funs)))))
	322	,(visit-term body label)))
	323	(($ $continue k src exp)
	324	,(let ((conts (visit-dom-conts* (vector-ref doms label))))
	325	(if (null? conts)
	326	(visit-exp k src exp)
	327	(build-cps-term
	328	($letk ,conts ,(visit-exp k src exp))))))))
329
330	(visit-fun-cont fun)))
331
22a79b55	332	(define (simplify fun)
c79c02d6 AW	333	;; Renumbering prunes continuations that are made unreachable by
c79c02d6 AW	334	;; eta/beta reductions.
44954194	335	(redominate (renumber (eta-reduce (beta-reduce fun)))))