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

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