[bpt/guile.git] / module / language / cps / dce.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:
;;;
;;; 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 src exp)
               (match exp
                 (($ $branch) #f)
                 (_ (cont-defs k))))))
           (($ $kreceive arity kargs)
            (cont-defs kargs))
           (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
            syms)
           (($ $kfun src meta self) (list self))
           (($ $ktail) #f)))
        (lp (1+ n))))
    defs))

(define (elide-type-checks! fun dfg effects min-label label-count)
  (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))
       (define (visit-primcall lidx fx name args)
         (when (primcall-types-check? typev (idx->label lidx) name args)
           (vector-set! effects lidx
                        (logand fx (lognot &type-check)))))
       (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))
                       (visit-primcall lidx fx name args))
                      (($ $continue k src ($ $branch _ ($primcall name args)))
                       (visit-primcall lidx fx name args))
                      (_ #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 ($ $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))
                           (($ $branch k ($ $primcall name args))
                            (for-each mark-live! args))
                           (($ $branch k ($ $values (arg)))
                            (mark-live! arg))
                           (($ $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)
                 (($ $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)
305cccb4 AW	2
a9ec16f9	3	;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
305cccb4 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	;;; 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)
305cccb4 AW	68	(match (find-call body)
92805e21 AW	69	(($ $continue k src exp)
	70	(match exp
	71	(($ $branch) #f)
	72	(_ (cont-defs k))))))
36527695	73	(($ $kreceive arity kargs)
305cccb4 AW	74	(cont-defs kargs))
	75	(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
	76	syms)
8320f504	77	(($ $kfun src meta self) (list self))
305cccb4 AW	78	(($ $ktail) #f)))
	79	(lp (1+ n))))
	80	defs))
	81
