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