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