module/language/cps/dce.scm

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