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 classes.algebra generic
   5 stack-checker.dependencies
   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 GENERIC: flushable? ( word -- ? )
  13
  14 M: predicate flushable? drop t ;
  15
  16 M: word flushable? "flushable" word-prop ;
  17
  18 M: method-body flushable? "method-generic" word-prop flushable? ;
  19
  20 : flushable-call? ( #call -- ? )
  21     dup word>> dup flushable? [
  22         "input-classes" word-prop dup [
  23             [ node-input-infos ] dip
  24             [ [ class>> ] dip class<= ] 2all?
  25         ] [ 2drop t ] if
  26     ] [ 2drop f ] if ;
  27
  28 M: #call mark-live-values*
  29     dup flushable-call? [ drop ] [ look-at-inputs ] if ;
  30
  31 M: #alien-invoke mark-live-values* look-at-inputs ;
  32
  33 M: #alien-indirect mark-live-values* look-at-inputs ;
  34
  35 M: #return mark-live-values* look-at-inputs ;
  36
  37 : look-at-mapping ( value inputs outputs -- )
  38     [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
  39
  40 M: #copy compute-live-values*
  41     #! If the output of a copy is live, then the corresponding
  42     #! input is live also.
  43     [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
  44
  45 M: #call compute-live-values* nip look-at-inputs ;
  46
  47 M: #shuffle compute-live-values*
  48     mapping>> at look-at-value ;
  49
  50 M: #alien-invoke compute-live-values* nip look-at-inputs ;
  51
  52 M: #alien-indirect compute-live-values* nip look-at-inputs ;
  53
  54 : filter-mapping ( assoc -- assoc' )
  55     live-values get '[ drop _ key? ] assoc-filter ;
  56
  57 : filter-corresponding ( new old -- old' )
  58     #! Remove elements from 'old' if the element with the same
  59     #! index in 'new' is dead.
  60     zip filter-mapping values ;
  61
  62 : filter-live ( values -- values' )
  63     dup empty? [ [ live-value? ] filter ] unless ;
  64
  65 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
  66     inputs
  67     outputs
  68     outputs
  69     mapping-keys
  70     mapping-values
  71     filter-corresponding zip #data-shuffle ; inline
  72
  73 :: drop-dead-values ( outputs -- #shuffle )
  74     outputs make-values :> new-outputs
  75     outputs filter-live :> live-outputs
  76     new-outputs
  77     live-outputs
  78     outputs
  79     new-outputs
  80     drop-values ;
  81
  82 : drop-dead-outputs ( node -- #shuffle )
  83     dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
  84
  85 : some-outputs-dead? ( #call -- ? )
  86     out-d>> [ live-value? not ] any? ;
  87
  88 : maybe-drop-dead-outputs ( node -- nodes )
  89     dup some-outputs-dead? [
  90         dup drop-dead-outputs 2array
  91     ] when ;
  92
  93 M: #introduce remove-dead-code* ( #introduce -- nodes )
  94     maybe-drop-dead-outputs ;
  95
  96 M: #push remove-dead-code*
  97     dup out-d>> first live-value? [ drop f ] unless ;
  98
  99 : dead-flushable-call? ( #call -- ? )
 100     dup flushable-call? [
 101         out-d>> [ live-value? not ] all?
 102     ] [ drop f ] if ;
 103
 104 : remove-flushable-call ( #call -- node )
 105     [ word>> flushed-dependency depends-on ]
 106     [ in-d>> #drop remove-dead-code* ]
 107     bi ;
 108
 109 M: #call remove-dead-code*
 110     dup dead-flushable-call?
 111     [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
 112
 113 M: #shuffle remove-dead-code*
 114     [ filter-live ] change-in-d
 115     [ filter-live ] change-out-d
 116     [ filter-live ] change-in-r
 117     [ filter-live ] change-out-r
 118     [ filter-mapping ] change-mapping
 119     dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
 120
 121 M: #copy remove-dead-code*
 122     [ in-d>> ] [ out-d>> ] bi
 123     2dup swap zip #data-shuffle
 124     remove-dead-code* ;
 125
 126 M: #terminate remove-dead-code*
 127     [ filter-live ] change-in-d
 128     [ filter-live ] change-in-r ;
 129
 130 M: #alien-invoke remove-dead-code*
 131     maybe-drop-dead-outputs ;
 132
 133 M: #alien-indirect remove-dead-code*
 134     maybe-drop-dead-outputs ;