basis/math/vectors/simd/simd.factor

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