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

   1 USING: tools.test kernel sequences words sequences.private fry
   2 prettyprint alien alien.accessors math.private compiler.tree.builder
   3 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
   4 compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
   5 compiler.cfg arrays locals byte-arrays kernel.private math
   6 slots.private vectors sbufs strings math.partial-dispatch
   7 hashtables assocs combinators.short-circuit
   8 strings.private accessors compiler.cfg.instructions ;
   9 IN: compiler.cfg.builder.tests
  10
  11 ! Just ensure that various CFGs build correctly.
  12 : unit-test-cfg ( quot -- )
  13     '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
  14
  15 : blahblah ( nodes -- ? )
  16     { fixnum } declare [
  17         dup 3 bitand 1 = [ drop t ] [
  18             dup 3 bitand 2 = [
  19                 blahblah
  20             ] [ drop f ] if
  21         ] if
  22     ] any? ; inline recursive
  23
  24 : more? ( x -- ? ) ;
  25
  26 : test-case-1 ( -- ? ) f ;
  27
  28 : test-case-2 ( -- )
  29     test-case-1 [ test-case-2 ] [ ] if ; inline recursive
  30
  31 {
  32     [ ]
  33     [ dup ]
  34     [ swap ]
  35     [ [ ] dip ]
  36     [ fixnum+ ]
  37     [ fixnum+fast ]
  38     [ 3 fixnum+fast ]
  39     [ fixnum*fast ]
  40     [ 3 fixnum*fast ]
  41     [ 3 swap fixnum*fast ]
  42     [ fixnum-shift-fast ]
  43     [ 10 fixnum-shift-fast ]
  44     [ -10 fixnum-shift-fast ]
  45     [ 0 fixnum-shift-fast ]
  46     [ 10 swap fixnum-shift-fast ]
  47     [ -10 swap fixnum-shift-fast ]
  48     [ 0 swap fixnum-shift-fast ]
  49     [ fixnum-bitnot ]
  50     [ eq? ]
  51     [ "hi" eq? ]
  52     [ fixnum< ]
  53     [ 5 fixnum< ]
  54     [ float+ ]
  55     [ 3.0 float+ ]
  56     [ float<= ]
  57     [ fixnum>bignum ]
  58     [ bignum>fixnum ]
  59     [ fixnum>float ]
  60     [ float>fixnum ]
  61     [ 3 f <array> ]
  62     [ [ 1 ] [ 2 ] if ]
  63     [ fixnum< [ 1 ] [ 2 ] if ]
  64     [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
  65     [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
  66     [ [ t ] loop ]
  67     [ [ dup ] loop ]
  68     [ [ 2 ] [ 3 throw ] if 4 ]
  69     [ "int" f "malloc" { "int" } alien-invoke ]
  70     [ "int" { "int" } "cdecl" alien-indirect ]
  71     [ "int" { "int" } "cdecl" [ ] alien-callback ]
  72     [ swap - + * ]
  73     [ swap slot ]
  74     [ blahblah ]
  75     [ 1000 [ dup [ reverse ] when ] times ]
  76     [ 1array ]
  77     [ 1 2 ? ]
  78     [ { array } declare [ ] map ]
  79     [ { array } declare dup 1 slot [ 1 slot ] when ]
  80     [ [ dup more? ] [ dup ] produce ]
  81     [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
  82     [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
  83     [
  84         { fixnum sbuf } declare 2dup 3 slot fixnum> [
  85             over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
  86         ] [ ] if
  87     ]
  88     [ [ 2 fixnum* ] when 3 ]
  89     [ [ 2 fixnum+ ] when 3 ]
  90     [ [ 2 fixnum- ] when 3 ]
  91     [ 10000 [ ] times ]
  92     [
  93         over integer? [
  94             over dup 16 <-integer-fixnum
  95             [ 0 >=-integer-fixnum ] [ drop f ] if [
  96                 nip dup
  97                 [ ] [ ] if
  98             ] [ 2drop f ] if
  99         ] [ 2drop f ] if
 100     ]
 101     [
 102         pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
 103         set-string-nth-fast
 104     ]
 105 } [
 106     unit-test-cfg
 107 ] each
 108
 109 : test-1 ( -- ) test-1 ;
 110 : test-2 ( -- ) 3 . test-2 ;
 111 : test-3 ( a -- b ) dup [ test-3 ] when ;
 112
 113 {
 114     test-1
 115     test-2
 116     test-3
 117 } [ unit-test-cfg ] each
 118
 119 {
 120     byte-array
 121     simple-alien
 122     alien
 123     POSTPONE: f
 124 } [| class |
 125     {
 126         alien-signed-1
 127         alien-signed-2
 128         alien-signed-4
 129         alien-unsigned-1
 130         alien-unsigned-2
 131         alien-unsigned-4
 132         alien-cell
 133         alien-float
 134         alien-double
 135     } [| word |
 136         { class } word '[ _ declare 10 _ execute ] unit-test-cfg
 137         { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
 138     ] each
 139
 140     {
 141         set-alien-signed-1
 142         set-alien-signed-2
 143         set-alien-signed-4
 144         set-alien-unsigned-1
 145         set-alien-unsigned-2
 146         set-alien-unsigned-4
 147     } [| word |
 148         { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
 149         { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
 150     ] each
 151
 152     { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
 153     { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
 154
 155     { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
 156     { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
 157
 158     { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
 159     { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
 160 ] each
 161
 162 : count-insns ( quot insn-check -- ? )
 163     [ test-mr [ instructions>> ] map ] dip
 164     '[ _ count ] sigma ; inline
 165
 166 : contains-insn? ( quot insn-check -- ? )
 167     count-insns 0 > ; inline
 168
 169 [ t ] [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
 170
 171 [ f ] [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
 172
 173 [ t ] [
 174     [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
 175     [ ##set-alien-integer-1? ] contains-insn?
 176 ] unit-test
 177
 178 [ t ] [
 179     [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
 180     [ ##set-alien-integer-1? ] contains-insn?
 181 ] unit-test
 182
 183 [ f ] [
 184     [ { byte-array fixnum } declare set-alien-unsigned-1 ]
 185     [ ##set-alien-integer-1? ] contains-insn?
 186 ] unit-test
 187
 188 [ f ] [
 189     [ 1000 [ ] times ]
 190     [ [ ##peek? ] [ ##replace? ] bi or ] contains-insn?
 191 ] unit-test
 192
 193 [ f t ] [
 194     [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
 195     [ [ ##unbox-any-c-ptr? ] contains-insn? ]
 196     [ [ ##unbox-alien? ] contains-insn? ] bi
 197 ] unit-test
 198
 199 \ alien-float "intrinsic" word-prop [
 200     [ f t ] [
 201         [ { byte-array fixnum } declare alien-cell 4 alien-float ]
 202         [ [ ##box-alien? ] contains-insn? ]
 203         [ [ ##allot? ] contains-insn? ] bi
 204     ] unit-test
 205
 206     [ f t ] [
 207         [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
 208         [ [ ##box-alien? ] contains-insn? ]
 209         [ [ ##allot? ] contains-insn? ] bi
 210     ] unit-test
 211
 212     [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
 213 ] when
 214
 215 ! Regression. Make sure everything is inlined correctly
 216 [ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test