basis/compiler/cfg/stacks/local/local-tests.factor

   1 USING: accessors compiler.cfg compiler.cfg.instructions
   2 compiler.cfg.registers compiler.cfg.stacks.local
   3 compiler.cfg.utilities compiler.test cpu.architecture kernel
   4 kernel.private make math namespaces sequences.private slots.private
   5 tools.test ;
   6 QUALIFIED: sets
   7 IN: compiler.cfg.stacks.local.tests
   8
   9 ! end-local-analysis
  10 {
  11     HS{ }
  12     HS{ }
  13     HS{ }
  14 } [
  15     V{ } 137 insns>block
  16     [ [ "eh" , end-local-analysis ] V{ } make drop ]
  17     [ [ peeks>> ] [ replaces>> ] [ kills>> ] tri ] bi
  18 ] cfg-unit-test
  19
  20 {
  21     HS{ D: 3 }
  22 } [
  23     V{ } 137 insns>block
  24     [ [ 3 D: 3 replace-loc "eh" , end-local-analysis ] V{ } make drop ]
  25     [ replaces>> ] bi
  26 ] cfg-unit-test
  27
  28 ! local-loc>global
  29 { D: 6 } [
  30     D: 3 3 0 0 0 height-state boa
  31     local-loc>global
  32 ] unit-test
  33
  34 {
  35     D: 4
  36     R: 5
  37 } [
  38     3 4 0 0 height-state boa
  39     [ D: 1 swap local-loc>global ]
  40     [ R: 1 swap local-loc>global ] bi
  41 ] unit-test
  42
  43 ! kill-locations
  44 {
  45     { 10 11 12 13 14 15 }
  46     { }
  47     { }
  48     { -6 -5 -4 -3 }
  49     { -7 -6 -5 }
  50 } [
  51     -10 -6 kill-locations
  52     0 0 kill-locations
  53     2 4 kill-locations
  54     6 -4 kill-locations
  55     7 -3 kill-locations
  56 ] unit-test
  57
  58 ! loc>vreg
  59 { 1 } [
  60     D: 0 loc>vreg
  61 ] cfg-unit-test
  62
  63 ! replace-loc
  64 { 80 } [
  65     80 D: 77 replace-loc
  66     D: 77 peek-loc
  67 ] cfg-unit-test
  68
  69 ! stack-changes
  70 {
  71     {
  72         T{ ##copy { dst 1 } { src 25 } { rep any-rep } }
  73         T{ ##copy { dst 2 } { src 26 } { rep any-rep } }
  74     }
  75 } [
  76     { { D: 0 25 } { R: 0 26 } } replaces>copy-insns
  77 ] cfg-unit-test
  78
  79 ! remove-redundant-replaces
  80 {
  81     H{ { T{ ds-loc { n 3 } } 7 } }
  82 } [
  83     D: 0 loc>vreg D: 2 loc>vreg 2drop
  84     2 D: 2 replace-loc 7 D: 3 replace-loc
  85     replaces get remove-redundant-replaces
  86 ] cfg-unit-test
  87
  88 ! emit-insns
  89 {
  90     V{
  91         T{ ##copy { dst 1 } { src 3 } { rep any-rep } }
  92         "eh"
  93     }
  94 } [
  95     3 D: 0 replace-loc [
  96         "eh" ,
  97         replaces get height-state get emit-insns
  98     ] V{ } make
  99 ] cfg-unit-test
 100
 101 ! compute-local-kill-set
 102 { HS{ } } [
 103     0 0 0 0 height-state boa compute-local-kill-set
 104 ] unit-test
 105
 106 { HS{ R: -4 } } [
 107     0 4 0 -1 height-state boa compute-local-kill-set
 108 ] unit-test
 109
 110 { HS{ D: -1 D: -2 } } [
 111     2 0 -2 0 height-state boa compute-local-kill-set
 112 ] unit-test
 113
 114 ! global-loc>local
 115 { D: 2 } [
 116     D: 3 1 0 0 0 height-state boa global-loc>local
 117 ] unit-test
 118
 119 ! height-state
 120 {
 121     T{ height-state f 0 0 3 0 }
 122 } [
 123     D: 3 inc-stack height-state get
 124 ] cfg-unit-test
 125
 126 {
 127     T{ height-state f 2 0 3 0 }
 128 } [
 129     2 0 0 0 height-state boa height-state set
 130     D: 3 inc-stack height-state get
 131 ] cfg-unit-test
 132
 133 {
 134     { T{ ##inc { loc D: 4 } } T{ ##inc { loc R: -2 } } }
 135 } [
 136     0 0 4 -2 height-state boa height-state>insns
 137 ] unit-test
 138
 139 { H{ { D: -1 40 } } } [
 140     D: 1 inc-stack 40 D: 0 replace-loc replaces get
 141 ] cfg-unit-test
 142
 143 ! Compiling these words used to make the compiler hang due to a bug in
 144 ! end-local-analysis. So the test is just to compile them and if it
 145 ! doesn't hang, the bug is fixed! See #1507
 146 : my-new-key4 ( a i j -- i/j )
 147     2over
 148     slot
 149     tuck
 150     ! a i el j el
 151     [
 152         ! a i el j
 153         swap
 154         ! a i j el
 155         77 eq?
 156         [
 157             rot drop and
 158         ]
 159         [
 160             ! a i j
 161             over or my-new-key4
 162         ] if
 163     ]
 164     [
 165         ! a i el j
 166         2drop t
 167         ! a i t
 168         my-new-key4
 169     ] if ; inline recursive
 170
 171 : badword ( y -- )
 172     0 swap dup
 173     { integer object } declare
 174     [
 175         { array-capacity object } declare nip
 176         1234 1234 pick
 177         f
 178         my-new-key4
 179         set-slot
 180     ]
 181     curry (each-integer) ;