[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)
  #:export (eliminate-dead-code))

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

(define (compute-cont-vector cfa cont-table)
  (let ((v (make-vector (cfa-k-count cfa) #f)))
    (let lp ((n 0))
      (when (< n (vector-length v))
        (vector-set! v n (lookup-cont (cfa-k-sym cfa n) cont-table))
        (lp (1+ n))))
    v))

(define (compute-defs cfa contv)
  (define (cont-defs k)
    (match (vector-ref contv (cfa-k-idx cfa k))
      (($ $kargs names syms) syms)
      (_ #f)))
  (let ((defs (make-vector (vector-length contv) #f)))
    (let lp ((n 0))
      (when (< n (vector-length contv))
        (vector-set!
         defs
         n
         (match (vector-ref contv n)
           (($ $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)
           (($ $kentry self) (list self))
           (($ $ktail) #f)))
        (lp (1+ n))))
    defs))

(define (compute-live-code fun)
  (let ((fun-data-table (make-hash-table))
        (live-vars (make-hash-table))
        (dfg (compute-dfg fun #:global? #t))
        (changed? #f))
    (define (mark-live! sym)
      (unless (value-live? sym)
        (set! changed? #t)
        (hashq-set! live-vars sym #t)))
    (define (value-live? sym)
      (hashq-ref live-vars sym))
    (define (ensure-fun-data fun)
      (or (hashq-ref fun-data-table fun)
          (let* ((cfa (analyze-control-flow fun dfg))
                 (effects (compute-effects cfa dfg))
                 (contv (compute-cont-vector cfa (dfg-cont-table dfg)))
                 (live-conts (make-bitvector (cfa-k-count cfa) #f))
                 (defs (compute-defs cfa contv))
                 (fun-data (make-fun-data cfa effects contv live-conts defs)))
            (hashq-set! fun-data-table fun fun-data)
            (set! changed? #t)
            fun-data)))
    (define (visit-fun fun)
      (match (ensure-fun-data fun)
        (($ $fun-data cfa effects contv live-conts defs)
         (define (visit-grey-exp n)
           (let ((defs (vector-ref defs n)))
             (cond
              ((not defs) #t)
              ((not (effect-free? (exclude-effects (vector-ref effects n)
                                                   &allocation)))
               #t)
              (else
               (or-map value-live? defs)))))
         (let lp ((n (1- (cfa-k-count cfa))))
           (unless (< n 0)
             (let ((cont (vector-ref contv n)))
               (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)
                                     (visit-fun fun)))
                                 syms funs))
                      (($ $continue k src exp)
                       (unless (bitvector-ref live-conts n)
                         (when (visit-grey-exp n)
                           (set! changed? #t)
                           (bitvector-set! live-conts n #t)))
                       (when (bitvector-ref live-conts n)
                         (match exp
                           ((or ($ $void) ($ $const) ($ $prim))
                            #f)
                           ((and fun ($ $fun))
                            (visit-fun fun))
                           (($ $prompt escape? tag handler)
                            (mark-live! tag))
                           (($ $call 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))
                 (($ $kentry self tail clauses)
                  (mark-live! self))
                 (($ $ktail) #f))
               (lp (1- n))))))))
    (let lp ()
      (set! changed? #f)
      (visit-fun fun)
      (when changed? (lp)))
    (values fun-data-table live-vars)))

(define (eliminate-dead-code fun)
  (call-with-values (lambda () (compute-live-code fun))
    (lambda (fun-data-table live-vars)
      (define (value-live? sym)
        (hashq-ref live-vars sym))
      (define (make-adaptor name k defs)
        (let* ((names (map (lambda (_) 'tmp) defs))
               (syms (map (lambda (_) (gensym "tmp")) 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 cfa effects contv live-conts defs)
           (define (must-visit-cont cont)
             (match (visit-cont cont)
               ((cont) cont)
               (conts (error "cont must be reachable" cont conts))))
           (define (visit-cont cont)
             (match cont
               (($ $cont sym cont)
                (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
                  (#f '())
                  (n
                   (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
                            (sym ($kargs names syms
                                   ,(visit-term body n))))))))
                     (($ $kentry self tail clauses)
                      (list
                       (build-cps-cont
                         (sym ($kentry self ,tail
                                ,(visit-conts clauses))))))
                     (($ $kclause arity body)
                      (list
                       (build-cps-cont
                         (sym ($kclause ,arity
                                ,(must-visit-cont body))))))
                     (($ $kreceive ($ $arity req () rest () #f) kargs)
                      (let ((defs (vector-ref defs n)))
                        (if (and-map value-live? defs)
                            (list (build-cps-cont (sym ,cont)))
                            (let-gensyms (adapt)
                              (list (make-adaptor adapt kargs defs)
                                    (build-cps-cont
                                      (sym ($kreceive req rest adapt))))))))
                     (_ (list (build-cps-cont (sym ,cont))))))))))
           (define (visit-conts conts)
             (append-map visit-cont conts))
           (define (visit-term term term-k-idx)
             (match term
               (($ $letk conts body)
                (let ((body (visit-term body term-k-idx)))
                  (match (visit-conts conts)
                    (() body)
                    (conts (build-cps-term ($letk ,conts ,body))))))
               (($ $letrec names syms funs body)
                (let ((body (visit-term body term-k-idx)))
                  (match (filter-map
                          (lambda (name sym fun)
                            (and (value-live? sym)
                                 (list name sym (visit-fun fun))))
                          names syms funs)
                    (() body)
                    (((names syms funs) ...)
                     (build-cps-term
                       ($letrec names syms funs ,body))))))
               (($ $continue k src ($ $values args))
                (match (vector-ref defs term-k-idx)
                  (#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 term-k-idx)
                    (rewrite-cps-term exp
                      (($ $fun) ($continue k src ,(visit-fun exp)))
                      (_
                       ,(match (vector-ref defs term-k-idx)
                          ((or #f ((? value-live?) ...))
                           (build-cps-term
                             ($continue k src ,exp)))
                          (syms
                           (let-gensyms (adapt)
                             (build-cps-term
                               ($letk (,(make-adaptor adapt k syms))
                                 ($continue adapt src ,exp))))))))
                    (build-cps-term ($continue k src ($values ())))))))
           (rewrite-cps-exp fun
             (($ $fun src meta free body)
              ($fun src meta free ,(must-visit-cont body)))))))
      (visit-fun fun))))
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)
	42	#:export (eliminate-dead-code))
	43
	44	(define-record-type $fun-data
	45	(make-fun-data cfa effects conts live-conts defs)
	46	fun-data?
	47	(cfa fun-data-cfa)
	48	(effects fun-data-effects)
	49	(conts fun-data-conts)
	50	(live-conts fun-data-live-conts)
	51	(defs fun-data-defs))
	52
	53	(define (compute-cont-vector cfa cont-table)
	54	(let ((v (make-vector (cfa-k-count cfa) #f)))
	55	(let lp ((n 0))
	56	(when (< n (vector-length v))
	57	(vector-set! v n (lookup-cont (cfa-k-sym cfa n) cont-table))
	58	(lp (1+ n))))
	59	v))
	60
	61	(define (compute-defs cfa contv)
	62	(define (cont-defs k)
	63	(match (vector-ref contv (cfa-k-idx cfa k))
	64	(($ $kargs names syms) syms)
65	(_ #f)))
66	(let ((defs (make-vector (vector-length contv) #f)))
67	(let lp ((n 0))
68	(when (< n (vector-length contv))
69	(vector-set!
70	defs
71	n
72	(match (vector-ref contv n)
73	(($ $kargs _ _ body)
74	(match (find-call body)
75	(($ $continue k) (cont-defs k))))
36527695	76	(($ $kreceive arity kargs)
305cccb4 AW	77	(cont-defs kargs))
	78	(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
	79	syms)
	80	(($ $kif) #f)
	81	(($ $kentry self) (list self))
	82	(($ $ktail) #f)))
	83	(lp (1+ n))))
	84	defs))
	85
	86	(define (compute-live-code fun)
	87	(let ((fun-data-table (make-hash-table))
	88	(live-vars (make-hash-table))
	89	(dfg (compute-dfg fun #:global? #t))
	90	(changed? #f))
	91	(define (mark-live! sym)
	92	(unless (value-live? sym)
	93	(set! changed? #t)
	94	(hashq-set! live-vars sym #t)))
	95	(define (value-live? sym)
	96	(hashq-ref live-vars sym))
	97	(define (ensure-fun-data fun)
	98	(or (hashq-ref fun-data-table fun)
	99	(let* ((cfa (analyze-control-flow fun dfg))
	100	(effects (compute-effects cfa dfg))
	101	(contv (compute-cont-vector cfa (dfg-cont-table dfg)))
	102	(live-conts (make-bitvector (cfa-k-count cfa) #f))
	103	(defs (compute-defs cfa contv))
	104	(fun-data (make-fun-data cfa effects contv live-conts defs)))
	105	(hashq-set! fun-data-table fun fun-data)
	106	(set! changed? #t)
	107	fun-data)))
	108	(define (visit-fun fun)
	109	(match (ensure-fun-data fun)
	110	(($ $fun-data cfa effects contv live-conts defs)
	111	(define (visit-grey-exp n)
	112	(let ((defs (vector-ref defs n)))
	113	(cond
	114	((not defs) #t)
	115	((not (effect-free? (exclude-effects (vector-ref effects n)
	116	&allocation)))
	117	#t)
	118	(else
	119	(or-map value-live? defs)))))
	120	(let lp ((n (1- (cfa-k-count cfa))))
	121	(unless (< n 0)
	122	(let ((cont (vector-ref contv n)))
	123	(match cont
	124	(($ $kargs _ _ body)
	125	(let lp ((body body))
	126	(match body
	127	(($ $letk conts body) (lp body))
	128	(($ $letrec names syms funs body)
	129	(lp body)
	130	(for-each (lambda (sym fun)
	131	(when (value-live? sym)
	132	(visit-fun fun)))
	133	syms funs))
	134	(($ $continue k src exp)
	135	(unless (bitvector-ref live-conts n)
	136	(when (visit-grey-exp n)
	137	(set! changed? #t)
	138	(bitvector-set! live-conts n #t)))
	139	(when (bitvector-ref live-conts n)
	140	(match exp
141	((or ($ $void) ($ $const) ($ $prim))
142	#f)
143	((and fun ($ $fun))
144	(visit-fun fun))
145	(($ $prompt escape? tag handler)
146	(mark-live! tag))
147	(($ $call proc args)
148	(mark-live! proc)
149	(for-each mark-live! args))
150	(($ $primcall name args)
151	(for-each mark-live! args))
152	(($ $values args)
153	(match (vector-ref defs n)
154	(#f (for-each mark-live! args))
155	(defs (for-each (lambda (use def)
156	(when (value-live? def)
157	(mark-live! use)))
158	args defs))))))))))
36527695	159	(($ $kreceive arity kargs) #f)
305cccb4 AW	160	(($ $kif) #f)
	161	(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
	162	(for-each mark-live! syms))
	163	(($ $kentry self tail clauses)
	164	(mark-live! self))
	165	(($ $ktail) #f))
	166	(lp (1- n))))))))
	167	(let lp ()
	168	(set! changed? #f)
	169	(visit-fun fun)
	170	(when changed? (lp)))
	171	(values fun-data-table live-vars)))
	172
	173	(define (eliminate-dead-code fun)
	174	(call-with-values (lambda () (compute-live-code fun))
	175	(lambda (fun-data-table live-vars)
	176	(define (value-live? sym)
	177	(hashq-ref live-vars sym))
	178	(define (make-adaptor name k defs)
	179	(let* ((names (map (lambda (_) 'tmp) defs))
	180	(syms (map (lambda (_) (gensym "tmp")) defs))
	181	(live (filter-map (lambda (def sym)
	182	(and (value-live? def)
	183	sym))
	184	defs syms)))
	185	(build-cps-cont
	186	(name ($kargs names syms
	187	($continue k #f ($values live)))))))
	188	(define (visit-fun fun)
	189	(match (hashq-ref fun-data-table fun)
	190	(($ $fun-data cfa effects contv live-conts defs)
	191	(define (must-visit-cont cont)
	192	(match (visit-cont cont)
	193	((cont) cont)
	194	(conts (error "cont must be reachable" cont conts))))
	195	(define (visit-cont cont)
	196	(match cont
	197	(($ $cont sym cont)
	198	(match (cfa-k-idx cfa sym #:default (lambda (k) #f))
	199	(#f '())
	200	(n
	201	(match cont
	202	(($ $kargs names syms body)
	203	(match (filter-map (lambda (name sym)
	204	(and (value-live? sym)
	205	(cons name sym)))
	206	names syms)
	207	(((names . syms) ...)
	208	(list
	209	(build-cps-cont
	210	(sym ($kargs names syms
	211	,(visit-term body n))))))))
	212	(($ $kentry self tail clauses)
	213	(list
	214	(build-cps-cont
	215	(sym ($kentry self ,tail
	216	,(visit-conts clauses))))))
	217	(($ $kclause arity body)
	218	(list
	219	(build-cps-cont
	220	(sym ($kclause ,arity
	221	,(must-visit-cont body))))))
36527695	222	(($ $kreceive ($ $arity req () rest () #f) kargs)
305cccb4 AW	223	(let ((defs (vector-ref defs n)))
	224	(if (and-map value-live? defs)
	225	(list (build-cps-cont (sym ,cont)))
	226	(let-gensyms (adapt)
	227	(list (make-adaptor adapt kargs defs)
	228	(build-cps-cont
36527695	229	(sym ($kreceive req rest adapt))))))))
305cccb4 AW	230	(_ (list (build-cps-cont (sym ,cont))))))))))
	231	(define (visit-conts conts)
	232	(append-map visit-cont conts))
	233	(define (visit-term term term-k-idx)
	234	(match term
	235	(($ $letk conts body)
	236	(let ((body (visit-term body term-k-idx)))
	237	(match (visit-conts conts)
	238	(() body)
	239	(conts (build-cps-term ($letk ,conts ,body))))))
	240	(($ $letrec names syms funs body)
	241	(let ((body (visit-term body term-k-idx)))
	242	(match (filter-map
	243	(lambda (name sym fun)
	244	(and (value-live? sym)
	245	(list name sym (visit-fun fun))))
	246	names syms funs)
	247	(() body)
	248	(((names syms funs) ...)
	249	(build-cps-term
	250	($letrec names syms funs ,body))))))
	251	(($ $continue k src ($ $values args))
	252	(match (vector-ref defs term-k-idx)
	253	(#f term)
	254	(defs
	255	(let ((args (filter-map (lambda (use def)
	256	(and (value-live? def) use))
	257	args defs)))
	258	(build-cps-term
	259	($continue k src ($values args)))))))
	260	(($ $continue k src exp)
	261	(if (bitvector-ref live-conts term-k-idx)
	262	(rewrite-cps-term exp
	263	(($ $fun) ($continue k src ,(visit-fun exp)))
	264	(_
	265	,(match (vector-ref defs term-k-idx)
	266	((or #f ((? value-live?) ...))
	267	(build-cps-term
	268	($continue k src ,exp)))
	269	(syms
	270	(let-gensyms (adapt)
	271	(build-cps-term
	272	($letk (,(make-adaptor adapt k syms))
	273	($continue adapt src ,exp))))))))
	274	(build-cps-term ($continue k src ($values ())))))))
	275	(rewrite-cps-exp fun
	276	(($ $fun src meta free body)
	277	($fun src meta free ,(must-visit-cont body)))))))
	278	(visit-fun fun))))