basis/compiler/cfg/intrinsics/simd/simd.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien byte-arrays fry classes.algebra
   4 cpu.architecture kernel math sequences math.vectors
   5 math.vectors.simd macros generalizations combinators
   6 combinators.short-circuit arrays locals
   7 compiler.tree.propagation.info compiler.cfg.builder.blocks
   8 compiler.cfg.comparisons
   9 compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
  10 compiler.cfg.instructions compiler.cfg.registers
  11 compiler.cfg.intrinsics.alien
  12 specialized-arrays ;
  13 FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
  14 SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
  15 IN: compiler.cfg.intrinsics.simd
  16
  17 MACRO: check-elements ( quots -- )
  18     [ length '[ _ firstn ] ]
  19     [ '[ _ spread ] ]
  20     [ length 1 - \ and <repetition> [ ] like ]
  21     tri 3append ;
  22
  23 MACRO: if-literals-match ( quots -- )
  24     [ length ] [ ] [ length ] tri
  25     ! n quots n
  26     '[
  27         ! node quot
  28         [
  29             dup node-input-infos
  30             _ tail-slice* [ literal>> ] map
  31             dup _ check-elements
  32         ] dip
  33         swap [
  34             ! node literals quot
  35             [ _ firstn ] dip call
  36             drop
  37         ] [ 2drop emit-primitive ] if
  38     ] ;
  39
  40 : emit-vector-op ( node quot: ( rep -- ) -- )
  41     { [ representation? ] } if-literals-match ; inline
  42
  43 : [binary] ( quot -- quot' )
  44     '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
  45
  46 : emit-binary-vector-op ( node quot -- )
  47     [binary] emit-vector-op ; inline
  48
  49 : [unary] ( quot -- quot' )
  50     '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
  51
  52 : emit-unary-vector-op ( node quot -- )
  53     [unary] emit-vector-op ; inline
  54
  55 : [unary/param] ( quot -- quot' )
  56     '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
  57
  58 : emit-shift-vector-imm-op ( node quot -- )
  59     [unary/param]
  60     { [ integer? ] [ representation? ] } if-literals-match ; inline
  61
  62 :: emit-shift-vector-op ( node imm-quot var-quot -- )
  63     node node-input-infos 2 tail-slice* first literal>> integer?
  64     [ node imm-quot emit-shift-vector-imm-op ]
  65     [ node var-quot emit-binary-vector-op ] if ; inline
  66
  67 : emit-gather-vector-2 ( node -- )
  68     [ ^^gather-vector-2 ] emit-binary-vector-op ;
  69
  70 : emit-gather-vector-4 ( node -- )
  71     [
  72         ds-drop
  73         [
  74             D 3 peek-loc
  75             D 2 peek-loc
  76             D 1 peek-loc
  77             D 0 peek-loc
  78             -4 inc-d
  79         ] dip
  80         ^^gather-vector-4
  81         ds-push
  82     ] emit-vector-op ;
  83
  84 : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
  85
  86 : >variable-shuffle ( shuffle rep -- shuffle' )
  87     rep-component-type heap-size
  88     [ dup <repetition> >byte-array ]
  89     [ iota >byte-array ] bi
  90     '[ _ n*v _ v+ ] map concat ;
  91
  92 : generate-shuffle-vector-imm ( src shuffle rep -- dst )
  93     dup %shuffle-vector-imm-reps member?
  94     [ ^^shuffle-vector-imm ]
  95     [
  96         [ >variable-shuffle ^^load-constant ] keep
  97         ^^shuffle-vector
  98     ] if ;
  99
 100 : emit-shuffle-vector-imm ( node -- )
 101     ! Pad the permutation with zeroes if it's too short, since we
 102     ! can't throw an error at this point.
 103     [ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param]
 104     { [ shuffle? ] [ representation? ] } if-literals-match ;
 105
 106 : emit-shuffle-vector-var ( node -- )
 107     [ ^^shuffle-vector ] [binary]
 108     { [ %shuffle-vector-reps member? ] } if-literals-match ;
 109
 110 : emit-shuffle-vector ( node -- )
 111     dup node-input-infos {
 112         [ length 3 = ]
 113         [ first  class>> byte-array class<= ]
 114         [ second class>> byte-array class<= ]
 115         [ third  literal>> representation?  ]
 116     } 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ;
 117
 118 : ^^broadcast-vector ( src n rep -- dst )
 119     [ rep-components swap <array> ] keep
 120     generate-shuffle-vector-imm ;
 121
 122 : emit-broadcast-vector ( node -- )
 123     [ ^^broadcast-vector ] [unary/param]
 124     { [ integer? ] [ representation? ] } if-literals-match ;
 125
 126 : ^^with-vector ( src rep -- dst )
 127     [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
 128
 129 : ^^select-vector ( src n rep -- dst )
 130     [ ^^broadcast-vector ] keep ^^vector>scalar ;
 131
 132 : emit-select-vector ( node -- )
 133     [ ^^select-vector ] [unary/param]
 134     { [ integer? ] [ representation? ] } if-literals-match ; inline
 135
 136 : emit-alien-vector-op ( node quot: ( rep -- ) -- )
 137     { [ %alien-vector-reps member? ] } if-literals-match ; inline
 138
 139 : emit-alien-vector ( node -- )
 140     dup [
 141         '[
 142             ds-drop prepare-alien-getter
 143             _ ^^alien-vector ds-push
 144         ]
 145         [ inline-alien-getter? ] inline-alien
 146     ] with emit-alien-vector-op ;
 147
 148 : emit-set-alien-vector ( node -- )
 149     dup [
 150         '[
 151             ds-drop prepare-alien-setter ds-pop
 152             _ ##set-alien-vector
 153         ]
 154         [ byte-array inline-alien-setter? ]
 155         inline-alien
 156     ] with emit-alien-vector-op ;
 157
 158 : generate-not-vector ( src rep -- dst )
 159     dup %not-vector-reps member?
 160     [ ^^not-vector ]
 161     [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
 162
 163 :: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
 164     {cc,swap} first2 :> ( cc swap? )
 165     swap?
 166     [ src2 src1 rep cc ^^compare-vector ]
 167     [ src1 src2 rep cc ^^compare-vector ] if ;
 168
 169 :: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
 170     rep orig-cc %compare-vector-ccs :> ( ccs not? )
 171
 172     ccs empty?
 173     [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
 174     [
 175         ccs unclip :> ( rest-ccs first-cc )
 176         src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
 177
 178         rest-ccs first-dst
 179         [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
 180         reduce
 181
 182         not? [ rep generate-not-vector ] when
 183     ] if ;
 184
 185 : sign-bit-mask ( rep -- byte-array )
 186     unsign-rep {
 187         { char-16-rep [ uchar-array{
 188             HEX: 80 HEX: 80 HEX: 80 HEX: 80
 189             HEX: 80 HEX: 80 HEX: 80 HEX: 80
 190             HEX: 80 HEX: 80 HEX: 80 HEX: 80
 191             HEX: 80 HEX: 80 HEX: 80 HEX: 80
 192         } underlying>> ] }
 193         { short-8-rep [ ushort-array{
 194             HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
 195             HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
 196         } underlying>> ] }
 197         { int-4-rep [ uint-array{
 198             HEX: 8000,0000 HEX: 8000,0000
 199             HEX: 8000,0000 HEX: 8000,0000
 200         } underlying>> ] }
 201         { longlong-2-rep [ ulonglong-array{
 202             HEX: 8000,0000,0000,0000
 203             HEX: 8000,0000,0000,0000
 204         } underlying>> ] }
 205     } case ;
 206
 207 :: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
 208     orig-cc order-cc {
 209         { cc<  [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
 210         { cc<= [ src1 src2 rep ^^min-vector src1 rep cc=  (generate-compare-vector) ] }
 211         { cc>  [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
 212         { cc>= [ src1 src2 rep ^^max-vector src1 rep cc=  (generate-compare-vector) ] }
 213     } case ;
 214
 215 :: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
 216     {
 217         {
 218             [ rep orig-cc %compare-vector-reps member? ]
 219             [ src1 src2 rep orig-cc (generate-compare-vector) ]
 220         }
 221         {
 222             [ rep %min-vector-reps member? ]
 223             [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
 224         }
 225         {
 226             [ rep unsign-rep orig-cc %compare-vector-reps member? ]
 227             [
 228                 rep sign-bit-mask ^^load-constant :> sign-bits
 229                 src1 sign-bits rep ^^xor-vector
 230                 src2 sign-bits rep ^^xor-vector
 231                 rep unsign-rep orig-cc (generate-compare-vector)
 232             ]
 233         }
 234     } cond ;
 235
 236 :: generate-unpack-vector-head ( src rep -- dst )
 237     {
 238         {
 239             [ rep %unpack-vector-head-reps member? ]
 240             [ src rep ^^unpack-vector-head ]
 241         }
 242         {
 243             [ rep unsigned-int-vector-rep? ]
 244             [
 245                 rep ^^zero-vector :> zero
 246                 src zero rep ^^merge-vector-head
 247             ]
 248         }
 249         {
 250             [ rep widen-vector-rep %shr-vector-imm-reps member? ]
 251             [
 252                 src src rep ^^merge-vector-head
 253                 rep rep-component-type
 254                 heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
 255             ]
 256         }
 257         [
 258             rep ^^zero-vector :> zero
 259             zero src rep cc> ^^compare-vector :> sign
 260             src sign rep ^^merge-vector-head
 261         ]
 262     } cond ;
 263
 264 :: generate-unpack-vector-tail ( src rep -- dst )
 265     {
 266         {
 267             [ rep %unpack-vector-tail-reps member? ]
 268             [ src rep ^^unpack-vector-tail ]
 269         }
 270         {
 271             [ rep %unpack-vector-head-reps member? ]
 272             [
 273                 src rep ^^tail>head-vector :> tail
 274                 tail rep ^^unpack-vector-head
 275             ]
 276         }
 277         {
 278             [ rep unsigned-int-vector-rep? ]
 279             [
 280                 rep ^^zero-vector :> zero
 281                 src zero rep ^^merge-vector-tail
 282             ]
 283         }
 284         {
 285             [ rep widen-vector-rep %shr-vector-imm-reps member? ]
 286             [
 287                 src src rep ^^merge-vector-tail
 288                 rep rep-component-type
 289                 heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
 290             ]
 291         }
 292         [
 293             rep ^^zero-vector :> zero
 294             zero src rep cc> ^^compare-vector :> sign
 295             src sign rep ^^merge-vector-tail
 296         ]
 297     } cond ;
 298
 299 :: generate-load-neg-zero-vector ( rep -- dst )
 300     rep {
 301         { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
 302         { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
 303         [ drop rep ^^zero-vector ]
 304     } case ;
 305
 306 :: generate-neg-vector ( src rep -- dst )
 307     rep generate-load-neg-zero-vector
 308     src rep ^^sub-vector ;
 309
 310 :: generate-blend-vector ( mask true false rep -- dst )
 311     mask true rep ^^and-vector
 312     mask false rep ^^andn-vector
 313     rep ^^or-vector ;
 314
 315 :: generate-abs-vector ( src rep -- dst )
 316     {
 317         {
 318             [ rep unsigned-int-vector-rep? ]
 319             [ src ]
 320         }
 321         {
 322             [ rep %abs-vector-reps member? ]
 323             [ src rep ^^abs-vector ]
 324         }
 325         {
 326             [ rep float-vector-rep? ]
 327             [
 328                 rep generate-load-neg-zero-vector
 329                 src rep ^^andn-vector
 330             ]
 331         }
 332         [
 333             rep ^^zero-vector :> zero
 334             zero src rep ^^sub-vector :> -src
 335             zero src rep cc> ^^compare-vector :> sign
 336             sign -src src rep generate-blend-vector
 337         ]
 338     } cond ;
 339
 340 : generate-min-vector ( src1 src2 rep -- dst )
 341     dup %min-vector-reps member?
 342     [ ^^min-vector ] [
 343         [ cc< generate-compare-vector ]
 344         [ generate-blend-vector ] 3bi
 345     ] if ;
 346
 347 : generate-max-vector ( src1 src2 rep -- dst )
 348     dup %max-vector-reps member?
 349     [ ^^max-vector ] [
 350         [ cc> generate-compare-vector ]
 351         [ generate-blend-vector ] 3bi
 352     ] if ;
 353
 354 : enable-simd ( -- )
 355     {
 356         { math.vectors.simd:assert-positive [ drop ] }
 357         { math.vectors.simd:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
 358         { math.vectors.simd:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] }
 359         { math.vectors.simd:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] }
 360         { math.vectors.simd:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
 361         { math.vectors.simd:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] }
 362         { math.vectors.simd:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] }
 363         { math.vectors.simd:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
 364         { math.vectors.simd:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
 365         { math.vectors.simd:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
 366         { math.vectors.simd:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
 367         { math.vectors.simd:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
 368         { math.vectors.simd:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
 369         { math.vectors.simd:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
 370         { math.vectors.simd:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
 371         { math.vectors.simd:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
 372         { math.vectors.simd:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
 373         { math.vectors.simd:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
 374         { math.vectors.simd:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
 375         { math.vectors.simd:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
 376         { math.vectors.simd:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] }
 377         { math.vectors.simd:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
 378         { math.vectors.simd:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] }
 379         { math.vectors.simd:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
 380         { math.vectors.simd:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
 381         { math.vectors.simd:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] }
 382         { math.vectors.simd:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] }
 383         { math.vectors.simd:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] }
 384         { math.vectors.simd:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] }
 385         { math.vectors.simd:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] }
 386         { math.vectors.simd:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] }
 387         { math.vectors.simd:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
 388         { math.vectors.simd:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
 389         { math.vectors.simd:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
 390         { math.vectors.simd:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
 391         { math.vectors.simd:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] }
 392         { math.vectors.simd:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
 393         { math.vectors.simd:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] }
 394         { math.vectors.simd:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
 395         { math.vectors.simd:(simd-gather-2) [ emit-gather-vector-2 ] }
 396         { math.vectors.simd:(simd-gather-4) [ emit-gather-vector-4 ] }
 397         { math.vectors.simd:(simd-vshuffle-elements) [ emit-shuffle-vector ] }
 398         { math.vectors.simd:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] }
 399         { math.vectors.simd:(simd-vmerge-head) [ [ ^^merge-vector-head ] emit-binary-vector-op ] }
 400         { math.vectors.simd:(simd-vmerge-tail) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] }
 401         { math.vectors.simd:(simd-v>float) [ [ ^^integer>float-vector ] emit-unary-vector-op ] }
 402         { math.vectors.simd:(simd-v>integer) [ [ ^^float>integer-vector ] emit-unary-vector-op ] }
 403         { math.vectors.simd:(simd-vpack-signed) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] }
 404         { math.vectors.simd:(simd-vpack-unsigned) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] }
 405         { math.vectors.simd:(simd-vunpack-head) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] }
 406         { math.vectors.simd:(simd-vunpack-tail) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] }
 407         { math.vectors.simd:(simd-select) [ emit-select-vector ] }
 408         { math.vectors.simd:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
 409         { math.vectors.simd:alien-vector [ emit-alien-vector ] }
 410         { math.vectors.simd:set-alien-vector [ emit-set-alien-vector ] }
 411     } enable-intrinsics ;
 412
 413 enable-simd