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 io 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 ] [ ##peek? ] contains-insn?
 203 ] unit-test
 204
 205 { f t } [
 206     [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
 207     [ [ ##unbox-any-c-ptr? ] contains-insn? ]
 208     [ [ ##unbox-alien? ] contains-insn? ] bi
 209 ] unit-test
 210
 211 \ alien-float "intrinsic" word-prop [
 212     [ f t ] [
 213         [ { byte-array fixnum } declare alien-cell 4 alien-float ]
 214         [ [ ##box-alien? ] contains-insn? ]
 215         [ [ ##allot? ] contains-insn? ] bi
 216     ] unit-test
 217
 218     [ f t ] [
 219         [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
 220         [ [ ##box-alien? ] contains-insn? ]
 221         [ [ ##allot? ] contains-insn? ] bi
 222     ] unit-test
 223
 224     [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
 225 ] when
 226
 227 ! Regression. Make sure everything is inlined correctly
 228 { f } [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
 229
 230 ! Regression. Make sure branch splitting works.
 231 { 2 } [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test
 232
 233 ! Make sure fast union predicates don't have conditionals.
 234 { f } [
 235     [ tag 1 swap fixnum-shift-fast ]
 236     [ ##compare-integer-imm-branch? ] contains-insn?
 237 ] unit-test
 238
 239 ! make-input-map
 240 {
 241     { { 37 D 2 } { 81 D 1 } { 92 D 0 } }
 242 } [
 243     T{ #shuffle { in-d { 37 81 92 } } } make-input-map
 244 ] unit-test
 245
 246 ! emit-call
 247 {
 248     V{ T{ ##call { word print } } T{ ##branch } }
 249 } [
 250     [ \ print 4 emit-call ] V{ } make drop
 251     basic-block get successors>> first instructions>>
 252 ] cfg-unit-test
 253
 254 ! emit-node
 255 {
 256     { T{ ##load-integer { dst 78 } { val 0 } } }
 257 } [
 258     77 vreg-counter set-global
 259     [
 260         T{ #push { literal 0 } { out-d { 8537399 } } } emit-node
 261     ] { } make
 262 ] cfg-unit-test
 263
 264 {
 265     { { 1 1 } { 0 0 } }
 266     H{ { D -1 4 } { D 0 4 } }
 267 } [
 268     4 D 0 replace-loc
 269     T{ #shuffle
 270        { mapping { { 2 4 } { 3 4 } } }
 271        { in-d V{ 4 } }
 272        { out-d V{ 2 3 } }
 273     } emit-node
 274     height-state get
 275     replaces get
 276 ] cfg-unit-test
 277
 278 { 1 } [
 279     V{ } 0 insns>block basic-block set init-cfg-test
 280     V{ } 1 insns>block [ emit-loop-call ] V{ } make drop
 281     basic-block get successors>> length
 282 ] unit-test
 283
 284 ! emit-loop-call
 285 { "bar" } [
 286     V{ } "foo" insns>block basic-block set init-cfg-test
 287     [ V{ } "bar" insns>block emit-loop-call ] V{ } make drop
 288     basic-block get successors>> first number>>
 289 ] unit-test
 290
 291 ! begin-cfg
 292 SYMBOL: foo
 293
 294 { foo } [
 295     \ foo f begin-cfg word>>
 296 ] cfg-unit-test
 297
 298 ! store-shuffle
 299 {
 300     H{ { D 2 1 } }
 301 } [
 302     T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
 303     emit-node replaces get
 304 ] cfg-unit-test
 305
 306 {
 307     H{ { D -1 1 } { D 0 1 } }
 308 } [
 309     T{ #shuffle
 310        { in-d { 7 } }
 311        { out-d { 55 77 } }
 312        { mapping { { 55 7 } { 77 7 } } }
 313     } emit-node replaces get
 314 ] cfg-unit-test