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: #shuffle compute-live-values*
  43     mapping>> at look-at-value ;
  44
  45 M: #alien-invoke compute-live-values* nip look-at-inputs ;
  46
  47 M: #alien-indirect compute-live-values* nip look-at-inputs ;
  48
  49 : filter-mapping ( assoc -- assoc' )
  50     live-values get '[ drop _ key? ] assoc-filter ;
  51
  52 : filter-corresponding ( new old -- old' )
  53     #! Remove elements from 'old' if the element with the same
  54     #! index in 'new' is dead.
  55     zip filter-mapping values ;
  56
  57 : filter-live ( values -- values' )
  58     dup empty? [ [ live-value? ] filter ] unless ;
  59
  60 :: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
  61     inputs
  62     outputs
  63     outputs
  64     mapping-keys
  65     mapping-values
  66     filter-corresponding zip #data-shuffle ; inline
  67
  68 :: drop-dead-values ( outputs -- #shuffle )
  69     [let* | new-outputs [ outputs make-values ]
  70             live-outputs [ outputs filter-live ] |
  71         new-outputs
  72         live-outputs
  73         outputs
  74         new-outputs
  75         drop-values
  76     ] ;
  77
  78 : drop-dead-outputs ( node -- #shuffle )
  79     dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
  80
  81 : some-outputs-dead? ( #call -- ? )
  82     out-d>> [ live-value? not ] any? ;
  83
  84 : maybe-drop-dead-outputs ( node -- nodes )
  85     dup some-outputs-dead? [
  86         dup drop-dead-outputs 2array
  87     ] when ;
  88
  89 M: #introduce remove-dead-code* ( #introduce -- nodes )
  90     maybe-drop-dead-outputs ;
  91
  92 M: #push remove-dead-code*
  93     dup out-d>> first live-value? [ drop f ] unless ;
  94
  95 : dead-flushable-call? ( #call -- ? )
  96     dup flushable-call? [
  97         out-d>> [ live-value? not ] all?
  98     ] [ drop f ] if ;
  99
 100 : remove-flushable-call ( #call -- node )
 101     [ word>> flushed-dependency depends-on ]
 102     [ in-d>> #drop remove-dead-code* ]
 103     bi ;
 104
 105 M: #call remove-dead-code*
 106     dup dead-flushable-call?
 107     [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
 108
 109 M: #shuffle remove-dead-code*
 110     [ filter-live ] change-in-d
 111     [ filter-live ] change-out-d
 112     [ filter-live ] change-in-r
 113     [ filter-live ] change-out-r
 114     [ filter-mapping ] change-mapping
 115     dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
 116
 117 M: #copy remove-dead-code*
 118     [ in-d>> ] [ out-d>> ] bi
 119     2dup swap zip #data-shuffle
 120     remove-dead-code* ;
 121
 122 M: #terminate remove-dead-code*
 123     [ filter-live ] change-in-d
 124     [ filter-live ] change-in-r ;
 125
 126 M: #alien-invoke remove-dead-code*
 127     maybe-drop-dead-outputs ;
 128
 129 M: #alien-indirect remove-dead-code*
 130     maybe-drop-dead-outputs ;