basis/compiler/tests/templates.factor

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