basis/math/vectors/simd/simd.factor

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