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

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