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
   3 compiler.cfg.builder.blocks compiler.cfg.checker compiler.cfg.debugger
   4 compiler.cfg.instructions compiler.cfg.linearization
   5 compiler.cfg.optimizer compiler.cfg.registers
   6 compiler.cfg.stacks.local compiler.cfg.utilities compiler.test
   7 compiler.tree compiler.tree.builder compiler.tree.optimizer
   8 compiler.tree.propagation.info cpu.architecture fry hashtables io
   9 kernel kernel.private locals make math math.intervals
  10 math.partial-dispatch math.private namespaces prettyprint sbufs
  11 sequences sequences.private slots.private strings strings.private
  12 tools.test vectors words ;
  13 FROM: alien.c-types => int ;
  14 IN: compiler.cfg.builder.tests
  15
  16 ! Just ensure that various CFGs build correctly.
  17 : unit-test-builder ( quot -- )
  18     '[
  19         _ test-builder [
  20             [
  21                 [ optimize-cfg ] [ check-cfg ] bi
  22             ] with-cfg
  23         ] each
  24     ] [ ] swap unit-test ;
  25
  26 : blahblah ( nodes -- ? )
  27     { fixnum } declare [
  28         dup 3 bitand 1 = [ drop t ] [
  29             dup 3 bitand 2 = [
  30                 blahblah
  31             ] [ drop f ] if
  32         ] if
  33     ] any? ; inline recursive
  34
  35 : more? ( x -- ? ) ;
  36
  37 : test-case-1 ( -- ? ) f ;
  38
  39 : test-case-2 ( -- )
  40     test-case-1 [ test-case-2 ] [ ] if ; inline recursive
  41
  42 {
  43     [ ]
  44     [ dup ]
  45     [ swap ]
  46     [ [ ] dip ]
  47     [ fixnum+ ]
  48     [ fixnum+fast ]
  49     [ 3 fixnum+fast ]
  50     [ fixnum*fast ]
  51     [ 3 fixnum*fast ]
  52     [ 3 swap fixnum*fast ]
  53     [ fixnum-shift-fast ]
  54     [ 10 fixnum-shift-fast ]
  55     [ -10 fixnum-shift-fast ]
  56     [ 0 fixnum-shift-fast ]
  57     [ 10 swap fixnum-shift-fast ]
  58     [ -10 swap fixnum-shift-fast ]
  59     [ 0 swap fixnum-shift-fast ]
  60     [ fixnum-bitnot ]
  61     [ eq? ]
  62     [ "hi" eq? ]
  63     [ fixnum< ]
  64     [ 5 fixnum< ]
  65     [ float+ ]
  66     [ 3.0 float+ ]
  67     [ float<= ]
  68     [ fixnum>bignum ]
  69     [ bignum>fixnum ]
  70     [ fixnum>float ]
  71     [ float>fixnum ]
  72     [ 3 f <array> ]
  73     [ [ 1 ] [ 2 ] if ]
  74     [ fixnum< [ 1 ] [ 2 ] if ]
  75     [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
  76     [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
  77     [ [ t ] loop ]
  78     [ [ dup ] loop ]
  79     [ [ 2 ] [ 3 throw ] if 4 ]
  80     [ int f "malloc" { int } f alien-invoke ]
  81     [ int { int } cdecl alien-indirect ]
  82     [ int { int } cdecl [ ] alien-callback ]
  83     [ swap - + * ]
  84     [ swap slot ]
  85     [ blahblah ]
  86     [ 1000 [ dup [ reverse ] when ] times ]
  87     [ 1array ]
  88     [ 1 2 ? ]
  89     [ { array } declare [ ] map ]
  90     [ { array } declare dup 1 slot [ 1 slot ] when ]
  91     [ [ dup more? ] [ dup ] produce ]
  92     [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
  93     [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry each-integer-from ]
  94     [
  95         { fixnum sbuf } declare 2dup 3 slot fixnum> [
  96             over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
  97         ] [ ] if
  98     ]
  99     [ [ 2 fixnum* ] when 3 ]
 100     [ [ 2 fixnum+ ] when 3 ]
 101     [ [ 2 fixnum- ] when 3 ]
 102     [ 10000 [ ] times ]
 103     [
 104         over integer? [
 105             over dup 16 <-integer-fixnum
 106             [ 0 >=-integer-fixnum ] [ drop f ] if [
 107                 nip dup
 108                 [ ] [ ] if
 109             ] [ 2drop f ] if
 110         ] [ 2drop f ] if
 111     ]
 112     [
 113         pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
 114         set-string-nth-fast
 115     ]
 116 } [
 117     unit-test-builder
 118 ] each
 119
 120 : test-1 ( -- ) test-1 ;
 121 : test-2 ( -- ) 3 . test-2 ;
 122 : test-3 ( a -- b ) dup [ test-3 ] when ;
 123
 124 {
 125     test-1
 126     test-2
 127     test-3
 128 } [ unit-test-builder ] each
 129
 130 {
 131     byte-array
 132     alien
 133     POSTPONE: f
 134 } [| class |
 135     {
 136         alien-signed-1
 137         alien-signed-2
 138         alien-signed-4
 139         alien-unsigned-1
 140         alien-unsigned-2
 141         alien-unsigned-4
 142         alien-cell
 143         alien-float
 144         alien-double
 145     } [| word |
 146         { class } word '[ _ declare 10 _ execute ] unit-test-builder
 147         { class fixnum } word '[ _ declare _ execute ] unit-test-builder
 148     ] each
 149
 150     {
 151         set-alien-signed-1
 152         set-alien-signed-2
 153         set-alien-signed-4
 154         set-alien-unsigned-1
 155         set-alien-unsigned-2
 156         set-alien-unsigned-4
 157     } [| word |
 158         { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
 159         { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
 160     ] each
 161
 162     { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
 163     { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
 164
 165     { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
 166     { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
 167
 168     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
 169     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
 170 ] each
 171
 172 { t } [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
 173
 174 { f } [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
 175
 176 { t } [
 177     [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
 178     [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 179 ] unit-test
 180
 181 { t } [
 182     [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
 183     [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 184 ] unit-test
 185
 186 { f } [
 187     [ { byte-array fixnum } declare set-alien-unsigned-1 ]
 188     [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 189 ] unit-test
 190
 191 { t t } [
 192     [ { byte-array fixnum } declare alien-cell ]
 193     [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
 194     [ [ ##box-alien? ] contains-insn? ]
 195     bi
 196 ] unit-test
 197
 198 { f } [
 199     [ { byte-array integer } declare alien-cell ]
 200     [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
 201 ] unit-test
 202
 203 { f } [
 204     [ 1000 [ ] times ] [ ##peek? ] contains-insn?
 205 ] unit-test
 206
 207 { f t } [
 208     [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
 209     [ [ ##unbox-any-c-ptr? ] contains-insn? ]
 210     [ [ ##unbox-alien? ] contains-insn? ] bi
 211 ] unit-test
 212
 213 \ alien-float "intrinsic" word-prop [
 214     [ f t ] [
 215         [ { byte-array fixnum } declare alien-cell 4 alien-float ]
 216         [ [ ##box-alien? ] contains-insn? ]
 217         [ [ ##allot? ] contains-insn? ] bi
 218     ] unit-test
 219
 220     [ f t ] [
 221         [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
 222         [ [ ##box-alien? ] contains-insn? ]
 223         [ [ ##allot? ] contains-insn? ] bi
 224     ] unit-test
 225
 226     [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
 227 ] when
 228
 229 ! Regression. Make sure everything is inlined correctly
 230 { f } [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
 231
 232 ! Regression. Make sure branch splitting works.
 233 { 2 } [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test
 234
 235 ! Make sure fast union predicates don't have conditionals.
 236 { f } [
 237     [ tag 1 swap fixnum-shift-fast ]
 238     [ ##compare-integer-imm-branch? ] contains-insn?
 239 ] unit-test
 240
 241 ! begin-cfg
 242 SYMBOL: foo
 243
 244 { foo } [
 245     \ foo f begin-cfg word>>
 246 ] cfg-unit-test
 247
 248 ! build-cfg
 249 { 5 } [
 250     [ dup ] build-tree optimize-tree gensym build-cfg
 251     first linearization-order length
 252 ] unit-test
 253
 254 ! emit-branch
 255 { 77 } [
 256     { T{ #call { word + } } }
 257     V{ } 77 insns>block
 258     emit-branch
 259     first predecessors>>
 260     first predecessors>>
 261     first predecessors>>
 262     first  number>>
 263 ] cfg-unit-test
 264
 265 ! emit-call
 266 {
 267     V{ T{ ##call { word print } } T{ ##branch } }
 268 } [
 269     <basic-block> dup set-basic-block \ print 4 emit-call
 270     predecessors>> first instructions>>
 271 ] cfg-unit-test
 272
 273 ! emit-if
 274 { V{ 3 2 } } [
 275     <basic-block> dup set-basic-block ##branch,
 276     T{ #if
 277        { in-d { 9 } }
 278        { children
 279          {
 280              { T{ #push { literal 3 } { out-d { 6 } } } }
 281              { T{ #push { literal 2 } { out-d { 7 } } } }
 282          }
 283        }
 284        { live-branches { t t } }
 285     } emit-if
 286     predecessors>> [ instructions>> first val>> ] map
 287 ] cfg-unit-test
 288
 289 ! emit-loop-call
 290 { 1 "good" } [
 291     V{ } 0 insns>block dup set-basic-block
 292     V{ } "good" insns>block swap [ emit-loop-call ] keep
 293     [ successors>> length ] [ successors>> first number>> ] bi
 294 ] unit-test
 295
 296 ! emit-node
 297
 298 ! ! #call
 299 {
 300     V{
 301         T{ ##load-integer { dst 3 } { val 0 } }
 302         T{ ##add { dst 4 } { src1 3 } { src2 2 } }
 303         T{ ##load-memory-imm
 304            { dst 5 }
 305            { base 4 }
 306            { offset 0 }
 307            { rep int-rep }
 308         }
 309         T{ ##box-alien { dst 7 } { src 5 } { temp 6 } }
 310     }
 311 } [
 312     f T{ #call
 313        { word alien-cell }
 314        { in-d V{ 10 20 } }
 315        { out-d { 30 } }
 316     } [ emit-node drop ] V{ } make
 317 ] cfg-unit-test
 318
 319 : call-node-1 ( -- node )
 320     T{ #call
 321        { word set-slot }
 322        { in-d V{ 1 2 3 } }
 323        { out-d { } }
 324        { info
 325          H{
 326              {
 327                  1
 328                  T{ value-info-state
 329                     { class object }
 330                     { interval full-interval }
 331                  }
 332              }
 333              {
 334                  2
 335                  T{ value-info-state
 336                     { class object }
 337                     { interval full-interval }
 338                  }
 339              }
 340              {
 341                  3
 342                  T{ value-info-state
 343                     { class object }
 344                     { interval full-interval }
 345                  }
 346              }
 347          }
 348        }
 349     } ;
 350
 351 {
 352     V{ T{ ##call { word set-slot } } T{ ##branch } }
 353 } [
 354     [
 355          <basic-block> dup set-basic-block call-node-1 emit-node
 356     ] V{ } make drop
 357     predecessors>> first instructions>>
 358 ] cfg-unit-test
 359
 360 ! ! #push
 361 {
 362     { T{ ##load-integer { dst 78 } { val 0 } } }
 363 } [
 364     77 vreg-counter set-global
 365     [ f T{ #push { literal 0 } { out-d { 8537399 } } } emit-node drop ] { } make
 366 ] cfg-unit-test
 367
 368 ! ! #shuffle
 369 {
 370     T{ height-state f 0 0 1 0 }
 371     H{ { D: -1 4 } { D: 0 4 } }
 372 } [
 373     4 D: 0 replace-loc
 374     f T{ #shuffle
 375        { mapping { { 2 4 } { 3 4 } } }
 376        { in-d V{ 4 } }
 377        { out-d V{ 2 3 } }
 378     } emit-node drop
 379     height-state get
 380     replaces get
 381 ] cfg-unit-test
 382
 383 ! ! #terminate
 384
 385 { f } [
 386     <basic-block> dup set-basic-block
 387     T{ #terminate { in-d { } } { in-r { } } } emit-node
 388 ] cfg-unit-test
 389
 390 ! end-word
 391 {
 392     V{
 393         T{ ##safepoint }
 394         T{ ##epilogue }
 395         T{ ##return }
 396     }
 397 } [
 398     <basic-block> dup set-basic-block end-word instructions>>
 399 ] unit-test
 400
 401 ! height-changes
 402 { { -2 0 } } [
 403     T{ #shuffle { in-d { 37 81 92 } } { out-d { 20 } } } height-changes
 404 ] unit-test
 405
 406 ! make-input-map
 407 {
 408     { { 37 D: 2 } { 81 D: 1 } { 92 D: 0 } }
 409 } [
 410     T{ #shuffle { in-d { 37 81 92 } } } make-input-map
 411 ] unit-test
 412
 413 ! store-shuffle
 414 {
 415     H{ { D: 2 1 } }
 416 } [
 417     f T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
 418     emit-node drop replaces get
 419 ] cfg-unit-test
 420
 421 {
 422     H{ { D: -1 1 } { D: 0 1 } }
 423 } [
 424     f T{ #shuffle
 425        { in-d { 7 } }
 426        { out-d { 55 77 } }
 427        { mapping { { 55 7 } { 77 7 } } }
 428     } emit-node drop replaces get
 429 ] cfg-unit-test