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 ;
  10 IN: compiler.tree.dead-code.tests
  11
  12 \ remove-dead-code must-infer
  13
  14 : count-live-values ( quot -- n )
  15     build-tree
  16     analyze-recursive
  17     normalize
  18     propagate
  19     cleanup
  20     escape-analysis
  21     unbox-tuples
  22     compute-def-use
  23     remove-dead-code
  24     0 swap [
  25         dup
  26         [ #push? ] [ #introduce? ] bi or
  27         [ out-d>> length + ] [ drop ] if
  28     ] each-node ;
  29
  30 [ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
  31
  32 [ 1 ] [ [ drop ] count-live-values ] unit-test
  33
  34 [ 0 ] [ [ 1 drop ] count-live-values ] unit-test
  35
  36 [ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
  37
  38 [ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
  39
  40 [ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
  41
  42 [ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
  43
  44 [ 2 ] [ [ 1 + ] count-live-values ] unit-test
  45
  46 [ 0 ] [ [ 1 2 + drop ] count-live-values ] unit-test
  47
  48 [ 3 ] [ [ 1 + 3 + ] count-live-values ] unit-test
  49
  50 [ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
  51
  52 [ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
  53
  54 [ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
  55
  56 [ 0 ] [ [ [ ] call ] count-live-values ] unit-test
  57
  58 [ 1 ] [ [ [ 1 ] call ] count-live-values ] unit-test
  59
  60 [ 2 ] [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
  61
  62 [ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
  63
  64 [ 3 ] [ [ 10 [ ] times ] count-live-values ] unit-test
  65
  66 : optimize-quot ( quot -- quot' )
  67     build-tree
  68     analyze-recursive
  69     normalize
  70     propagate
  71     cleanup
  72     escape-analysis
  73     unbox-tuples
  74     compute-def-use
  75     remove-dead-code
  76     "no-check" get [ dup check-nodes ] unless nodes>quot ;
  77
  78 [ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
  79
  80 [ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
  81
  82 [ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
  83
  84 [ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
  85
  86 : flushable-1 ( a b -- c ) 2drop f ; flushable
  87 : flushable-2 ( a b -- c ) 2drop f ; flushable
  88
  89 [ [ 2nip [ ] [ ] if ] ] [
  90     [ [ flushable-1 ] [ flushable-2 ] if drop ] optimize-quot
  91 ] unit-test
  92
  93 : non-flushable-3 ( a b -- c ) 2drop f ;
  94
  95 [ [ [ 2drop ] [ non-flushable-3 drop ] if ] ] [
  96     [ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
  97 ] unit-test
  98
  99 [ [ [ f ] [ f ] if ] ] [ [ [ f ] [ f ] if ] optimize-quot ] unit-test
 100
 101 [ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
 102
 103 [ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test
 104
 105 [ [ f ] ] [ [ f dup [ ] [ ] if ] optimize-quot ] unit-test
 106
 107 [ ] [ [ over [ ] [ dup [ "X" throw ] [ "X" throw ] if ] if ] optimize-quot drop ] unit-test
 108
 109 : boo ( a b -- c ) 2drop f ;
 110
 111 [ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test
 112
 113 : squish ( quot -- quot' )
 114     [
 115         {
 116             { [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] }
 117             { [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] }
 118             [ ]
 119         } cond
 120     ] deep-map ;
 121
 122 : call-recursive-dce-1 ( a -- b )
 123     [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
 124
 125 [ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
 126     [ call-recursive-dce-1 ] optimize-quot squish
 127 ] unit-test
 128
 129 : produce-a-value ( -- a ) f ;
 130
 131 : call-recursive-dce-2 ( a -- b )
 132     drop
 133     produce-a-value dup . call-recursive-dce-2 ; inline recursive
 134
 135 [ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
 136     [ f call-recursive-dce-2 drop ] optimize-quot squish
 137 ] unit-test
 138
 139 [ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
 140     [ f call-recursive-dce-2 ] optimize-quot squish
 141 ] unit-test
 142
 143 : call-recursive-dce-3 ( a -- )
 144     call-recursive-dce-3 ; inline recursive
 145
 146 [ [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] ] [
 147     [ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish
 148 ] unit-test
 149
 150 [ [ drop "WRAP" [ "REC" ] label ] ] [
 151     [ call-recursive-dce-3 ] optimize-quot squish
 152 ] unit-test
 153
 154 : call-recursive-dce-4 ( a -- b )
 155     call-recursive-dce-4 ; inline recursive
 156
 157 [ [ drop "WRAP" [ "REC" ] label ] ] [
 158     [ call-recursive-dce-4 ] optimize-quot squish
 159 ] unit-test
 160
 161 [ [ drop "WRAP" [ "REC" ] label ] ] [
 162     [ call-recursive-dce-4 drop ] optimize-quot squish
 163 ] unit-test
 164
 165 [ ] [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test
 166
 167 : call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive
 168
 169 [ ] [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test
 170
 171 [ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
 172
 173 : call-recursive-dce-6 ( i quot: ( i -- ? ) -- i )
 174     dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
 175
 176 [ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
 177
 178 [ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
 179
 180 [ [ drop ] ] [ [ array? drop ] optimize-quot ] unit-test
 181
 182 [ [ drop ] ] [ [ array instance? drop ] optimize-quot ] unit-test
 183
 184 [ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
 185
 186 [ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
 187
 188 : call-recursive-dce-7 ( obj -- elt ? )
 189     dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
 190
 191 [ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test