3be43fb7	82	(define (elide-type-checks! fun dfg effects min-label label-count)
0ad455ca AW	83	(match fun
	84	(($ $cont kfun ($ $kfun src meta min-var))
	85	(let ((typev (infer-types fun dfg)))
	86	(define (idx->label idx) (+ idx min-label))
	87	(define (var->idx var) (- var min-var))
	88	(define (visit-primcall lidx fx name args)
	89	(when (primcall-types-check? typev (idx->label lidx) name args)
	90	(vector-set! effects lidx
	91	(logand fx (lognot &type-check)))))
	92	(let lp ((lidx 0))
	93	(when (< lidx label-count)
	94	(let ((fx (vector-ref effects lidx)))
	95	(unless (causes-all-effects? fx)
	96	(when (causes-effect? fx &type-check)
	97	(match (lookup-cont (idx->label lidx) dfg)
	98	(($ $kargs _ _ term)
	99	(match (find-call term)
	100	(($ $continue k src ($ $primcall name args))
	101	(visit-primcall lidx fx name args))
	102	(($ $continue k src ($ $branch _ ($primcall name args)))
	103	(visit-primcall lidx fx name args))
	104	(_ #f)))
	105	(_ #f)))))
	106	(lp (1+ lidx))))))))
40b36bbf	107
305cccb4	108	(define (compute-live-code fun)
3269e1b6	109	(let* ((fun-data-table (make-hash-table))
a0329d01	110	(dfg (compute-dfg fun #:global? #t))
0912202a	111	(live-vars (make-bitvector (dfg-var-count dfg) #f))
3269e1b6	112	(changed? #f))
0912202a AW	113	(define (mark-live! var)
0912202a AW	114	(unless (value-live? var)
305cccb4	115	(set! changed? #t)
0912202a AW	116	(bitvector-set! live-vars var #t)))
	117	(define (value-live? var)
	118	(bitvector-ref live-vars var))
305cccb4 AW	119	(define (ensure-fun-data fun)
305cccb4 AW	120	(or (hashq-ref fun-data-table fun)
3269e1b6	121	(call-with-values (lambda ()
405805fb	122	((make-local-cont-folder label-count max-label)
a0329d01 AW	123	(lambda (k cont label-count max-label)
	124	(values (1+ label-count) (max k max-label)))
	125	fun 0 -1))
3269e1b6 AW	126	(lambda (label-count max-label)
	127	(let* ((min-label (- (1+ max-label) label-count))
	128	(effects (compute-effects dfg min-label label-count))
	129	(live-conts (make-bitvector label-count #f))
	130	(defs (compute-defs dfg min-label label-count))
ce1dbe8c AW	131	(fun-data (make-fun-data
ce1dbe8c AW	132	min-label effects live-conts defs)))
3be43fb7	133	(elide-type-checks! fun dfg effects min-label label-count)
3269e1b6 AW	134	(hashq-set! fun-data-table fun fun-data)
	135	(set! changed? #t)
	136	fun-data)))))
305cccb4 AW	137	(define (visit-fun fun)
305cccb4 AW	138	(match (ensure-fun-data fun)
ce1dbe8c	139	(($ $fun-data min-label effects live-conts defs)
3be43fb7 AW	140	(define (idx->label idx) (+ idx min-label))
	141	(define (label->idx label) (- label min-label))
	142	(define (known-allocation? var dfg)
	143	(match (lookup-predecessors (lookup-def var dfg) dfg)
	144	((def-exp-k)
	145	(match (lookup-cont def-exp-k dfg)
	146	(($ $kargs _ _ term)
	147	(match (find-call term)
	148	(($ $continue k src ($ $values (var)))
	149	(known-allocation? var dfg))
	150	(($ $continue k src ($ $primcall))
	151	(let ((kidx (label->idx def-exp-k)))
	152	(and (>= kidx 0)
	153	(causes-effect? (vector-ref effects kidx)
	154	&allocation))))
	155	(_ #f)))
	156	(_ #f)))
	157	(_ #f)))
40b36bbf AW	158	(define (visit-grey-exp n exp)
	159	(let ((defs (vector-ref defs n))
	160	(fx (vector-ref effects n)))
	161	(or
	162	;; No defs; perhaps continuation is $ktail.
	163	(not defs)
	164	;; Do we have a live def?
	165	(or-map value-live? defs)
5d25fdae AW	166	;; Does this expression cause all effects? If so, it's
	167	;; definitely live.
	168	(causes-all-effects? fx)
3be43fb7 AW	169	;; Does it cause a type check, but we weren't able to
	170	;; prove that the types check?
	171	(causes-effect? fx &type-check)
5d25fdae	172	;; We might have a setter. If the object being assigned
3be43fb7 AW	173	;; to is live or was not created by us, then this
3be43fb7 AW	174	;; expression is live. Otherwise the value is still dead.
5d25fdae AW	175	(and (causes-effect? fx &write)
5d25fdae AW	176	(match exp
3be43fb7 AW	177	(($ $primcall
	178	(or 'vector-set! 'vector-set!/immediate
	179	'set-car! 'set-cdr!
	180	'box-set!)
	181	(obj . _))
	182	(or (value-live? obj)
	183	(not (known-allocation? obj dfg))))
5d25fdae	184	(_ #t))))))
ce1dbe8c	185	(let lp ((n (1- (vector-length effects))))
305cccb4	186	(unless (< n 0)
3269e1b6	187	(let ((cont (lookup-cont (idx->label n) dfg)))
305cccb4 AW	188	(match cont
	189	(($ $kargs _ _ body)
	190	(let lp ((body body))
	191	(match body
	192	(($ $letk conts body) (lp body))
	193	(($ $letrec names syms funs body)
	194	(lp body)
	195	(for-each (lambda (sym fun)
	196	(when (value-live? sym)
a0329d01 AW	197	(match fun
	198	(($ $fun free body)
	199	(visit-fun body)))))
305cccb4 AW	200	syms funs))
	201	(($ $continue k src exp)
	202	(unless (bitvector-ref live-conts n)
40b36bbf	203	(when (visit-grey-exp n exp)
305cccb4 AW	204	(set! changed? #t)
	205	(bitvector-set! live-conts n #t)))
	206	(when (bitvector-ref live-conts n)
	207	(match exp
a9ec16f9	208	((or ($ $const) ($ $prim))
305cccb4	209	#f)
a0329d01 AW	210	(($ $fun free body)
a0329d01 AW	211	(visit-fun body))
305cccb4 AW	212	(($ $prompt escape? tag handler)
	213	(mark-live! tag))
	214	(($ $call proc args)
	215	(mark-live! proc)
	216	(for-each mark-live! args))
b3ae2b50 AW	217	(($ $callk k proc args)
	218	(mark-live! proc)
	219	(for-each mark-live! args))
305cccb4 AW	220	(($ $primcall name args)
305cccb4 AW	221	(for-each mark-live! args))
92805e21 AW	222	(($ $branch k ($ $primcall name args))
	223	(for-each mark-live! args))
	224	(($ $branch k ($ $values (arg)))
	225	(mark-live! arg))
305cccb4 AW	226	(($ $values args)
	227	(match (vector-ref defs n)
	228	(#f (for-each mark-live! args))
	229	(defs (for-each (lambda (use def)
	230	(when (value-live? def)
	231	(mark-live! use)))
	232	args defs))))))))))
36527695	233	(($ $kreceive arity kargs) #f)
305cccb4 AW	234	(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
305cccb4 AW	235	(for-each mark-live! syms))
8320f504	236	(($ $kfun src meta self)
305cccb4 AW	237	(mark-live! self))
	238	(($ $ktail) #f))
	239	(lp (1- n))))))))
0912202a AW	240	(unless (= (dfg-var-count dfg) (var-counter))
0912202a AW	241	(error "internal error" (dfg-var-count dfg) (var-counter)))
305cccb4 AW	242	(let lp ()
	243	(set! changed? #f)
	244	(visit-fun fun)
	245	(when changed? (lp)))
	246	(values fun-data-table live-vars)))
	247
3269e1b6	248	(define (process-eliminations fun fun-data-table live-vars)
0912202a AW	249	(define (value-live? var)
0912202a AW	250	(bitvector-ref live-vars var))
3269e1b6 AW	251	(define (make-adaptor name k defs)
	252	(let* ((names (map (lambda (_) 'tmp) defs))
	253	(syms (map (lambda (_) (fresh-var)) defs))
	254	(live (filter-map (lambda (def sym)
	255	(and (value-live? def)
	256	sym))
	257	defs syms)))
	258	(build-cps-cont
	259	(name ($kargs names syms
	260	($continue k #f ($values live)))))))
	261	(define (visit-fun fun)
	262	(match (hashq-ref fun-data-table fun)
ce1dbe8c	263	(($ $fun-data min-label effects live-conts defs)
3269e1b6 AW	264	(define (label->idx label) (- label min-label))
	265	(define (visit-cont cont)
	266	(match (visit-cont* cont)
	267	((cont) cont)))
	268	(define (visit-cont* cont)
	269	(match cont
	270	(($ $cont label cont)
	271	(match cont
	272	(($ $kargs names syms body)
	273	(match (filter-map (lambda (name sym)
	274	(and (value-live? sym)
	275	(cons name sym)))
	276	names syms)
	277	(((names . syms) ...)
	278	(list
	279	(build-cps-cont
	280	(label ($kargs names syms
	281	,(visit-term body label))))))))
8320f504	282	(($ $kfun src meta self tail clause)
3269e1b6 AW	283	(list
3269e1b6 AW	284	(build-cps-cont
8320f504	285	(label ($kfun src meta self ,tail
3269e1b6 AW	286	,(and clause (visit-cont clause)))))))
	287	(($ $kclause arity body alternate)
	288	(list
	289	(build-cps-cont
	290	(label ($kclause ,arity
	291	,(visit-cont body)
	292	,(and alternate
	293	(visit-cont alternate)))))))
	294	(($ $kreceive ($ $arity req () rest () #f) kargs)
	295	(let ((defs (vector-ref defs (label->idx label))))
	296	(if (and-map value-live? defs)
	297	(list (build-cps-cont (label ,cont)))
	298	(let-fresh (adapt) ()
	299	(list (make-adaptor adapt kargs defs)
	300	(build-cps-cont
	301	(label ($kreceive req rest adapt))))))))
	302	(_ (list (build-cps-cont (label ,cont))))))))
	303	(define (visit-conts conts)
	304	(append-map visit-cont* conts))
	305	(define (visit-term term term-k)
	306	(match term
	307	(($ $letk conts body)
	308	(let ((body (visit-term body term-k)))
	309	(match (visit-conts conts)
	310	(() body)
	311	(conts (build-cps-term ($letk ,conts ,body))))))
	312	(($ $letrec names syms funs body)
	313	(let ((body (visit-term body term-k)))
	314	(match (filter-map
	315	(lambda (name sym fun)
	316	(and (value-live? sym)
a0329d01 AW	317	(match fun
	318	(($ $fun free body)
	319	(list name
	320	sym
	321	(build-cps-exp
	322	($fun free ,(visit-fun body))))))))
3269e1b6 AW	323	names syms funs)
	324	(() body)
	325	(((names syms funs) ...)
	326	(build-cps-term
	327	($letrec names syms funs ,body))))))
	328	(($ $continue k src ($ $values args))
	329	(match (vector-ref defs (label->idx term-k))
	330	(#f term)
	331	(defs
	332	(let ((args (filter-map (lambda (use def)
	333	(and (value-live? def) use))
	334	args defs)))
	335	(build-cps-term
	336	($continue k src ($values args)))))))
	337	(($ $continue k src exp)
	338	(if (bitvector-ref live-conts (label->idx term-k))
	339	(rewrite-cps-term exp
a0329d01 AW	340	(($ $fun free body)
a0329d01 AW	341	($continue k src ($fun free ,(visit-fun body))))
3269e1b6 AW	342	(_
	343	,(match (vector-ref defs (label->idx term-k))
	344	((or #f ((? value-live?) ...))
828ed944	345	(build-cps-term
3269e1b6 AW	346	($continue k src ,exp)))
	347	(syms
	348	(let-fresh (adapt) ()
	349	(build-cps-term
	350	($letk (,(make-adaptor adapt k syms))
	351	($continue adapt src ,exp))))))))
	352	(build-cps-term ($continue k src ($values ())))))))
a0329d01	353	(visit-cont fun))))
3269e1b6 AW	354	(visit-fun fun))
	355
	356	(define (eliminate-dead-code fun)
cc8eb195 AW	357	(call-with-values (lambda () (renumber fun))
	358	(lambda (fun nlabels nvars)
	359	(parameterize ((label-counter nlabels)
	360	(var-counter nvars))
	361	(call-with-values (lambda () (compute-live-code fun))
	362	(lambda (fun-data-table live-vars)
	363	(process-eliminations fun fun-data-table live-vars)))))))