basis/math/vectors/simd/simd.factor

   1 USING: accessors alien arrays byte-arrays classes combinators
   2 cpu.architecture effects functors generalizations kernel lexer
   3 literals math math.bitwise math.vectors
   4 math.vectors.simd.intrinsics parser prettyprint.custom
   5 quotations sequences sequences.generalizations sequences.private
   6 vocabs.loader words ;
   7 QUALIFIED-WITH: alien.c-types c
   8 IN: math.vectors.simd
   9
  10 ERROR: bad-simd-length got expected ;
  11 ERROR: bad-simd-vector obj ;
  12
  13 <<
  14 <PRIVATE
  15 ! Primitive SIMD constructors
  16
  17 GENERIC: new-underlying ( underlying seq -- seq' )
  18
  19 : make-underlying ( seq quot -- seq' )
  20     dip new-underlying ; inline
  21 : change-underlying ( seq quot -- seq' )
  22     '[ underlying>> @ ] keep new-underlying ; inline
  23 PRIVATE>
  24 >>
  25
  26 <PRIVATE
  27
  28 ! Helper for boolean vector literals
  29
  30 : vector-true-value ( class -- value )
  31     { c:float c:double } member? [ -1 bits>double ] [ -1 ] if ; foldable
  32
  33 : vector-false-value ( type -- value )
  34     { c:float c:double } member? [ 0.0 ] [ 0 ] if ; foldable
  35
  36 : boolean>element ( bool/elt type -- elt )
  37     swap {
  38         { t [ vector-true-value  ] }
  39         { f [ vector-false-value ] }
  40         [ nip ]
  41     } case ; inline
  42
  43 PRIVATE>
  44
  45 ! SIMD base type
  46
  47 TUPLE: simd-128
  48     { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
  49
  50 GENERIC: simd-element-type ( obj -- c-type )
  51 GENERIC: simd-rep ( simd -- rep )
  52 GENERIC: simd-with ( n exemplar -- v )
  53
  54 M: object simd-element-type drop f ;
  55 M: object simd-rep drop f ;
  56
  57 <<
  58 <PRIVATE
  59
  60 DEFER: simd-construct-op
  61
  62 ! Unboxers for SIMD operations
  63 : if-both-vectors ( a b rep t f -- )
  64     [ 2over [ simd-128? ] both? ] 2dip if ; inline
  65
  66 : if-both-vectors-match ( a b rep t f -- )
  67     [ 3dup [ drop [ simd-128? ] both? ] [ '[ simd-rep _ eq? ] both? ] 3bi and ]
  68     2dip if ; inline
  69
  70 : simd-unbox ( a -- a (a) )
  71     [ ] [ underlying>> ] bi ; inline
  72
  73 : v->v-op ( a rep quot: ( (a) rep -- (c) ) fallback-quot -- c )
  74     drop [ simd-unbox ] 2dip 2curry make-underlying ; inline
  75
  76 : vx->v-op ( a obj rep quot: ( (a) obj rep -- (c) ) fallback-quot -- c )
  77     drop [ simd-unbox ] 3dip 3curry make-underlying ; inline
  78
  79 : vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c )
  80     drop [ [ simd-unbox ] [ >fixnum ] bi* ] 2dip 3curry make-underlying ; inline
  81
  82 : vx->x-op ( a obj rep quot: ( (a) obj rep -- obj ) fallback-quot -- obj )
  83     drop [ underlying>> ] 3dip call ; inline
  84
  85 : v->x-op ( a rep quot: ( (a) rep -- obj ) fallback-quot -- obj )
  86     drop [ underlying>> ] 2dip call ; inline
  87
  88 : (vv->v-op) ( a b rep quot: ( (a) (b) rep -- (c) ) -- c )
  89     [ [ simd-unbox ] [ underlying>> ] bi* ] 2dip 3curry make-underlying ; inline
  90
  91 : (vv->x-op) ( a b rep quot: ( (a) (b) rep -- n ) -- n )
  92     [ [ underlying>> ] bi@ ] 2dip 3curry call ; inline
  93
  94 : (vvx->v-op) ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) -- c )
  95     [ [ simd-unbox ] [ underlying>> ] bi* ] 3dip 2curry 2curry make-underlying ; inline
  96
  97 : vv->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
  98     [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
  99
 100 :: vvx->v-op ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) fallback-quot -- c )
 101     a b rep
 102     [ obj swap quot (vvx->v-op) ]
 103     [ drop obj fallback-quot call ] if-both-vectors-match ; inline
 104
 105 : vv'->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
 106     [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors ; inline
 107
 108 : vv->x-op ( a b rep quot: ( (a) (b) rep -- obj ) fallback-quot -- obj )
 109     [ '[ _ (vv->x-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
 110
 111 : mask>count ( n rep -- n' )
 112     [ bit-count ] dip {
 113         { float-4-rep     [ ] }
 114         { double-2-rep    [ -1 shift ] }
 115         { uchar-16-rep    [ ] }
 116         { char-16-rep     [ ] }
 117         { ushort-8-rep    [ -1 shift ] }
 118         { short-8-rep     [ -1 shift ] }
 119         { ushort-8-rep    [ -1 shift ] }
 120         { int-4-rep       [ -2 shift ] }
 121         { uint-4-rep      [ -2 shift ] }
 122         { longlong-2-rep  [ -3 shift ] }
 123         { ulonglong-2-rep [ -3 shift ] }
 124     } case ; inline
 125
 126 PRIVATE>
 127 >>
 128
 129 <<
 130
 131 ! SIMD vectors as sequences
 132
 133 M: simd-128 hashcode* underlying>> hashcode* ; inline
 134 M: simd-128 clone [ clone ] change-underlying ; inline
 135 M: simd-128 byte-length drop 16 ; inline
 136
 137 M: simd-128 new-sequence
 138     2dup length =
 139     [ nip [ 16 (byte-array) ] make-underlying ]
 140     [ length bad-simd-length ] if ; inline
 141
 142 M: simd-128 equal?
 143     dup simd-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
 144
 145 ! SIMD primitive operations
 146
 147 M: simd-128 v+
 148     dup simd-rep [ (simd-v+) ] [ call-next-method ] vv->v-op ; inline
 149 M: simd-128 v-
 150     dup simd-rep [ (simd-v-) ] [ call-next-method ] vv->v-op ; inline
 151 M: simd-128 vneg
 152     dup simd-rep [ (simd-vneg) ] [ call-next-method ] v->v-op  ; inline
 153 M: simd-128 v+-
 154     dup simd-rep [ (simd-v+-) ] [ call-next-method ] vv->v-op ; inline
 155 M: simd-128 vs+
 156     dup simd-rep [ (simd-vs+) ] [ call-next-method ] vv->v-op ; inline
 157 M: simd-128 vs-
 158     dup simd-rep [ (simd-vs-) ] [ call-next-method ] vv->v-op ; inline
 159 M: simd-128 vs*
 160     dup simd-rep [ (simd-vs*) ] [ call-next-method ] vv->v-op ; inline
 161 M: simd-128 v*
 162     dup simd-rep [ (simd-v*) ] [ call-next-method ] vv->v-op ; inline
 163 M: simd-128 v*high
 164     dup simd-rep [ (simd-v*high) ] [ call-next-method ] vv->v-op ; inline
 165 M: simd-128 v/
 166     dup simd-rep [ (simd-v/) ] [ call-next-method ] vv->v-op ; inline
 167 M: simd-128 vavg
 168     dup simd-rep [ (simd-vavg) ] [ call-next-method ] vv->v-op ; inline
 169 M: simd-128 vmin
 170     dup simd-rep [ (simd-vmin) ] [ call-next-method ] vv->v-op ; inline
 171 M: simd-128 vmax
 172     dup simd-rep [ (simd-vmax) ] [ call-next-method ] vv->v-op ; inline
 173 M: simd-128 vdot
 174     dup simd-rep [ (simd-vdot) ] [ call-next-method ] vv->x-op ; inline
 175 M: simd-128 vsad
 176     dup simd-rep [ (simd-vsad) ] [ call-next-method ] vv->x-op ; inline
 177 M: simd-128 vsqrt
 178     dup simd-rep [ (simd-vsqrt) ] [ call-next-method ] v->v-op  ; inline
 179 M: simd-128 sum
 180     dup simd-rep [ (simd-sum) ] [ call-next-method ] v->x-op  ; inline
 181 M: simd-128 vabs
 182     dup simd-rep [ (simd-vabs) ] [ call-next-method ] v->v-op  ; inline
 183 M: simd-128 vbitand
 184     dup simd-rep [ (simd-vbitand) ] [ call-next-method ] vv->v-op ; inline
 185 M: simd-128 vbitandn
 186     dup simd-rep [ (simd-vbitandn) ] [ call-next-method ] vv->v-op ; inline
 187 M: simd-128 vbitor
 188     dup simd-rep [ (simd-vbitor) ] [ call-next-method ] vv->v-op ; inline
 189 M: simd-128 vbitxor
 190     dup simd-rep [ (simd-vbitxor) ] [ call-next-method ] vv->v-op ; inline
 191 M: simd-128 vbitnot
 192     dup simd-rep [ (simd-vbitnot) ] [ call-next-method ] v->v-op  ; inline
 193 M: simd-128 vand
 194     dup simd-rep [ (simd-vand) ] [ call-next-method ] vv->v-op ; inline
 195 M: simd-128 vandn
 196     dup simd-rep [ (simd-vandn) ] [ call-next-method ] vv->v-op ; inline
 197 M: simd-128 vor
 198     dup simd-rep [ (simd-vor) ] [ call-next-method ] vv->v-op ; inline
 199 M: simd-128 vxor
 200     dup simd-rep [ (simd-vxor) ] [ call-next-method ] vv->v-op ; inline
 201 M: simd-128 vnot
 202     dup simd-rep [ (simd-vnot) ] [ call-next-method ] v->v-op  ; inline
 203 M: simd-128 vlshift
 204     over simd-rep [ (simd-vlshift) ] [ call-next-method ] vn->v-op ; inline
 205 M: simd-128 vrshift
 206     over simd-rep [ (simd-vrshift) ] [ call-next-method ] vn->v-op ; inline
 207 M: simd-128 hlshift
 208     over simd-rep [ (simd-hlshift) ] [ call-next-method ] vn->v-op ; inline
 209 M: simd-128 hrshift
 210     over simd-rep [ (simd-hrshift) ] [ call-next-method ] vn->v-op ; inline
 211 M: simd-128 vshuffle-elements
 212     over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vx->v-op ; inline
 213 M: simd-128 vshuffle2-elements
 214     over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvx->v-op ; inline
 215 M: simd-128 vshuffle-bytes
 216     dup simd-rep [ (simd-vshuffle-bytes) ] [ call-next-method ] vv'->v-op ; inline
 217 M: simd-128 (vmerge-head)
 218     dup simd-rep [ (simd-vmerge-head) ] [ call-next-method ] vv->v-op ; inline
 219 M: simd-128 (vmerge-tail)
 220     dup simd-rep [ (simd-vmerge-tail) ] [ call-next-method ] vv->v-op ; inline
 221 M: simd-128 v<=
 222     dup simd-rep [ (simd-v<=) ] [ call-next-method ] vv->v-op ; inline
 223 M: simd-128 v<
 224     dup simd-rep [ (simd-v<) ] [ call-next-method ] vv->v-op ; inline
 225 M: simd-128 v=
 226     dup simd-rep [ (simd-v=) ] [ call-next-method ] vv->v-op ; inline
 227 M: simd-128 v>
 228     dup simd-rep [ (simd-v>) ] [ call-next-method ] vv->v-op ; inline
 229 M: simd-128 v>=
 230     dup simd-rep [ (simd-v>=) ] [ call-next-method ] vv->v-op ; inline
 231 M: simd-128 vunordered?
 232     dup simd-rep [ (simd-vunordered?) ] [ call-next-method ] vv->v-op ; inline
 233 M: simd-128 vany?
 234     dup simd-rep [ (simd-vany?) ] [ call-next-method ] v->x-op  ; inline
 235 M: simd-128 vall?
 236     dup simd-rep [ (simd-vall?) ] [ call-next-method ] v->x-op  ; inline
 237 M: simd-128 vnone?
 238     dup simd-rep [ (simd-vnone?) ] [ call-next-method ] v->x-op  ; inline
 239 M: simd-128 vcount
 240     dup simd-rep
 241     [ [ (simd-vgetmask) assert-positive ] [ call-next-method ] v->x-op ]
 242     [ mask>count ] bi ; inline
 243
 244 ! SIMD high-level specializations
 245
 246 M: simd-128 vbroadcast swap [ nth ] [ simd-with ] bi ; inline
 247 M: simd-128 n+v [ simd-with ] keep v+ ; inline
 248 M: simd-128 n-v [ simd-with ] keep v- ; inline
 249 M: simd-128 n*v [ simd-with ] keep v* ; inline
 250 M: simd-128 n/v [ simd-with ] keep v/ ; inline
 251 M: simd-128 v+n over simd-with v+ ; inline
 252 M: simd-128 v-n over simd-with v- ; inline
 253 M: simd-128 v*n over simd-with v* ; inline
 254 M: simd-128 v/n over simd-with v/ ; inline
 255 M: simd-128 norm-sq dup vdot assert-positive ; inline
 256 M: simd-128 distance v- norm ; inline
 257
 258 M: simd-128 >pprint-sequence ;
 259 M: simd-128 pprint* pprint-object ;
 260
 261 <PRIVATE
 262
 263 ! SIMD concrete type functor
 264
 265 <FUNCTOR: define-simd-128 ( T -- )
 266
 267 A      DEFINES-CLASS ${T}
 268 A-rep  IS            ${T}-rep
 269 >A     DEFINES       >${T}
 270 A-boa  DEFINES       ${T}-boa
 271 A-with DEFINES       ${T}-with
 272 A-cast DEFINES       ${T}-cast
 273 A{     DEFINES       ${T}{
 274
 275 ELT     [ A-rep rep-component-type ]
 276 N       [ A-rep rep-length ]
 277 COERCER [ ELT c:c-type-class "coercer" word-prop [ ] or ]
 278
 279 BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
 280
 281 WHERE
 282
 283 TUPLE: A < simd-128 ; final
 284
 285 M: A new-underlying    drop \ A boa ; inline
 286 M: A simd-rep          drop A-rep ; inline
 287 M: A simd-element-type drop ELT ; inline
 288 M: A simd-with         drop A-with ; inline
 289
 290 M: A nth-unsafe
 291     swap \ A-rep [ (simd-select) ] [ call-next-method ] vx->x-op ; inline
 292 M: A set-nth-unsafe
 293     [ ELT boolean>element ] 2dip
 294     underlying>> ELT c:set-alien-element ; inline
 295
 296 : >A ( seq -- simd ) \ A new clone-like ; inline
 297
 298 M: A like drop dup \ A instance? [ >A ] unless ; inline
 299
 300 : A-with ( n -- v ) COERCER call \ A-rep (simd-with) \ A boa ; inline
 301 : A-cast ( v -- v' ) underlying>> \ A boa ; inline
 302
 303 M: A length drop N ; inline
 304
 305 \ A-boa
 306 [ COERCER N napply ] N {
 307     { 2 [ [ A-rep (simd-gather-2) A boa ] ] }
 308     { 4 [ [ A-rep (simd-gather-4) A boa ] ] }
 309     [ \ A new '[ _ _ nsequence ] ]
 310 } case compose
 311 BOA-EFFECT define-inline
 312
 313 M: A pprint-delims drop \ A{ \ } ;
 314 SYNTAX: A{ \ } [ >A ] parse-literal ;
 315
 316 INSTANCE: A sequence
 317
 318 c:<c-type>
 319     byte-array >>class
 320     A >>boxed-class
 321     { A-rep alien-vector A boa } >quotation >>getter
 322     {
 323         [ dup simd-128? [ bad-simd-vector ] unless underlying>> ] 2dip
 324         A-rep set-alien-vector
 325     } >quotation >>setter
 326     16 >>size
 327     16 >>align
 328     A-rep >>rep
 329 \ A c:typedef
 330
 331 ;FUNCTOR>
 332
 333 SYNTAX: SIMD-128:
 334     scan-token define-simd-128 ;
 335
 336 PRIVATE>
 337
 338 >>
 339
 340 ! SIMD instances
 341
 342 SIMD-128: char-16
 343 SIMD-128: uchar-16
 344 SIMD-128: short-8
 345 SIMD-128: ushort-8
 346 SIMD-128: int-4
 347 SIMD-128: uint-4
 348 SIMD-128: longlong-2
 349 SIMD-128: ulonglong-2
 350 SIMD-128: float-4
 351 SIMD-128: double-2
 352
 353 ! misc
 354
 355 M: simd-128 vshuffle
 356     vshuffle-bytes ; inline
 357
 358 M: uchar-16 v*hs+
 359     uchar-16-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op short-8-cast ; inline
 360 M: ushort-8 v*hs+
 361     ushort-8-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op uint-4-cast ; inline
 362 M: uint-4 v*hs+
 363     uint-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op ulonglong-2-cast ; inline
 364 M: char-16 v*hs+
 365     char-16-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op short-8-cast ; inline
 366 M: short-8 v*hs+
 367     short-8-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op int-4-cast ; inline
 368 M: int-4 v*hs+
 369     int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline
 370
 371 { "math.vectors.simd" "mirrors" } "math.vectors.simd.mirrors" require-when