basis/compiler/tree/dead-code/simple/simple.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors words assocs sequences arrays namespaces
   4 fry locals definitions classes.algebra
   5 stack-checker.state
   6 stack-checker.backend
   7 compiler.tree
   8 compiler.tree.propagation.info
   9 compiler.tree.dead-code.liveness ;
  10 IN: compiler.tree.dead-code.simple
  11
  12 : flushable? ( word -- ? )
  13     [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
  14
  15 : flushable-call? ( #call -- ? )
  16     dup word>> dup flushable? [
  17         "input-classes" word-prop dup [
  18             [ node-input-infos ] dip
  19             [ [ class>> ] dip class<= ] 2all?
  20         ] [ 2drop t ] if
  21     ] [ 2drop f ] if ;
  22
  23 M: #call mark-live-values*
  24     dup flushable-call? [ drop ] [ look-at-inputs ] if ;
  25
  26 M: #alien-invoke mark-live-values* look-at-inputs ;
  27
  28 M: #alien-indirect mark-live-values* look-at-inputs ;
  29
  30 M: #return mark-live-values* look-at-inputs ;
  31
  32 : look-at-mapping ( value inputs outputs -- )
  33     [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
  34
  35 M: #copy compute-live-values*
  36     #! If the output of a copy is live, then the corresponding
  37     #! input is live also.
  38     [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
  39
  40 M: #call compute-live-values* nip look-at-inputs ;
  41
  42 M: #>r compute-live-values*
  43     [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
  44
  45 M: #r> compute-live-values*
  46     [ out-d>> ] [ in-r>> ] bi look-at-mapping ;
  47
  48 M: #shuffle compute-live-values*
  49     mapping>> at look-at-value ;
  50
  51 M: #alien-invoke compute-live-values* nip look-at-inputs ;
  52
  53 M: #alien-indirect compute-live-values* nip look-at-inputs ;
  54
  55 : filter-mapping ( assoc -- assoc' )
  56     live-values get '[ drop _ key? ] assoc-filter ;
  57
  58 : filter-corresponding ( new old -- old' )
  59     #! Remove elements from 'old' if the element with the same
  60     #! index in 'new' is dead.
  61     zip filter-mapping values ;
  62
  63 : filter-live ( values -- values' )
  64     [ live-value? ] filter ;
  65
  66 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
  67     inputs
  68     outputs
  69     outputs
  70     mapping-keys
  71     mapping-values
  72     filter-corresponding zip #shuffle ; inline
  73
  74 :: drop-dead-values ( outputs -- #shuffle )
  75     [let* | new-outputs [ outputs make-values ]
  76             live-outputs [ outputs filter-live ] |
  77         new-outputs
  78         live-outputs
  79         outputs
  80         new-outputs
  81         drop-values
  82     ] ;
  83
  84 : drop-dead-outputs ( node -- #shuffle )
  85     dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
  86
  87 : some-outputs-dead? ( #call -- ? )
  88     out-d>> [ live-value? not ] contains? ;
  89
  90 : maybe-drop-dead-outputs ( node -- nodes )
  91     dup some-outputs-dead? [
  92         dup drop-dead-outputs 2array
  93     ] when ;
  94
  95 M: #introduce remove-dead-code* ( #introduce -- nodes )
  96     maybe-drop-dead-outputs ;
  97
  98 M: #>r remove-dead-code*
  99     [ filter-live ] change-out-r
 100     [ filter-live ] change-in-d
 101     dup in-d>> empty? [ drop f ] when ;
 102
 103 M: #r> remove-dead-code*
 104     [ filter-live ] change-out-d
 105     [ filter-live ] change-in-r
 106     dup in-r>> empty? [ drop f ] when ;
 107
 108 M: #push remove-dead-code*
 109     dup out-d>> first live-value? [ drop f ] unless ;
 110
 111 : dead-flushable-call? ( #call -- ? )
 112     dup flushable-call? [
 113         out-d>> [ live-value? not ] all?
 114     ] [ drop f ] if ;
 115
 116 : remove-flushable-call ( #call -- node )
 117     [ word>> flushed-dependency depends-on ]
 118     [ in-d>> #drop remove-dead-code* ]
 119     bi ;
 120
 121 M: #call remove-dead-code*
 122     dup dead-flushable-call?
 123     [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
 124
 125 M: #shuffle remove-dead-code*
 126     [ filter-live ] change-in-d
 127     [ filter-live ] change-out-d
 128     [ filter-mapping ] change-mapping
 129     dup in-d>> empty? [ drop f ] when ;
 130
 131 M: #copy remove-dead-code*
 132     [ in-d>> ] [ out-d>> ] bi
 133     2dup swap zip #shuffle
 134     remove-dead-code* ;
 135
 136 M: #terminate remove-dead-code*
 137     [ filter-live ] change-in-d
 138     [ filter-live ] change-in-r ;
 139
 140 M: #alien-invoke remove-dead-code*
 141     maybe-drop-dead-outputs ;
 142
 143 M: #alien-indirect remove-dead-code*
 144     maybe-drop-dead-outputs ;