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   #: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            (($ $kif) #f)
  78            (($ $kfun src meta self) (list self))
  79            (($ $ktail) #f)))
  80         (lp (1+ n))))
  81     defs))
  82
  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))
  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)))))))
  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))
 106                         (visit-primcall lidx fx name args))
 107                        (($ $continue k src ($ $branch _ ($primcall name args)))
 108                         (visit-primcall lidx fx name args))
 109                        (_ #f)))
 110                     (_ #f)))))
 111             (lp (1+ lidx)))))))))
 112
 113 (define (compute-live-code fun)
 114   (let* ((fun-data-table (make-hash-table))
 115          (dfg (compute-dfg fun #:global? #t))
 116          (live-vars (make-bitvector (dfg-var-count dfg) #f))
 117          (changed? #f))
 118     (define (mark-live! var)
 119       (unless (value-live? var)
 120         (set! changed? #t)
 121         (bitvector-set! live-vars var #t)))
 122     (define (value-live? var)
 123       (bitvector-ref live-vars var))
 124     (define (ensure-fun-data fun)
 125       (or (hashq-ref fun-data-table fun)
 126           (call-with-values (lambda ()
 127                               ((make-local-cont-folder label-count max-label)
 128                                (lambda (k cont label-count max-label)
 129                                  (values (1+ label-count) (max k max-label)))
 130                                fun 0 -1))
 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))
 136                      (fun-data (make-fun-data
 137                                 min-label effects live-conts defs)))
 138                 (elide-type-checks! fun dfg effects min-label label-count)
 139                 (hashq-set! fun-data-table fun fun-data)
 140                 (set! changed? #t)
 141                 fun-data)))))
 142     (define (visit-fun fun)
 143       (match (ensure-fun-data fun)
 144         (($ $fun-data min-label effects live-conts defs)
 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)))
 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)
 171               ;; Does this expression cause all effects?  If so, it's
 172               ;; definitely live.
 173               (causes-all-effects? fx)
 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)
 177               ;; We might have a setter.  If the object being assigned
 178               ;; to is live or was not created by us, then this
 179               ;; expression is live.  Otherwise the value is still dead.
 180               (and (causes-effect? fx &write)
 181                    (match exp
 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))))
 189                      (_ #t))))))
 190          (let lp ((n (1- (vector-length effects))))
 191            (unless (< n 0)
 192              (let ((cont (lookup-cont (idx->label n) dfg)))
 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)
 202                                      (match fun
 203                                        (($ $fun free body)
 204                                         (visit-fun body)))))
 205                                  syms funs))
 206                       (($ $continue k src exp)
 207                        (unless (bitvector-ref live-conts n)
 208                          (when (visit-grey-exp n exp)
 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)
 215                            (($ $fun free body)
 216                             (visit-fun body))
 217                            (($ $prompt escape? tag handler)
 218                             (mark-live! tag))
 219                            (($ $call proc args)
 220                             (mark-live! proc)
 221                             (for-each mark-live! args))
 222                            (($ $callk k proc args)
 223                             (mark-live! proc)
 224                             (for-each mark-live! args))
 225                            (($ $primcall name args)
 226                             (for-each mark-live! args))
 227                            (($ $branch k ($ $primcall name args))
 228                             (for-each mark-live! args))
 229                            (($ $branch k ($ $values (arg)))
 230                             (mark-live! arg))
 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))))))))))
 238                  (($ $kreceive arity kargs) #f)
 239                  (($ $kif) #f)
 240                  (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
 241                   (for-each mark-live! syms))
 242                  (($ $kfun src meta self)
 243                   (mark-live! self))
 244                  (($ $ktail) #f))
 245                (lp (1- n))))))))
 246     (unless (= (dfg-var-count dfg) (var-counter))
 247       (error "internal error" (dfg-var-count dfg) (var-counter)))
 248     (let lp ()
 249       (set! changed? #f)
 250       (visit-fun fun)
 251       (when changed? (lp)))
 252     (values fun-data-table live-vars)))
 253
 254 (define (process-eliminations fun fun-data-table live-vars)
 255   (define (value-live? var)
 256     (bitvector-ref live-vars var))
 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)
 269       (($ $fun-data min-label effects live-conts defs)
 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))))))))
 288               (($ $kfun src meta self tail clause)
 289                (list
 290                 (build-cps-cont
 291                   (label ($kfun src meta self ,tail
 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)
 323                              (match fun
 324                                (($ $fun free body)
 325                                 (list name
 326                                       sym
 327                                       (build-cps-exp
 328                                         ($fun free ,(visit-fun body))))))))
 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
 346                   (($ $fun free body)
 347                    ($continue k src ($fun free ,(visit-fun body))))
 348                   (_
 349                    ,(match (vector-ref defs (label->idx term-k))
 350                       ((or #f ((? value-live?) ...))
 351                        (build-cps-term
 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 ())))))))
 359        (visit-cont fun))))
 360   (visit-fun fun))
 361
 362 (define (eliminate-dead-code fun)
 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)))))))