basis/compiler/tests/codegen.factor

   1 USING: generalizations accessors arrays compiler kernel
   2 kernel.private math hashtables.private math.private namespaces
   3 sequences sequences.private tools.test namespaces.private
   4 slots.private sequences.private byte-arrays alien
   5 alien.accessors layouts words definitions compiler.units io
   6 combinators vectors grouping make ;
   7 IN: compiler.tests
   8
   9 ! Originally, this file did black box testing of templating
  10 ! optimization. We now have a different codegen, but the tests
  11 ! in here are still useful.
  12
  13 ! Oops!
  14 [ 5000 ] [ [ 5000 ] compile-call ] unit-test
  15 [ "hi" ] [ [ "hi" ] compile-call ] unit-test
  16
  17 [ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-call ] unit-test
  18
  19 [ 1 1 ] [ 1 [ dup ] compile-call ] unit-test
  20 [ 0 ] [ 3 [ tag ] compile-call ] unit-test
  21 [ 0 3 ] [ 3 [ [ tag ] keep ] compile-call ] unit-test
  22
  23 [ 2 3 ] [ 3 [ 2 swap ] compile-call ] unit-test
  24
  25 [ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-call ] unit-test
  26
  27 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
  28
  29 [ { 1 2 3 } { 1 4 3 } 3 3 ]
  30 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
  31 unit-test
  32
  33 ! Test literals in either side of a shuffle
  34 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
  35
  36 [ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
  37
  38 : foo ( -- ) ;
  39
  40 [ 5 5 ]
  41 [ 1.2 [ tag [ foo ] keep ] compile-call ]
  42 unit-test
  43
  44 [ 1 2 2 ]
  45 [ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-call ]
  46 unit-test
  47
  48 [ 3 ]
  49 [
  50     global [ 3 \ foo set ] bind
  51     \ foo [ global >n get ndrop ] compile-call
  52 ] unit-test
  53
  54 : blech drop ;
  55
  56 [ 3 ]
  57 [
  58     global [ 3 \ foo set ] bind
  59     \ foo [ global [ get ] swap blech call ] compile-call
  60 ] unit-test
  61
  62 [ 3 ]
  63 [
  64     global [ 3 \ foo set ] bind
  65     \ foo [ global [ get ] swap >n call ndrop ] compile-call
  66 ] unit-test
  67
  68 [ 3 ]
  69 [
  70     global [ 3 \ foo set ] bind
  71     \ foo [ global [ get ] bind ] compile-call
  72 ] unit-test
  73
  74 [ 12 13 ] [
  75     -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
  76 ] unit-test
  77
  78 [ -1 2 ] [ 1 2 [ [ 0 swap fixnum- ] dip ] compile-call ] unit-test
  79
  80 [ 12 13 ] [
  81     -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
  82 ] unit-test
  83
  84 [ 1 ] [
  85     SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
  86 ] unit-test
  87
  88 ! Test slow shuffles
  89 [ 3 1 2 3 4 5 6 7 8 9 ] [
  90     1 2 3 4 5 6 7 8 9
  91     [ [ [ [ [ [ [ [ [ [ 3 ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ]
  92     compile-call
  93 ] unit-test
  94
  95 [ 2 2 2 2 2 2 2 2 2 2 1 ] [
  96     1 2
  97     [ swap [ dup dup dup dup dup dup dup dup dup ] dip ] compile-call
  98 ] unit-test
  99
 100 [ ] [ [ 9 [ ] times ] compile-call ] unit-test
 101
 102 [ ] [
 103     [
 104         [ 200 dup [ 200 3array ] curry map drop ] times
 105     ] [ define-temp ] with-compilation-unit drop
 106 ] unit-test
 107
 108 ! Test how dispatch handles the end of a basic block
 109 : try-breaking-dispatch ( n a b -- x str )
 110     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
 111
 112 : try-breaking-dispatch-2 ( -- ? )
 113     1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
 114
 115 [ t ] [
 116     10000000 [ drop try-breaking-dispatch-2 ] all?
 117 ] unit-test
 118
 119 ! Regression
 120 : (broken) ( x -- y ) ;
 121
 122 [ 2.0 { 2.0 0.0 } ] [
 123     2.0 1.0
 124     [ float/f 0.0 [ drop (broken) ] 2keep 2array ] compile-call
 125 ] unit-test
 126
 127 ! Regression
 128 : hellish-bug-1 ( a b -- ) 2drop ;
 129
 130 : hellish-bug-2 ( i array x -- x )
 131     2dup 1 slot eq? [ 2drop ] [
 132         2dup array-nth tombstone? [
 133             [
 134                 [ array-nth ] 2keep [ 1 fixnum+fast ] dip array-nth
 135                 pick 2dup hellish-bug-1 3drop
 136             ] 2keep
 137         ] unless [ 2 fixnum+fast ] dip hellish-bug-2
 138     ] if ; inline recursive
 139
 140 : hellish-bug-3 ( hash array -- )
 141     0 swap hellish-bug-2 drop ;
 142
 143 [ ] [
 144     H{ { 1 2 } { 3 4 } } dup array>>
 145     [ 0 swap hellish-bug-2 drop ] compile-call
 146 ] unit-test
 147
 148 ! Regression
 149 : foox ( obj -- obj )
 150     dup not
 151     [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
 152
 153 [ 3 ] [ f foox ] unit-test
 154
 155 TUPLE: my-tuple ;
 156
 157 [ 4 ] [ T{ my-tuple } foox ] unit-test
 158
 159 [ 5 ] [ "hi" foox ] unit-test
 160
 161 ! Making sure we don't needlessly unbox/rebox
 162 [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ [ eq? ] dip ] compile-call ] unit-test
 163
 164 [ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call [ eq? ] dip ] unit-test
 165
 166 [ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
 167
 168 [ 1 B{ 1 2 3 4 } ] [
 169     B{ 1 2 3 4 } [
 170         { byte-array } declare
 171         [ 0 alien-unsigned-1 ] keep
 172     ] compile-call
 173 ] unit-test
 174
 175 [ 1 t ] [
 176     B{ 1 2 3 4 } [
 177         { c-ptr } declare
 178         [ 0 alien-unsigned-1 ] keep hi-tag
 179     ] compile-call byte-array type-number =
 180 ] unit-test
 181
 182 [ t ] [
 183     B{ 1 2 3 4 } [
 184         { c-ptr } declare
 185         0 alien-cell hi-tag
 186     ] compile-call alien type-number =
 187 ] unit-test
 188
 189 [ 2 1 ] [
 190     2 1
 191     [ 2dup fixnum< [ [ die ] dip ] when ] compile-call
 192 ] unit-test
 193
 194 ! Regression
 195 : a-dummy ( a -- ) drop "hi" print ;
 196
 197 [ ] [
 198     1 [
 199         dup 0 2 3dup pick >= [ >= ] [ 2drop f ] if [
 200             drop - >fixnum {
 201                 [ a-dummy ]
 202                 [ a-dummy ]
 203                 [ a-dummy ]
 204             } dispatch
 205         ] [ 2drop no-case ] if
 206     ] compile-call
 207 ] unit-test
 208
 209 ! Regression
 210 : dispatch-alignment-regression ( -- c )
 211     { tuple vector } 3 slot { word } declare
 212     dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
 213
 214 [ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
 215
 216 [ vector ] [ dispatch-alignment-regression ] unit-test
 217
 218 ! Regression
 219 : bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
 220
 221 [ { f f f } ] [ t bad-value-bug ] unit-test
 222
 223 ! PowerPC regression
 224 TUPLE: id obj ;
 225
 226 : (gc-check-bug) ( a b -- c )
 227     { [ id boa ] [ id boa ] } dispatch ;
 228
 229 : gc-check-bug ( -- )
 230     10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
 231
 232 [ ] [ gc-check-bug ] unit-test
 233
 234 ! New optimization
 235 : test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
 236
 237 [ "a" ] [ 8 test-1 ] unit-test
 238 [ "b" ] [ 9 test-1 ] unit-test
 239
 240 : test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
 241
 242 [ "a" ] [ 1 test-2 ] unit-test
 243 [ "b" ] [ 2 test-2 ] unit-test
 244
 245 ! I accidentally fixnum/i-fast on PowerPC
 246 [ { { 1 2 } { 3 4 } } ] [
 247     { 1 2 3 4 }
 248     [
 249         [ { array } declare 2 <groups> [ , ] each ] compile-call
 250     ] { } make
 251 ] unit-test
 252
 253 [ 2 ] [
 254     { 1 2 3 4 }
 255     [ { array } declare 2 <groups> length ] compile-call
 256 ] unit-test
 257
 258 ! Oops with new intrinsics
 259 : fixnum-overflow-control-flow-test ( a b -- c )
 260     [ 1 fixnum- ] [ 2 fixnum- ] if 3 fixnum+fast ;
 261
 262 [ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test
 263 [ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test
 264
 265 ! LOL
 266 : blah ( a -- b )
 267     { float } declare dup 0 =
 268     [ drop 1 ] [
 269         dup 0 >=
 270         [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
 271         [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
 272         if
 273     ] if ;
 274
 275 [ 4.0 ] [ 2.0 blah ] unit-test
 276
 277 [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
 278 [ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
 279
 280 TUPLE: cucumber ;
 281
 282 M: cucumber equal? "The cucumber has no equal" throw ;
 283
 284 [ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test