basis/compiler/cfg/builder/builder-tests.factor

   1 USING: accessors alien alien.accessors arrays assocs byte-arrays
   2 combinators.short-circuit compiler.cfg compiler.cfg.builder compiler.cfg.checker
   3 compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.optimizer
   4 compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.representations
   5 compiler.cfg.rpo compiler.cfg.stacks compiler.cfg.stacks.local
   6 compiler.cfg.utilities compiler.test compiler.tree compiler.tree.builder
   7 compiler.tree.optimizer fry hashtables kernel kernel.private locals make math
   8 math.partial-dispatch math.private namespaces prettyprint sbufs sequences
   9 sequences.private slots.private strings strings.private tools.test vectors
  10 words ;
  11 FROM: alien.c-types => int ;
  12 IN: compiler.cfg.builder.tests
  13
  14 ! Just ensure that various CFGs build correctly.
  15 : unit-test-builder ( quot -- )
  16     '[
  17         _ test-builder [
  18             [
  19                 [ optimize-cfg ] [ check-cfg ] bi
  20             ] with-cfg
  21         ] each
  22     ] [ ] swap unit-test ;
  23
  24 : blahblah ( nodes -- ? )
  25     { fixnum } declare [
  26         dup 3 bitand 1 = [ drop t ] [
  27             dup 3 bitand 2 = [
  28                 blahblah
  29             ] [ drop f ] if
  30         ] if
  31     ] any? ; inline recursive
  32
  33 : more? ( x -- ? ) ;
  34
  35 : test-case-1 ( -- ? ) f ;
  36
  37 : test-case-2 ( -- )
  38     test-case-1 [ test-case-2 ] [ ] if ; inline recursive
  39
  40 {
  41     [ ]
  42     [ dup ]
  43     [ swap ]
  44     [ [ ] dip ]
  45     [ fixnum+ ]
  46     [ fixnum+fast ]
  47     [ 3 fixnum+fast ]
  48     [ fixnum*fast ]
  49     [ 3 fixnum*fast ]
  50     [ 3 swap fixnum*fast ]
  51     [ fixnum-shift-fast ]
  52     [ 10 fixnum-shift-fast ]
  53     [ -10 fixnum-shift-fast ]
  54     [ 0 fixnum-shift-fast ]
  55     [ 10 swap fixnum-shift-fast ]
  56     [ -10 swap fixnum-shift-fast ]
  57     [ 0 swap fixnum-shift-fast ]
  58     [ fixnum-bitnot ]
  59     [ eq? ]
  60     [ "hi" eq? ]
  61     [ fixnum< ]
  62     [ 5 fixnum< ]
  63     [ float+ ]
  64     [ 3.0 float+ ]
  65     [ float<= ]
  66     [ fixnum>bignum ]
  67     [ bignum>fixnum ]
  68     [ fixnum>float ]
  69     [ float>fixnum ]
  70     [ 3 f <array> ]
  71     [ [ 1 ] [ 2 ] if ]
  72     [ fixnum< [ 1 ] [ 2 ] if ]
  73     [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
  74     [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
  75     [ [ t ] loop ]
  76     [ [ dup ] loop ]
  77     [ [ 2 ] [ 3 throw ] if 4 ]
  78     [ int f "malloc" { int } alien-invoke ]
  79     [ int { int } cdecl alien-indirect ]
  80     [ int { int } cdecl [ ] alien-callback ]
  81     [ swap - + * ]
  82     [ swap slot ]
  83     [ blahblah ]
  84     [ 1000 [ dup [ reverse ] when ] times ]
  85     [ 1array ]
  86     [ 1 2 ? ]
  87     [ { array } declare [ ] map ]
  88     [ { array } declare dup 1 slot [ 1 slot ] when ]
  89     [ [ dup more? ] [ dup ] produce ]
  90     [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
  91     [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
  92     [
  93         { fixnum sbuf } declare 2dup 3 slot fixnum> [
  94             over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
  95         ] [ ] if
  96     ]
  97     [ [ 2 fixnum* ] when 3 ]
  98     [ [ 2 fixnum+ ] when 3 ]
  99     [ [ 2 fixnum- ] when 3 ]
 100     [ 10000 [ ] times ]
 101     [
 102         over integer? [
 103             over dup 16 <-integer-fixnum
 104             [ 0 >=-integer-fixnum ] [ drop f ] if [
 105                 nip dup
 106                 [ ] [ ] if
 107             ] [ 2drop f ] if
 108         ] [ 2drop f ] if
 109     ]
 110     [
 111         pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
 112         set-string-nth-fast
 113     ]
 114 } [
 115     unit-test-builder
 116 ] each
 117
 118 : test-1 ( -- ) test-1 ;
 119 : test-2 ( -- ) 3 . test-2 ;
 120 : test-3 ( a -- b ) dup [ test-3 ] when ;
 121
 122 {
 123     test-1
 124     test-2
 125     test-3
 126 } [ unit-test-builder ] each
 127
 128 {
 129     byte-array
 130     alien
 131     POSTPONE: f
 132 } [| class |
 133     {
 134         alien-signed-1
 135         alien-signed-2
 136         alien-signed-4
 137         alien-unsigned-1
 138         alien-unsigned-2
 139         alien-unsigned-4
 140         alien-cell
 141         alien-float
 142         alien-double
 143     } [| word |
 144         { class } word '[ _ declare 10 _ execute ] unit-test-builder
 145         { class fixnum } word '[ _ declare _ execute ] unit-test-builder
 146     ] each
 147
 148     {
 149         set-alien-signed-1
 150         set-alien-signed-2
 151         set-alien-signed-4
 152         set-alien-unsigned-1
 153         set-alien-unsigned-2
 154         set-alien-unsigned-4
 155     } [| word |
 156         { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
 157         { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
 158     ] each
 159
 160     { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
 161     { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
 162
 163     { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
 164     { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
 165
 166     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
 167     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
 168 ] each
 169
 170 [ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
 171
 172 [ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
 173
 174 [ t ] [
 175     [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
 176     [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 177 ] unit-test
 178
 179 [ t ] [
 180     [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
 181     [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 182 ] unit-test
 183
 184 [ f ] [
 185     [ { byte-array fixnum } declare set-alien-unsigned-1 ]
 186     [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 187 ] unit-test
 188
 189 [ t t ] [
 190     [ { byte-array fixnum } declare alien-cell ]
 191     [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
 192     [ [ ##box-alien? ] contains-insn? ]
 193     bi
 194 ] unit-test
 195
 196 [ f ] [
 197     [ { byte-array integer } declare alien-cell ]
 198     [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
 199 ] unit-test
 200
 201 [ f ] [
 202     [ 1000 [ ] times ]
 203     [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
 204 ] unit-test
 205
 206 [ f t ] [
 207     [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
 208     [ [ ##unbox-any-c-ptr? ] contains-insn? ]
 209     [ [ ##unbox-alien? ] contains-insn? ] bi
 210 ] unit-test
 211
 212 \ alien-float "intrinsic" word-prop [
 213     [ f t ] [
 214         [ { byte-array fixnum } declare alien-cell 4 alien-float ]
 215         [ [ ##box-alien? ] contains-insn? ]
 216         [ [ ##allot? ] contains-insn? ] bi
 217     ] unit-test
 218
 219     [ f t ] [
 220         [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
 221         [ [ ##box-alien? ] contains-insn? ]
 222         [ [ ##allot? ] contains-insn? ] bi
 223     ] unit-test
 224
 225     [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
 226 ] when
 227
 228 ! Regression. Make sure everything is inlined correctly
 229 [ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
 230
 231 ! Regression. Make sure branch splitting works.
 232 [ 2 ] [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test
 233
 234 ! Make sure fast union predicates don't have conditionals.
 235 [ f ] [
 236     [ tag 1 swap fixnum-shift-fast ]
 237     [ ##compare-integer-imm-branch? ] contains-insn?
 238 ] unit-test
 239
 240 ! make-input-map
 241 {
 242     { { 37 D 2 } { 81 D 1 } { 92 D 0 } }
 243 } [
 244     T{ #shuffle { in-d { 37 81 92 } } } make-input-map
 245 ] unit-test
 246
 247 ! emit-node
 248 {
 249     { T{ ##load-integer { dst 78 } { val 0 } } }
 250 } [
 251     77 vreg-counter set-global
 252     [
 253         T{ #push { literal 0 } { out-d { 8537399 } } } emit-node
 254     ] { } make
 255 ] cfg-unit-test
 256
 257 {
 258     { { 1 1 } { 0 0 } }
 259     H{ { D -1 4 } { D 0 4 } }
 260 } [
 261     4 D 0 replace-loc
 262     T{ #shuffle
 263        { mapping { { 2 4 } { 3 4 } } }
 264        { in-d V{ 4 } }
 265        { out-d V{ 2 3 } }
 266     } emit-node
 267     height-state get
 268     replaces get
 269 ] cfg-unit-test
 270
 271 { 1 } [
 272     V{ } 0 insns>block basic-block set init-cfg-test
 273     V{ } 1 insns>block [ emit-loop-call ] V{ } make drop
 274     basic-block get successors>> length
 275 ] unit-test
 276
 277 ! emit-loop-call
 278 { "bar" } [
 279     V{ } "foo" insns>block basic-block set init-cfg-test
 280     [ V{ } "bar" insns>block emit-loop-call ] V{ } make drop
 281     basic-block get successors>> first number>>
 282 ] unit-test
 283
 284 ! begin-cfg
 285 SYMBOL: foo
 286
 287 { foo } [
 288     \ foo f begin-cfg word>>
 289 ] cfg-unit-test
 290
 291 ! store-shuffle
 292 {
 293     H{ { D 2 1 } }
 294 } [
 295     T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
 296     emit-node replaces get
 297 ] cfg-unit-test
 298
 299 {
 300     H{ { D -1 1 } { D 0 1 } }
 301 } [
 302     T{ #shuffle
 303        { in-d { 7 } }
 304        { out-d { 55 77 } }
 305        { mapping { { 55 7 } { 77 7 } } }
 306     } emit-node replaces get
 307 ] cfg-unit-test