basis/math/vectors/simd/simd.factor

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