basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor

   1 USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
   2 compiler.cfg.predecessors compiler.cfg.stack-analysis
   3 compiler.cfg.instructions sequences kernel tools.test accessors
   4 sequences.private alien math combinators.private compiler.cfg
   5 compiler.cfg.checker compiler.cfg.rpo
   6 compiler.cfg.dce compiler.cfg.registers
   7 sets namespaces arrays cpu.architecture ;
   8 IN: compiler.cfg.stack-analysis.tests
   9
  10 ! Fundamental invariant: a basic block should not load or store a value more than once
  11 : test-stack-analysis ( quot -- cfg )
  12     dup cfg? [ test-cfg first ] unless
  13     compute-predecessors
  14     stack-analysis
  15     dup check-cfg ;
  16
  17 : linearize ( cfg -- mr )
  18     flatten-cfg instructions>> ;
  19
  20 [ ] [ [ ] test-stack-analysis drop ] unit-test
  21
  22 ! Only peek once
  23 [ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
  24
  25 ! Redundant replace is redundant
  26 [ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
  27 [ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
  28
  29 ! Replace required here
  30 [ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
  31 [ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
  32
  33 ! Only one replace, at the end
  34 [ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
  35
  36 ! Do we support the full language?
  37 [ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
  38 [ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
  39 [ ] [
  40     [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
  41     test-cfg second test-stack-analysis drop
  42 ] unit-test
  43
  44 ! Test loops
  45 [ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
  46 [ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
  47
  48 ! Make sure that peeks are inserted in the right place
  49 [ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
  50
  51 ! This should be a total no-op
  52 [ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
  53
  54 ! Don't insert inc-d/inc-r; that's wrong!
  55 [ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
  56
  57 ! Bug in height tracking
  58 [ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
  59 [ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
  60 [ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
  61
  62 ! Bugs with code that throws
  63 [ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
  64 [ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
  65 [ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
  66 [ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
  67
  68 ! Make sure the replace stores a value with the right height
  69 [ ] [
  70     [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
  71     [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
  72 ] unit-test
  73
  74 ! translate-loc was the wrong way round
  75 [ ] [
  76     [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
  77     [ [ ##load-immediate? ] count 2 assert= ]
  78     [ [ ##peek? ] count 1 assert= ]
  79     [ [ ##replace? ] count 3 assert= ]
  80     tri
  81 ] unit-test
  82
  83 [ ] [
  84     [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
  85     [ [ ##load-immediate? ] count 2 assert= ]
  86     [ [ ##peek? ] count 1 assert= ]
  87     [ [ ##replace? ] count 1 assert= ]
  88     tri
  89 ] unit-test
  90
  91 ! Sync before a back-edge, not after
  92 ! ##peeks should be inserted before a ##loop-entry
  93 ! Don't optimize out the constants
  94 [ t ] [
  95     [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
  96     [ ##load-immediate? ] any?
  97 ] unit-test
  98
  99 ! Correct height tracking
 100 [ t ] [
 101     [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
 102     reverse-post-order 4 swap nth
 103     instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
 104     2array { D 1 D 0 } set=
 105 ] unit-test
 106
 107 [ D 1 ] [
 108     V{ T{ ##branch } } 0 test-bb
 109
 110     V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
 111
 112     V{
 113         T{ ##peek f V int-regs 1 D 2 }
 114         T{ ##inc-d f -1 }
 115         T{ ##branch }
 116     } 2 test-bb
 117
 118     V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
 119
 120     V{ T{ ##return } } 4 test-bb
 121
 122     test-diamond
 123
 124     cfg new 0 get >>entry
 125     compute-predecessors
 126     stack-analysis
 127     drop
 128
 129     3 get successors>> first instructions>> first loc>>
 130 ] unit-test
 131
 132 ! Do inserted ##peeks reference the correct stack location if
 133 ! an ##inc-d/r was also inserted?
 134 [ D 0 ] [
 135     V{ T{ ##branch } } 0 test-bb
 136
 137     V{ T{ ##branch } } 1 test-bb
 138
 139     V{
 140         T{ ##peek f V int-regs 1 D 0 }
 141         T{ ##branch }
 142     } 2 test-bb
 143
 144     V{
 145         T{ ##call f \ + -1 }
 146         T{ ##inc-d f 1 }
 147         T{ ##branch }
 148     } 3 test-bb
 149
 150     V{ T{ ##return } } 4 test-bb
 151
 152     test-diamond
 153
 154     cfg new 0 get >>entry
 155     compute-predecessors
 156     stack-analysis
 157     drop
 158
 159     3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
 160 ] unit-test
 161
 162 ! Missing ##replace
 163 [ t ] [
 164     [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
 165     reverse-post-order last
 166     instructions>> [ ##replace? ] filter [ loc>> ] map
 167     { D 0 D 1 D 2 } set=
 168 ] unit-test
 169
 170 ! Inserted ##peeks reference the wrong stack location
 171 [ t ] [
 172     [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
 173     eliminate-dead-code reverse-post-order 4 swap nth
 174     instructions>> [ ##peek? ] filter [ loc>> ] map
 175     { D 0 D 1 } set=
 176 ] unit-test
 177
 178 [ D 0 ] [
 179     V{ T{ ##branch } } 0 test-bb
 180
 181     V{ T{ ##branch } } 1 test-bb
 182
 183     V{
 184         T{ ##peek f V int-regs 1 D 0 }
 185         T{ ##inc-d f 1 }
 186         T{ ##branch }
 187     } 2 test-bb
 188
 189     V{
 190         T{ ##inc-d f 1 }
 191         T{ ##branch }
 192     } 3 test-bb
 193
 194     V{ T{ ##return } } 4 test-bb
 195
 196     test-diamond
 197
 198     cfg new 0 get >>entry
 199     compute-predecessors
 200     stack-analysis
 201     drop
 202
 203     3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
 204 ] unit-test