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

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

;; Copyright (C) 2013, 2014 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:
;;;
;;; Various optimizations can inline calls from one continuation to some
;;; other continuation, usually in response to information about the
;;; return arity of the call.  That leaves us with dangling
;;; continuations that aren't reachable any more from the procedure
;;; entry.  This pass will remove them.
;;;
;;; This pass also kills dead expressions: code that has no side
;;; effects, and whose value is unused.  It does so by marking all live
;;; values, and then discarding other values as dead.  This happens
;;; recursively through procedures, so it should be possible to elide
;;; dead procedures as well.
;;;
;;; Code:

(define-module (language cps dce)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (language cps)
  #:use-module (language cps dfg)
  #:use-module (language cps effects-analysis)
  #:use-module (language cps renumber)
  #:use-module (language cps types)
  #:export (eliminate-dead-code))

(define-record-type $fun-data
  (make-fun-data min-label effects live-conts defs)
  fun-data?
  (min-label fun-data-min-label)
  (effects fun-data-effects)
  (live-conts fun-data-live-conts)
  (defs fun-data-defs))

(define (compute-defs dfg min-label label-count)
  (define (cont-defs k)
    (match (lookup-cont k dfg)
      (($ $kargs names vars) vars)
      (_ #f)))
  (define (idx->label idx) (+ idx min-label))
  (let ((defs (make-vector label-count #f)))
    (let lp ((n 0))
      (when (< n label-count)
        (vector-set!
         defs
         n
         (match (lookup-cont (idx->label n) dfg)
           (($ $kargs _ _ body)
            (match (find-call body)
              (($ $continue k) (cont-defs k))))
           (($ $kreceive arity kargs)
            (cont-defs kargs))
           (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
            syms)
           (($ $kif) #f)
           (($ $kfun src meta self) (list self))
           (($ $ktail) #f)))
        (lp (1+ n))))
    defs))

(define (elide-type-checks! fun dfg effects min-label label-count)
  (when (< label-count 2000)
    (match fun
     (($ $cont kfun ($ $kfun src meta min-var))
      (let ((typev (infer-types fun dfg)))
        (define (idx->label idx) (+ idx min-label))
        (define (var->idx var) (- var min-var))
        (let lp ((lidx 0))
          (when (< lidx label-count)
            (let ((fx (vector-ref effects lidx)))
              (unless (causes-all-effects? fx)
                (when (causes-effect? fx &type-check)
                  (match (lookup-cont (idx->label lidx) dfg)
                    (($ $kargs _ _ term)
                     (match (find-call term)
                       (($ $continue k src ($ $primcall name args))
                        (let ((args (map var->idx args)))
                          ;; Negative args are closure variables.
                          (unless (or-map negative? args)
                            (when (primcall-types-check? lidx typev name args)
                              (vector-set! effects lidx
                                           (logand fx (lognot &type-check)))))))
                       (_ #f)))
                    (_ #f)))))
            (lp (1+ lidx)))))))))

(define (compute-live-code fun)
  (let* ((fun-data-table (make-hash-table))
         (dfg (compute-dfg fun #:global? #t))
         (live-vars (make-bitvector (dfg-var-count dfg) #f))
         (changed? #f))
    (define (mark-live! var)
      (unless (value-live? var)
        (set! changed? #t)
        (bitvector-set! live-vars var #t)))
    (define (value-live? var)
      (bitvector-ref live-vars var))
    (define (ensure-fun-data fun)
      (or (hashq-ref fun-data-table fun)
          (call-with-values (lambda ()
                              ((make-local-cont-folder label-count max-label)
                               (lambda (k cont label-count max-label)
                                 (values (1+ label-count) (max k max-label)))
                               fun 0 -1))
            (lambda (label-count max-label)
              (let* ((min-label (- (1+ max-label) label-count))
                     (effects (compute-effects dfg min-label label-count))
                     (live-conts (make-bitvector label-count #f))
                     (defs (compute-defs dfg min-label label-count))
                     (fun-data (make-fun-data
                                min-label effects live-conts defs)))
                (elide-type-checks! fun dfg effects min-label label-count)
                (hashq-set! fun-data-table fun fun-data)
                (set! changed? #t)
                fun-data)))))
    (define (visit-fun fun)
      (match (ensure-fun-data fun)
        (($ $fun-data min-label effects live-conts defs)
         (define (idx->label idx) (+ idx min-label))
         (define (label->idx label) (- label min-label))
         (define (known-allocation? var dfg)
           (match (lookup-predecessors (lookup-def var dfg) dfg)
             ((def-exp-k)
              (match (lookup-cont def-exp-k dfg)
                (($ $kargs _ _ term)
                 (match (find-call term)
                   (($ $continue k src ($ $values (var)))
                    (known-allocation? var dfg))
                   (($ $continue k src ($ $primcall))
                    (let ((kidx (label->idx def-exp-k)))
                      (and (>= kidx 0)
                           (causes-effect? (vector-ref effects kidx)
                                           &allocation))))
                   (_ #f)))
                (_ #f)))
             (_ #f)))
         (define (visit-grey-exp n exp)
           (let ((defs (vector-ref defs n))
                 (fx (vector-ref effects n)))
             (or
              ;; No defs; perhaps continuation is $ktail.
              (not defs)
              ;; Do we have a live def?
              (or-map value-live? defs)
              ;; Does this expression cause all effects?  If so, it's
              ;; definitely live.
              (causes-all-effects? fx)
              ;; Does it cause a type check, but we weren't able to
              ;; prove that the types check?
              (causes-effect? fx &type-check)
              ;; We might have a setter.  If the object being assigned
              ;; to is live or was not created by us, then this
              ;; expression is live.  Otherwise the value is still dead.
              (and (causes-effect? fx &write)
                   (match exp
                     (($ $primcall
                         (or 'vector-set! 'vector-set!/immediate
                             'set-car! 'set-cdr!
                             'box-set!)
                         (obj . _))
                      (or (value-live? obj)
                          (not (known-allocation? obj dfg))))
                     (_ #t))))))
         (let lp ((n (1- (vector-length effects))))
           (unless (< n 0)
             (let ((cont (lookup-cont (idx->label n) dfg)))
               (match cont
                 (($ $kargs _ _ body)
                  (let lp ((body body))
                    (match body
                      (($ $letk conts body) (lp body))
                      (($ $letrec names syms funs body)
                       (lp body)
                       (for-each (lambda (sym fun)
                                   (when (value-live? sym)
                                     (match fun
                                       (($ $fun free body)
                                        (visit-fun body)))))
                                 syms funs))
                      (($ $continue k src exp)
                       (unless (bitvector-ref live-conts n)
                         (when (visit-grey-exp n exp)
                           (set! changed? #t)
                           (bitvector-set! live-conts n #t)))
                       (when (bitvector-ref live-conts n)
                         (match exp
                           ((or ($ $void) ($ $const) ($ $prim))
                            #f)
                           (($ $fun free body)
                            (visit-fun body))
                           (($ $prompt escape? tag handler)
                            (mark-live! tag))
                           (($ $call proc args)
                            (mark-live! proc)
                            (for-each mark-live! args))
                           (($ $callk k proc args)
                            (mark-live! proc)
                            (for-each mark-live! args))
                           (($ $primcall name args)
                            (for-each mark-live! args))
                           (($ $values args)
                            (match (vector-ref defs n)
                              (#f (for-each mark-live! args))
                              (defs (for-each (lambda (use def)
                                                (when (value-live? def)
                                                  (mark-live! use)))
                                              args defs))))))))))
                 (($ $kreceive arity kargs) #f)
                 (($ $kif) #f)
                 (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
                  (for-each mark-live! syms))
                 (($ $kfun src meta self)
                  (mark-live! self))
                 (($ $ktail) #f))
               (lp (1- n))))))))
    (unless (= (dfg-var-count dfg) (var-counter))
      (error "internal error" (dfg-var-count dfg) (var-counter)))
    (let lp ()
      (set! changed? #f)
      (visit-fun fun)
      (when changed? (lp)))
    (values fun-data-table live-vars)))

(define (process-eliminations fun fun-data-table live-vars)
  (define (value-live? var)
    (bitvector-ref live-vars var))
  (define (make-adaptor name k defs)
    (let* ((names (map (lambda (_) 'tmp) defs))
           (syms (map (lambda (_) (fresh-var)) defs))
           (live (filter-map (lambda (def sym)
                               (and (value-live? def)
                                    sym))
                             defs syms)))
      (build-cps-cont
        (name ($kargs names syms
                ($continue k #f ($values live)))))))
  (define (visit-fun fun)
    (match (hashq-ref fun-data-table fun)
      (($ $fun-data min-label effects live-conts defs)
       (define (label->idx label) (- label min-label))
       (define (visit-cont cont)
         (match (visit-cont* cont)
           ((cont) cont)))
       (define (visit-cont* cont)
         (match cont
           (($ $cont label cont)
            (match cont
              (($ $kargs names syms body)
               (match (filter-map (lambda (name sym)
                                    (and (value-live? sym)
                                         (cons name sym)))
                                  names syms)
                 (((names . syms) ...)
                  (list
                   (build-cps-cont
                     (label ($kargs names syms
                              ,(visit-term body label))))))))
              (($ $kfun src meta self tail clause)
               (list
                (build-cps-cont
                  (label ($kfun src meta self ,tail
                           ,(and clause (visit-cont clause)))))))
              (($ $kclause arity body alternate)
               (list
                (build-cps-cont
                  (label ($kclause ,arity
                           ,(visit-cont body)
                           ,(and alternate
                                 (visit-cont alternate)))))))
              (($ $kreceive ($ $arity req () rest () #f) kargs)
               (let ((defs (vector-ref defs (label->idx label))))
                 (if (and-map value-live? defs)
                     (list (build-cps-cont (label ,cont)))
                     (let-fresh (adapt) ()
                       (list (make-adaptor adapt kargs defs)
                             (build-cps-cont
                               (label ($kreceive req rest adapt))))))))
              (_ (list (build-cps-cont (label ,cont))))))))
       (define (visit-conts conts)
         (append-map visit-cont* conts))
       (define (visit-term term term-k)
         (match term
           (($ $letk conts body)
            (let ((body (visit-term body term-k)))
              (match (visit-conts conts)
                (() body)
                (conts (build-cps-term ($letk ,conts ,body))))))
           (($ $letrec names syms funs body)
            (let ((body (visit-term body term-k)))
              (match (filter-map
                      (lambda (name sym fun)
                        (and (value-live? sym)
                             (match fun
                               (($ $fun free body)
                                (list name
                                      sym
                                      (build-cps-exp
                                        ($fun free ,(visit-fun body))))))))
                      names syms funs)
                (() body)
                (((names syms funs) ...)
                 (build-cps-term
                   ($letrec names syms funs ,body))))))
           (($ $continue k src ($ $values args))
            (match (vector-ref defs (label->idx term-k))
              (#f term)
              (defs
                (let ((args (filter-map (lambda (use def)
                                          (and (value-live? def) use))
                                        args defs)))
                  (build-cps-term
                    ($continue k src ($values args)))))))
           (($ $continue k src exp)
            (if (bitvector-ref live-conts (label->idx term-k))
                (rewrite-cps-term exp
                  (($ $fun free body)
                   ($continue k src ($fun free ,(visit-fun body))))
                  (_
                   ,(match (vector-ref defs (label->idx term-k))
                      ((or #f ((? value-live?) ...))
                       (build-cps-term
                         ($continue k src ,exp)))
                      (syms
                       (let-fresh (adapt) ()
                         (build-cps-term
                           ($letk (,(make-adaptor adapt k syms))
                             ($continue adapt src ,exp))))))))
                (build-cps-term ($continue k src ($values ())))))))
       (visit-cont fun))))
  (visit-fun fun))

(define (eliminate-dead-code fun)
  (call-with-values (lambda () (renumber fun))
    (lambda (fun nlabels nvars)
      (parameterize ((label-counter nlabels)
                     (var-counter nvars))
        (call-with-values (lambda () (compute-live-code fun))
          (lambda (fun-data-table live-vars)
            (process-eliminations fun fun-data-table live-vars)))))))
Commit	Line	Data
305cccb4 AW	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	;;; Various optimizations can inline calls from one continuation to some
	22	;;; other continuation, usually in response to information about the
	23	;;; return arity of the call. That leaves us with dangling
	24	;;; continuations that aren't reachable any more from the procedure
	25	;;; entry. This pass will remove them.
	26	;;;
	27	;;; This pass also kills dead expressions: code that has no side
	28	;;; effects, and whose value is unused. It does so by marking all live
	29	;;; values, and then discarding other values as dead. This happens
	30	;;; recursively through procedures, so it should be possible to elide
	31	;;; dead procedures as well.
	32	;;;
	33	;;; Code:
	34
	35	(define-module (language cps dce)
	36	#:use-module (ice-9 match)
	37	#:use-module (srfi srfi-1)
	38	#:use-module (srfi srfi-9)
	39	#:use-module (language cps)
	40	#:use-module (language cps dfg)
	41	#:use-module (language cps effects-analysis)
3269e1b6	42	#:use-module (language cps renumber)
3be43fb7	43	#:use-module (language cps types)
305cccb4 AW	44	#:export (eliminate-dead-code))
	45
	46	(define-record-type $fun-data
ce1dbe8c	47	(make-fun-data min-label effects live-conts defs)
305cccb4	48	fun-data?
3269e1b6	49	(min-label fun-data-min-label)
305cccb4	50	(effects fun-data-effects)
305cccb4 AW	51	(live-conts fun-data-live-conts)
	52	(defs fun-data-defs))
	53
3269e1b6	54	(define (compute-defs dfg min-label label-count)
305cccb4	55	(define (cont-defs k)
3269e1b6 AW	56	(match (lookup-cont k dfg)
3269e1b6 AW	57	(($ $kargs names vars) vars)
305cccb4	58	(_ #f)))
3269e1b6 AW	59	(define (idx->label idx) (+ idx min-label))
3269e1b6 AW	60	(let ((defs (make-vector label-count #f)))
305cccb4	61	(let lp ((n 0))
3269e1b6	62	(when (< n label-count)
305cccb4 AW	63	(vector-set!
	64	defs
	65	n
3269e1b6	66	(match (lookup-cont (idx->label n) dfg)
305cccb4 AW	67	(($ $kargs _ _ body)
	68	(match (find-call body)
	69	(($ $continue k) (cont-defs k))))
36527695	70	(($ $kreceive arity kargs)
305cccb4 AW	71	(cont-defs kargs))
	72	(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
	73	syms)
	74	(($ $kif) #f)
8320f504	75	(($ $kfun src meta self) (list self))
305cccb4 AW	76	(($ $ktail) #f)))
	77	(lp (1+ n))))
	78	defs))
	79
3be43fb7 AW	80	(define (elide-type-checks! fun dfg effects min-label label-count)
	81	(when (< label-count 2000)
	82	(match fun
	83	(($ $cont kfun ($ $kfun src meta min-var))
	84	(let ((typev (infer-types fun dfg)))
	85	(define (idx->label idx) (+ idx min-label))
	86	(define (var->idx var) (- var min-var))
	87	(let lp ((lidx 0))
	88	(when (< lidx label-count)
	89	(let ((fx (vector-ref effects lidx)))
	90	(unless (causes-all-effects? fx)
	91	(when (causes-effect? fx &type-check)
	92	(match (lookup-cont (idx->label lidx) dfg)
	93	(($ $kargs _ _ term)
	94	(match (find-call term)
	95	(($ $continue k src ($ $primcall name args))
	96	(let ((args (map var->idx args)))
	97	;; Negative args are closure variables.
	98	(unless (or-map negative? args)
	99	(when (primcall-types-check? lidx typev name args)
	100	(vector-set! effects lidx
	101	(logand fx (lognot &type-check)))))))
	102	(_ #f)))
	103	(_ #f)))))
	104	(lp (1+ lidx)))))))))
40b36bbf	105
305cccb4	106	(define (compute-live-code fun)
3269e1b6	107	(let* ((fun-data-table (make-hash-table))
a0329d01	108	(dfg (compute-dfg fun #:global? #t))
0912202a	109	(live-vars (make-bitvector (dfg-var-count dfg) #f))
3269e1b6	110	(changed? #f))
0912202a AW	111	(define (mark-live! var)
0912202a AW	112	(unless (value-live? var)
305cccb4	113	(set! changed? #t)
0912202a AW	114	(bitvector-set! live-vars var #t)))
	115	(define (value-live? var)
	116	(bitvector-ref live-vars var))
305cccb4 AW	117	(define (ensure-fun-data fun)
305cccb4 AW	118	(or (hashq-ref fun-data-table fun)
3269e1b6	119	(call-with-values (lambda ()
405805fb	120	((make-local-cont-folder label-count max-label)
a0329d01 AW	121	(lambda (k cont label-count max-label)
	122	(values (1+ label-count) (max k max-label)))
	123	fun 0 -1))
3269e1b6 AW	124	(lambda (label-count max-label)
	125	(let* ((min-label (- (1+ max-label) label-count))
	126	(effects (compute-effects dfg min-label label-count))
	127	(live-conts (make-bitvector label-count #f))
	128	(defs (compute-defs dfg min-label label-count))
ce1dbe8c AW	129	(fun-data (make-fun-data
ce1dbe8c AW	130	min-label effects live-conts defs)))
3be43fb7	131	(elide-type-checks! fun dfg effects min-label label-count)
3269e1b6 AW	132	(hashq-set! fun-data-table fun fun-data)
	133	(set! changed? #t)
	134	fun-data)))))
305cccb4 AW	135	(define (visit-fun fun)
305cccb4 AW	136	(match (ensure-fun-data fun)
ce1dbe8c	137	(($ $fun-data min-label effects live-conts defs)
3be43fb7 AW	138	(define (idx->label idx) (+ idx min-label))
	139	(define (label->idx label) (- label min-label))
	140	(define (known-allocation? var dfg)
	141	(match (lookup-predecessors (lookup-def var dfg) dfg)
	142	((def-exp-k)
	143	(match (lookup-cont def-exp-k dfg)
	144	(($ $kargs _ _ term)
	145	(match (find-call term)
	146	(($ $continue k src ($ $values (var)))
	147	(known-allocation? var dfg))
	148	(($ $continue k src ($ $primcall))
	149	(let ((kidx (label->idx def-exp-k)))
	150	(and (>= kidx 0)
	151	(causes-effect? (vector-ref effects kidx)
	152	&allocation))))
	153	(_ #f)))
	154	(_ #f)))
	155	(_ #f)))
40b36bbf AW	156	(define (visit-grey-exp n exp)
	157	(let ((defs (vector-ref defs n))
	158	(fx (vector-ref effects n)))
	159	(or
	160	;; No defs; perhaps continuation is $ktail.
	161	(not defs)
	162	;; Do we have a live def?
	163	(or-map value-live? defs)
5d25fdae AW	164	;; Does this expression cause all effects? If so, it's
	165	;; definitely live.
	166	(causes-all-effects? fx)
3be43fb7 AW	167	;; Does it cause a type check, but we weren't able to
	168	;; prove that the types check?
	169	(causes-effect? fx &type-check)
5d25fdae	170	;; We might have a setter. If the object being assigned
3be43fb7 AW	171	;; to is live or was not created by us, then this
3be43fb7 AW	172	;; expression is live. Otherwise the value is still dead.
5d25fdae AW	173	(and (causes-effect? fx &write)
5d25fdae AW	174	(match exp
3be43fb7 AW	175	(($ $primcall
	176	(or 'vector-set! 'vector-set!/immediate
	177	'set-car! 'set-cdr!
	178	'box-set!)
	179	(obj . _))
	180	(or (value-live? obj)
	181	(not (known-allocation? obj dfg))))
5d25fdae	182	(_ #t))))))
ce1dbe8c	183	(let lp ((n (1- (vector-length effects))))
305cccb4	184	(unless (< n 0)
3269e1b6	185	(let ((cont (lookup-cont (idx->label n) dfg)))
305cccb4 AW	186	(match cont
	187	(($ $kargs _ _ body)
	188	(let lp ((body body))
	189	(match body
	190	(($ $letk conts body) (lp body))
	191	(($ $letrec names syms funs body)
	192	(lp body)
	193	(for-each (lambda (sym fun)
	194	(when (value-live? sym)
a0329d01 AW	195	(match fun
	196	(($ $fun free body)
	197	(visit-fun body)))))
305cccb4 AW	198	syms funs))
	199	(($ $continue k src exp)
	200	(unless (bitvector-ref live-conts n)
40b36bbf	201	(when (visit-grey-exp n exp)
305cccb4 AW	202	(set! changed? #t)
	203	(bitvector-set! live-conts n #t)))
	204	(when (bitvector-ref live-conts n)
	205	(match exp
	206	((or ($ $void) ($ $const) ($ $prim))
	207	#f)
a0329d01 AW	208	(($ $fun free body)
a0329d01 AW	209	(visit-fun body))
305cccb4 AW	210	(($ $prompt escape? tag handler)
	211	(mark-live! tag))
	212	(($ $call proc args)
	213	(mark-live! proc)
	214	(for-each mark-live! args))
b3ae2b50 AW	215	(($ $callk k proc args)
	216	(mark-live! proc)
	217	(for-each mark-live! args))
305cccb4 AW	218	(($ $primcall name args)
	219	(for-each mark-live! args))
	220	(($ $values args)
	221	(match (vector-ref defs n)
	222	(#f (for-each mark-live! args))
	223	(defs (for-each (lambda (use def)
	224	(when (value-live? def)
	225	(mark-live! use)))
	226	args defs))))))))))
36527695	227	(($ $kreceive arity kargs) #f)
305cccb4 AW	228	(($ $kif) #f)
	229	(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
	230	(for-each mark-live! syms))
8320f504	231	(($ $kfun src meta self)
305cccb4 AW	232	(mark-live! self))
	233	(($ $ktail) #f))
	234	(lp (1- n))))))))
0912202a AW	235	(unless (= (dfg-var-count dfg) (var-counter))
0912202a AW	236	(error "internal error" (dfg-var-count dfg) (var-counter)))
305cccb4 AW	237	(let lp ()
	238	(set! changed? #f)
	239	(visit-fun fun)
	240	(when changed? (lp)))
	241	(values fun-data-table live-vars)))
	242
3269e1b6	243	(define (process-eliminations fun fun-data-table live-vars)
0912202a AW	244	(define (value-live? var)
0912202a AW	245	(bitvector-ref live-vars var))
3269e1b6 AW	246	(define (make-adaptor name k defs)
	247	(let* ((names (map (lambda (_) 'tmp) defs))
	248	(syms (map (lambda (_) (fresh-var)) defs))
	249	(live (filter-map (lambda (def sym)
	250	(and (value-live? def)
	251	sym))
	252	defs syms)))
	253	(build-cps-cont
	254	(name ($kargs names syms
	255	($continue k #f ($values live)))))))
	256	(define (visit-fun fun)
	257	(match (hashq-ref fun-data-table fun)
ce1dbe8c	258	(($ $fun-data min-label effects live-conts defs)
3269e1b6 AW	259	(define (label->idx label) (- label min-label))
	260	(define (visit-cont cont)
	261	(match (visit-cont* cont)
	262	((cont) cont)))
	263	(define (visit-cont* cont)
	264	(match cont
	265	(($ $cont label cont)
	266	(match cont
	267	(($ $kargs names syms body)
	268	(match (filter-map (lambda (name sym)
	269	(and (value-live? sym)
	270	(cons name sym)))
	271	names syms)
	272	(((names . syms) ...)
	273	(list
	274	(build-cps-cont
	275	(label ($kargs names syms
	276	,(visit-term body label))))))))
8320f504	277	(($ $kfun src meta self tail clause)
3269e1b6 AW	278	(list
3269e1b6 AW	279	(build-cps-cont
8320f504	280	(label ($kfun src meta self ,tail
3269e1b6 AW	281	,(and clause (visit-cont clause)))))))
	282	(($ $kclause arity body alternate)
	283	(list
	284	(build-cps-cont
	285	(label ($kclause ,arity
	286	,(visit-cont body)
	287	,(and alternate
	288	(visit-cont alternate)))))))
	289	(($ $kreceive ($ $arity req () rest () #f) kargs)
	290	(let ((defs (vector-ref defs (label->idx label))))
	291	(if (and-map value-live? defs)
	292	(list (build-cps-cont (label ,cont)))
	293	(let-fresh (adapt) ()
	294	(list (make-adaptor adapt kargs defs)
	295	(build-cps-cont
	296	(label ($kreceive req rest adapt))))))))
	297	(_ (list (build-cps-cont (label ,cont))))))))
	298	(define (visit-conts conts)
	299	(append-map visit-cont* conts))
	300	(define (visit-term term term-k)
	301	(match term
	302	(($ $letk conts body)
	303	(let ((body (visit-term body term-k)))
	304	(match (visit-conts conts)
	305	(() body)
	306	(conts (build-cps-term ($letk ,conts ,body))))))
	307	(($ $letrec names syms funs body)
	308	(let ((body (visit-term body term-k)))
	309	(match (filter-map
	310	(lambda (name sym fun)
	311	(and (value-live? sym)
a0329d01 AW	312	(match fun
	313	(($ $fun free body)
	314	(list name
	315	sym
	316	(build-cps-exp
	317	($fun free ,(visit-fun body))))))))
3269e1b6 AW	318	names syms funs)
	319	(() body)
	320	(((names syms funs) ...)
	321	(build-cps-term
	322	($letrec names syms funs ,body))))))
	323	(($ $continue k src ($ $values args))
	324	(match (vector-ref defs (label->idx term-k))
	325	(#f term)
	326	(defs
	327	(let ((args (filter-map (lambda (use def)
	328	(and (value-live? def) use))
	329	args defs)))
	330	(build-cps-term
	331	($continue k src ($values args)))))))
	332	(($ $continue k src exp)
	333	(if (bitvector-ref live-conts (label->idx term-k))
	334	(rewrite-cps-term exp
a0329d01 AW	335	(($ $fun free body)
a0329d01 AW	336	($continue k src ($fun free ,(visit-fun body))))
3269e1b6 AW	337	(_
	338	,(match (vector-ref defs (label->idx term-k))
	339	((or #f ((? value-live?) ...))
828ed944	340	(build-cps-term
3269e1b6 AW	341	($continue k src ,exp)))
	342	(syms
	343	(let-fresh (adapt) ()
	344	(build-cps-term
	345	($letk (,(make-adaptor adapt k syms))
	346	($continue adapt src ,exp))))))))
	347	(build-cps-term ($continue k src ($values ())))))))
a0329d01	348	(visit-cont fun))))
3269e1b6 AW	349	(visit-fun fun))
	350
	351	(define (eliminate-dead-code fun)
cc8eb195 AW	352	(call-with-values (lambda () (renumber fun))
	353	(lambda (fun nlabels nvars)
	354	(parameterize ((label-counter nlabels)
	355	(var-counter nvars))
	356	(call-with-values (lambda () (compute-live-code fun))
	357	(lambda (fun-data-table live-vars)
	358	(process-eliminations fun fun-data-table live-vars)))))))