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

   1 USING: namespaces assocs sequences compiler.tree.builder
   2 compiler.tree.dead-code compiler.tree.def-use compiler.tree
   3 compiler.tree.combinators compiler.tree.propagation
   4 compiler.tree.cleanup compiler.tree.escape-analysis
   5 compiler.tree.tuple-unboxing compiler.tree.debugger
   6 compiler.tree.recursive compiler.tree.normalization
   7 compiler.tree.checker tools.test kernel math stack-checker.state
   8 accessors combinators io prettyprint words sequences.deep
   9 sequences.private arrays classes kernel.private shuffle
  10 math.private ;
  11 IN: compiler.tree.dead-code.tests
  12
  13 : count-live-values ( quot -- n )
  14     build-tree
  15     analyze-recursive
  16     normalize
  17     propagate
  18     cleanup-tree
  19     escape-analysis
  20     unbox-tuples
  21     compute-def-use
  22     remove-dead-code
  23     0 swap [
  24         dup
  25         [ #push? ] [ #introduce? ] bi or
  26         [ out-d>> length + ] [ drop ] if
  27     ] each-node ;
  28
  29 { 3 } [ [ 1 2 3 ] count-live-values ] unit-test
  30
  31 { 1 } [ [ drop ] count-live-values ] unit-test
  32
  33 { 0 } [ [ 1 drop ] count-live-values ] unit-test
  34
  35 { 1 } [ [ 1 2 drop ] count-live-values ] unit-test
  36
  37 { 3 } [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
  38
  39 { 1 } [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
  40
  41 { 2 } [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
  42
  43 { 2 } [ [ 1 + ] count-live-values ] unit-test
  44
  45 { 0 } [ [ 1 2 + drop ] count-live-values ] unit-test
  46
  47 { 3 } [ [ 1 + 3 + ] count-live-values ] unit-test
  48
  49 { 0 } [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
  50
  51 { 4 } [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
  52
  53 { 1 } [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
  54
  55 { 0 } [ [ [ ] call ] count-live-values ] unit-test
  56
  57 { 1 } [ [ [ 1 ] call ] count-live-values ] unit-test
  58
  59 { 2 } [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
  60
  61 { 0 } [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
  62
  63 { 3 } [ [ 10 [ ] times ] count-live-values ] unit-test
  64
  65 : optimize-quot ( quot -- quot' )
  66     build-tree
  67     analyze-recursive
  68     normalize
  69     propagate
  70     cleanup-tree
  71     escape-analysis
  72     unbox-tuples
  73     compute-def-use
  74     remove-dead-code
  75     "no-check" get [ dup check-nodes ] unless nodes>quot ;
  76
  77 { [ drop 1 ] } [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
  78
  79 { [ stream-read1 drop 1 2 ] } [ [ stream-read1 [ 1 2 ] dip drop ] optimize-quot ] unit-test
  80
  81 { [ over >R + R> ] } [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
  82
  83 { [ [ ] [ ] if ] } [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
  84
  85 : flushable-1 ( a b -- c ) 2drop f ; flushable
  86 : flushable-2 ( a b -- c ) 2drop f ; flushable
  87
  88 { [ 2nip [ ] [ ] if ] } [
  89     [ [ flushable-1 ] [ flushable-2 ] if drop ] optimize-quot
  90 ] unit-test
  91
  92 : non-flushable-3 ( a b -- c ) 2drop f ;
  93
  94 { [ [ 2drop ] [ non-flushable-3 drop ] if ] } [
  95     [ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
  96 ] unit-test
  97
  98 { [ [ f ] [ f ] if ] } [ [ [ f ] [ f ] if ] optimize-quot ] unit-test
  99
 100 { } [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
 101
 102 { [ [ . ] [ drop ] if ] } [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test
 103
 104 { [ f ] } [ [ f dup [ ] [ ] if ] optimize-quot ] unit-test
 105
 106 { } [ [ over [ ] [ dup [ "X" throw ] [ "X" throw ] if ] if ] optimize-quot drop ] unit-test
 107
 108 : boo ( a b -- c ) 2drop f ;
 109
 110 { [ dup 4 eq? [ nip ] [ boo ] if ] } [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test
 111
 112 : squish ( quot -- quot' )
 113     [
 114         {
 115             { [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] }
 116             { [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] }
 117             [ ]
 118         } cond
 119     ] deep-map ;
 120
 121 : call-recursive-dce-1 ( a -- b )
 122     [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
 123
 124 { [ drop "WRAP" [ "REC" drop "REC" ] label ] } [
 125     [ call-recursive-dce-1 ] optimize-quot squish
 126 ] unit-test
 127
 128 : produce-a-value ( -- a ) f ;
 129
 130 : call-recursive-dce-2 ( a -- b )
 131     drop
 132     produce-a-value dup . call-recursive-dce-2 ; inline recursive
 133
 134 { [ "WRAP" [ produce-a-value . "REC" ] label ] } [
 135     [ f call-recursive-dce-2 drop ] optimize-quot squish
 136 ] unit-test
 137
 138 { [ "WRAP" [ produce-a-value . "REC" ] label ] } [
 139     [ f call-recursive-dce-2 ] optimize-quot squish
 140 ] unit-test
 141
 142 : call-recursive-dce-3 ( a -- )
 143     call-recursive-dce-3 ; inline recursive
 144
 145 { [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] } [
 146     [ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish
 147 ] unit-test
 148
 149 { [ drop "WRAP" [ "REC" ] label ] } [
 150     [ call-recursive-dce-3 ] optimize-quot squish
 151 ] unit-test
 152
 153 : call-recursive-dce-4 ( a -- b )
 154     call-recursive-dce-4 ; inline recursive
 155
 156 { [ drop "WRAP" [ "REC" ] label ] } [
 157     [ call-recursive-dce-4 ] optimize-quot squish
 158 ] unit-test
 159
 160 { [ drop "WRAP" [ "REC" ] label ] } [
 161     [ call-recursive-dce-4 drop ] optimize-quot squish
 162 ] unit-test
 163
 164 { } [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test
 165
 166 : call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive
 167
 168 { } [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test
 169
 170 { } [ [ [ 0 -rot set-nth-unsafe ] curry each-integer-from ] optimize-quot drop ] unit-test
 171
 172 : call-recursive-dce-6 ( i quot: ( ..a -- ..b ) -- i )
 173     dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
 174
 175 { } [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
 176
 177 { } [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
 178
 179 { [ drop ] } [ [ array? drop ] optimize-quot ] unit-test
 180
 181 { [ drop ] } [ [ array instance? drop ] optimize-quot ] unit-test
 182
 183 {
 184     [ f <array> drop ]
 185     [ f <array> drop ]
 186     [ drop ]
 187 } [
 188     ! Not flushed because the first argument to <array> can be
 189     ! something random which would cause an exception.
 190     [ f <array> drop ] optimize-quot
 191
 192     ! This call is not flushed because the integer can be outside
 193     ! array-capacity-interval
 194     [ { integer } declare f <array> drop ] optimize-quot
 195
 196     ! Flushed because the declaration guarantees that the integer is
 197     ! within the array-capacity-interval.
 198     [ { integer-array-capacity } declare f <array> drop ] optimize-quot
 199 ] unit-test
 200
 201 { [ f <array> drop ] } [ [ f <array> drop ] optimize-quot ] unit-test
 202
 203 : call-recursive-dce-7 ( obj -- elt ? )
 204     dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
 205
 206 { } [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test
 207
 208 { [ /i ] } [ [ /mod drop ] optimize-quot ] unit-test
 209
 210 { [ mod ] } [ [ /mod nip ] optimize-quot ] unit-test
 211
 212 { [ fixnum/i ] } [ [ { fixnum fixnum } declare /mod drop ] optimize-quot ] unit-test
 213
 214 { [ fixnum-mod ] } [ [ { fixnum fixnum } declare /mod nip ] optimize-quot ] unit-test
 215
 216 { [ bignum/i ] } [ [ { bignum bignum } declare /mod drop ] optimize-quot ] unit-test
 217
 218 { [ bignum-mod ] } [ [ { bignum bignum } declare /mod nip ] optimize-quot ] unit-test
 219
 220 { [ /i ] } [ [ /mod drop ] optimize-quot ] unit-test
 221
 222 { [ mod ] } [ [ /mod nip ] optimize-quot ] unit-test