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