module/language/cps/dce.scm

   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))))
  76            (($ $kreceive arity kargs)
  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                            (($ $callk k proc args)
 151                             (mark-live! proc)
 152                             (for-each mark-live! args))
 153                            (($ $primcall name args)
 154                             (for-each mark-live! args))
 155                            (($ $values args)
 156                             (match (vector-ref defs n)
 157                               (#f (for-each mark-live! args))
 158                               (defs (for-each (lambda (use def)
 159                                                 (when (value-live? def)
 160                                                   (mark-live! use)))
 161                                               args defs))))))))))
 162                  (($ $kreceive arity kargs) #f)
 163                  (($ $kif) #f)
 164                  (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
 165                   (for-each mark-live! syms))
 166                  (($ $kentry self tail clauses)
 167                   (mark-live! self))
 168                  (($ $ktail) #f))
 169                (lp (1- n))))))))
 170     (let lp ()
 171       (set! changed? #f)
 172       (visit-fun fun)
 173       (when changed? (lp)))
 174     (values fun-data-table live-vars)))
 175
 176 (define (eliminate-dead-code fun)
 177   (with-fresh-name-state fun
 178     (call-with-values (lambda () (compute-live-code fun))
 179       (lambda (fun-data-table live-vars)
 180         (define (value-live? sym)
 181           (hashq-ref live-vars sym))
 182         (define (make-adaptor name k defs)
 183           (let* ((names (map (lambda (_) 'tmp) defs))
 184                  (syms (map (lambda (_) (gensym "tmp")) defs))
 185                  (live (filter-map (lambda (def sym)
 186                                      (and (value-live? def)
 187                                           sym))
 188                                    defs syms)))
 189             (build-cps-cont
 190               (name ($kargs names syms
 191                       ($continue k #f ($values live)))))))
 192         (define (visit-fun fun)
 193           (match (hashq-ref fun-data-table fun)
 194             (($ $fun-data cfa effects contv live-conts defs)
 195              (define (must-visit-cont cont)
 196                (match (visit-cont cont)
 197                  ((cont) cont)
 198                  (conts (error "cont must be reachable" cont conts))))
 199              (define (visit-cont cont)
 200                (match cont
 201                  (($ $cont sym cont)
 202                   (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
 203                     (#f '())
 204                     (n
 205                      (match cont
 206                        (($ $kargs names syms body)
 207                         (match (filter-map (lambda (name sym)
 208                                              (and (value-live? sym)
 209                                                   (cons name sym)))
 210                                            names syms)
 211                           (((names . syms) ...)
 212                            (list
 213                             (build-cps-cont
 214                               (sym ($kargs names syms
 215                                      ,(visit-term body n))))))))
 216                        (($ $kentry self tail clauses)
 217                         (list
 218                          (build-cps-cont
 219                            (sym ($kentry self ,tail
 220                                   ,(visit-conts clauses))))))
 221                        (($ $kclause arity body)
 222                         (list
 223                          (build-cps-cont
 224                            (sym ($kclause ,arity
 225                                   ,(must-visit-cont body))))))
 226                        (($ $kreceive ($ $arity req () rest () #f) kargs)
 227                         (let ((defs (vector-ref defs n)))
 228                           (if (and-map value-live? defs)
 229                               (list (build-cps-cont (sym ,cont)))
 230                               (let-fresh (adapt) ()
 231                                 (list (make-adaptor adapt kargs defs)
 232                                       (build-cps-cont
 233                                         (sym ($kreceive req rest adapt))))))))
 234                        (_ (list (build-cps-cont (sym ,cont))))))))))
 235              (define (visit-conts conts)
 236                (append-map visit-cont conts))
 237              (define (visit-term term term-k-idx)
 238                (match term
 239                  (($ $letk conts body)
 240                   (let ((body (visit-term body term-k-idx)))
 241                     (match (visit-conts conts)
 242                       (() body)
 243                       (conts (build-cps-term ($letk ,conts ,body))))))
 244                  (($ $letrec names syms funs body)
 245                   (let ((body (visit-term body term-k-idx)))
 246                     (match (filter-map
 247                             (lambda (name sym fun)
 248                               (and (value-live? sym)
 249                                    (list name sym (visit-fun fun))))
 250                             names syms funs)
 251                       (() body)
 252                       (((names syms funs) ...)
 253                        (build-cps-term
 254                          ($letrec names syms funs ,body))))))
 255                  (($ $continue k src ($ $values args))
 256                   (match (vector-ref defs term-k-idx)
 257                     (#f term)
 258                     (defs
 259                       (let ((args (filter-map (lambda (use def)
 260                                                 (and (value-live? def) use))
 261                                               args defs)))
 262                         (build-cps-term
 263                           ($continue k src ($values args)))))))
 264                  (($ $continue k src exp)
 265                   (if (bitvector-ref live-conts term-k-idx)
 266                       (rewrite-cps-term exp
 267                         (($ $fun) ($continue k src ,(visit-fun exp)))
 268                         (_
 269                          ,(match (vector-ref defs term-k-idx)
 270                             ((or #f ((? value-live?) ...))
 271                              (build-cps-term
 272                                ($continue k src ,exp)))
 273                             (syms
 274                              (let-fresh (adapt) ()
 275                                (build-cps-term
 276                                  ($letk (,(make-adaptor adapt k syms))
 277                                    ($continue adapt src ,exp))))))))
 278                       (build-cps-term ($continue k src ($values ())))))))
 279              (rewrite-cps-exp fun
 280                (($ $fun src meta free body)
 281                 ($fun src meta free ,(must-visit-cont body)))))))
 282         (visit-fun fun)))))