basis/math/vectors/simd/intrinsics/intrinsics.factor

   1 ! (c)2009 Slava Pestov, Joe Groff bsd license
   2 USING: accessors alien alien.data combinators
   3 sequences.cords cpu.architecture fry generalizations grouping
   4 kernel libc locals macros math math.libm math.order
   5 math.ranges math.vectors sequences sequences.generalizations
   6 sequences.private sequences.unrolled sequences.unrolled.private
   7 specialized-arrays vocabs words effects.parser locals.parser
   8 math.bitwise ;
   9 QUALIFIED-WITH: alien.c-types c
  10 SPECIALIZED-ARRAYS:
  11     c:char c:short c:int c:longlong
  12     c:uchar c:ushort c:uint c:ulonglong
  13     c:float c:double ;
  14 IN: math.vectors.simd.intrinsics
  15
  16 <<
  17 : simd-intrinsic-body ( def effect -- def' )
  18     '[ _ _ call-effect ] ;
  19
  20 : define-simd-intrinsic ( word def effect -- )
  21     [ simd-intrinsic-body ] keep define-declared ;
  22
  23 SYNTAX: SIMD-INTRINSIC:
  24     (:) define-declared ;
  25 SYNTAX: SIMD-INTRINSIC::
  26     (::) define-declared ;
  27
  28 >>
  29
  30 : assert-positive ( x -- y ) ;
  31
  32 <PRIVATE
  33
  34 : >bitwise-vector-rep ( rep -- rep' )
  35     {
  36         { float-4-rep    [ uint-4-rep      ] }
  37         { double-2-rep   [ ulonglong-2-rep ] }
  38         [ ]
  39     } case ; foldable
  40
  41 : >uint-vector-rep ( rep -- rep' )
  42     {
  43         { longlong-2-rep [ ulonglong-2-rep ] }
  44         { int-4-rep      [ uint-4-rep      ] }
  45         { short-8-rep    [ ushort-8-rep    ] }
  46         { char-16-rep    [ uchar-16-rep    ] }
  47         [ ]
  48     } case ; foldable
  49
  50 : >int-vector-rep ( rep -- rep' )
  51     {
  52         { float-4-rep  [ int-4-rep      ] }
  53         { double-2-rep [ longlong-2-rep ] }
  54     } case ; foldable
  55
  56 : >float-vector-rep ( rep -- rep' )
  57     {
  58         { int-4-rep      [ float-4-rep  ] }
  59         { longlong-2-rep [ double-2-rep ] }
  60     } case ; foldable
  61
  62 : [byte>rep-array] ( rep -- class )
  63     {
  64         { char-16-rep      [ [ 16 c:char <c-direct-array>      ] ] }
  65         { uchar-16-rep     [ [ 16 c:uchar <c-direct-array>     ] ] }
  66         { short-8-rep      [ [  8 c:short <c-direct-array>     ] ] }
  67         { ushort-8-rep     [ [  8 c:ushort <c-direct-array>    ] ] }
  68         { int-4-rep        [ [  4 c:int <c-direct-array>       ] ] }
  69         { uint-4-rep       [ [  4 c:uint <c-direct-array>      ] ] }
  70         { longlong-2-rep   [ [  2 c:longlong <c-direct-array>  ] ] }
  71         { ulonglong-2-rep  [ [  2 c:ulonglong <c-direct-array> ] ] }
  72         { float-4-rep      [ [  4 c:float <c-direct-array>     ] ] }
  73         { double-2-rep     [ [  2 c:double <c-direct-array>    ] ] }
  74     } case ; foldable
  75
  76 : [>rep-array] ( rep -- class )
  77     {
  78         { char-16-rep      [ [ c:char >c-array      ] ] }
  79         { uchar-16-rep     [ [ c:uchar >c-array     ] ] }
  80         { short-8-rep      [ [ c:short >c-array     ] ] }
  81         { ushort-8-rep     [ [ c:ushort >c-array    ] ] }
  82         { int-4-rep        [ [ c:int >c-array       ] ] }
  83         { uint-4-rep       [ [ c:uint >c-array      ] ] }
  84         { longlong-2-rep   [ [ c:longlong >c-array  ] ] }
  85         { ulonglong-2-rep  [ [ c:ulonglong >c-array ] ] }
  86         { float-4-rep      [ [ c:float >c-array     ] ] }
  87         { double-2-rep     [ [ c:double >c-array    ] ] }
  88     } case ; foldable
  89
  90 : [<rep-array>] ( rep -- class )
  91     {
  92         { char-16-rep      [ [ 16 c:char (c-array)      ] ] }
  93         { uchar-16-rep     [ [ 16 c:uchar (c-array)     ] ] }
  94         { short-8-rep      [ [  8 c:short (c-array)     ] ] }
  95         { ushort-8-rep     [ [  8 c:ushort (c-array)    ] ] }
  96         { int-4-rep        [ [  4 c:int (c-array)       ] ] }
  97         { uint-4-rep       [ [  4 c:uint (c-array)      ] ] }
  98         { longlong-2-rep   [ [  2 c:longlong (c-array)  ] ] }
  99         { ulonglong-2-rep  [ [  2 c:ulonglong (c-array) ] ] }
 100         { float-4-rep      [ [  4 c:float (c-array)     ] ] }
 101         { double-2-rep     [ [  2 c:double (c-array)    ] ] }
 102     } case ; foldable
 103
 104 : rep-tf-values ( rep -- t f )
 105     float-vector-rep? [ -1 bits>double 0.0 ] [ -1 0 ] if ;
 106
 107 : >rep-array ( a rep -- a' )
 108     [byte>rep-array] call( a -- a' ) ; inline
 109 : 2>rep-array ( a b rep -- a' b' )
 110     [byte>rep-array] '[ _ call( a -- a' ) ] bi@ ; inline
 111 : <rep-array> ( rep -- a' )
 112     [<rep-array>] call( -- a' ) ; inline
 113
 114 : components-map ( a rep quot -- c )
 115     [ [ >rep-array ] [ rep-length ] bi ] dip unrolled-map-unsafe underlying>> ; inline
 116 : components-2map ( a b rep quot -- c )
 117     [ [ 2>rep-array ] [ rep-length ] bi ] dip unrolled-2map-unsafe underlying>> ; inline
 118 ! XXX
 119 : components-reduce ( a rep quot -- x )
 120     [ >rep-array [ ] ] dip map-reduce ; inline
 121
 122 : bitwise-components-map ( a rep quot -- c )
 123     [ >bitwise-vector-rep [ >rep-array ] [ rep-length ] bi ] dip
 124     unrolled-map-unsafe underlying>> ; inline
 125 : bitwise-components-2map ( a b rep quot -- c )
 126     [ >bitwise-vector-rep [ 2>rep-array ] [ rep-length ] bi ] dip
 127     unrolled-2map-unsafe underlying>> ; inline
 128 ! XXX
 129 : bitwise-components-reduce ( a rep quot -- x )
 130     [ >bitwise-vector-rep >rep-array [ ] ] dip map-reduce ; inline
 131 : bitwise-components-reduce* ( a rep identity quot -- x )
 132     [ >bitwise-vector-rep >rep-array ] 2dip reduce ; inline
 133
 134 :: (vshuffle) ( a elts rep -- c )
 135     a rep >rep-array :> a'
 136     rep <rep-array> :> c'
 137     elts rep rep-length [| from to |
 138         from rep rep-length 1 - bitand
 139            a' nth-unsafe
 140         to c' set-nth-unsafe
 141     ] unrolled-each-index-unsafe
 142     c' underlying>> ; inline
 143
 144 :: (vshuffle2) ( a b elts rep -- c )
 145     a rep >rep-array :> a'
 146     b rep >rep-array :> b'
 147     a' b' cord-append :> ab'
 148     rep <rep-array> :> c'
 149     elts rep rep-length [| from to |
 150         from rep rep-length dup + 1 - bitand
 151            ab' nth-unsafe
 152         to c' set-nth-unsafe
 153     ] unrolled-each-index-unsafe
 154     c' underlying>> ; inline
 155
 156 GENERIC: native/ ( x y -- x/y )
 157
 158 M: integer native/ /i ; inline
 159 M: float native/ /f ; inline
 160
 161 : ((vgetmask)) ( a rep -- b )
 162     0 [ [ 1 shift ] [ zero? 0 1 ? ] bi* bitor ] bitwise-components-reduce* ; inline
 163
 164 PRIVATE>
 165
 166 SIMD-INTRINSIC: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
 167 SIMD-INTRINSIC: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
 168 SIMD-INTRINSIC: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
 169 SIMD-INTRINSIC:: (simd-v+-)              ( a b rep -- c )
 170     a b rep 2>rep-array :> ( a' b' )
 171     rep <rep-array> :> c'
 172     0  rep rep-length [ 1 -  2 <range> ] [ 2 /i ] bi [| n |
 173         n     a' nth-unsafe n     b' nth-unsafe -
 174         n     c' set-nth-unsafe
 175
 176         n 1 + a' nth-unsafe n 1 + b' nth-unsafe +
 177         n 1 + c' set-nth-unsafe
 178     ] unrolled-each-unsafe
 179     c' underlying>> ;
 180 SIMD-INTRINSIC: (simd-vs+)               ( a b rep -- c )
 181     dup rep-component-type '[ + _ c:c-type-clamp ] components-2map ;
 182 SIMD-INTRINSIC: (simd-vs-)               ( a b rep -- c )
 183     dup rep-component-type '[ - _ c:c-type-clamp ] components-2map ;
 184 SIMD-INTRINSIC: (simd-vs*)               ( a b rep -- c )
 185     dup rep-component-type '[ * _ c:c-type-clamp ] components-2map ;
 186 SIMD-INTRINSIC: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
 187 SIMD-INTRINSIC: (simd-v*high)            ( a b rep -- c )
 188     dup rep-component-type c:heap-size -8 * '[ * _ shift ] components-2map ;
 189 SIMD-INTRINSIC:: (simd-v*hs+)            ( a b rep -- c )
 190     rep { char-16-rep uchar-16-rep } member-eq?
 191     [ uchar-16-rep char-16-rep ]
 192     [ rep rep ] if :> ( a-rep b-rep )
 193     b-rep widen-vector-rep signed-rep :> wide-rep
 194     wide-rep rep-component-type :> wide-type
 195     a a-rep >rep-array 2 <groups> :> a'
 196     b b-rep >rep-array 2 <groups> :> b'
 197     a' b' rep rep-length 2 /i [
 198         [ [ first  ] bi@ * ]
 199         [ [ second ] bi@ * ] 2bi +
 200         wide-type c:c-type-clamp
 201     ] wide-rep <rep-array> unrolled-2map-as-unsafe underlying>> ;
 202 SIMD-INTRINSIC: (simd-v/)                ( a b rep -- c ) [ native/ ] components-2map ;
 203 SIMD-INTRINSIC: (simd-vavg)              ( a b rep -- c )
 204     [ + dup integer? [ 1 + -1 shift ] [ 0.5 * ] if ] components-2map ;
 205 SIMD-INTRINSIC: (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
 206 SIMD-INTRINSIC: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
 207 ! XXX
 208 SIMD-INTRINSIC: (simd-v.)                ( a b rep -- n )
 209     [ 2>rep-array [ [ first ] bi@ * ] 2keep ] keep
 210     1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ;
 211 SIMD-INTRINSIC: (simd-vsqrt)             ( a   rep -- c ) [ fsqrt ] components-map ;
 212 SIMD-INTRINSIC: (simd-vsad)              ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
 213 SIMD-INTRINSIC: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
 214 SIMD-INTRINSIC: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
 215 SIMD-INTRINSIC: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
 216 SIMD-INTRINSIC: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
 217 SIMD-INTRINSIC: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
 218 SIMD-INTRINSIC: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
 219 SIMD-INTRINSIC: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
 220 SIMD-INTRINSIC: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
 221 SIMD-INTRINSIC: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
 222 SIMD-INTRINSIC: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
 223 SIMD-INTRINSIC: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
 224 SIMD-INTRINSIC: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
 225 SIMD-INTRINSIC: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
 226 SIMD-INTRINSIC: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
 227 ! XXX
 228 SIMD-INTRINSIC: (simd-hlshift)           ( a n rep -- c )
 229     drop head-slice* 16 0 pad-head ;
 230 ! XXX
 231 SIMD-INTRINSIC: (simd-hrshift)           ( a n rep -- c )
 232     drop tail-slice 16 0 pad-tail ;
 233 SIMD-INTRINSIC: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
 234 SIMD-INTRINSIC: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
 235 SIMD-INTRINSIC: (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
 236 SIMD-INTRINSIC:: (simd-vmerge-head)      ( a b rep -- c )
 237     a b rep 2>rep-array :> ( a' b' )
 238     rep <rep-array> :> c'
 239     rep rep-length 2 /i [| n |
 240         n a' nth-unsafe n 2 *     c' set-nth-unsafe
 241         n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
 242     ] unrolled-each-integer
 243     c' underlying>> ;
 244 SIMD-INTRINSIC:: (simd-vmerge-tail)      ( a b rep -- c )
 245     a b rep 2>rep-array :> ( a' b' )
 246     rep <rep-array> :> c'
 247     rep rep-length 2 /i :> len
 248     len [| n |
 249         n len + a' nth-unsafe n 2 *     c' set-nth-unsafe
 250         n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
 251     ] unrolled-each-integer
 252     c' underlying>> ;
 253 SIMD-INTRINSIC: (simd-v<=)               ( a b rep -- c )
 254     dup rep-tf-values '[ <= _ _ ? ] components-2map ;
 255 SIMD-INTRINSIC: (simd-v<)                ( a b rep -- c )
 256     dup rep-tf-values '[ <  _ _ ? ] components-2map ;
 257 SIMD-INTRINSIC: (simd-v=)                ( a b rep -- c )
 258     dup rep-tf-values '[ =  _ _ ? ] components-2map ;
 259 SIMD-INTRINSIC: (simd-v>)                ( a b rep -- c )
 260     dup rep-tf-values '[ >  _ _ ? ] components-2map ;
 261 SIMD-INTRINSIC: (simd-v>=)               ( a b rep -- c )
 262     dup rep-tf-values '[ >= _ _ ? ] components-2map ;
 263 SIMD-INTRINSIC: (simd-vunordered?)       ( a b rep -- c )
 264     dup rep-tf-values '[ unordered? _ _ ? ] components-2map ;
 265 SIMD-INTRINSIC: (simd-vany?)             ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero? not ;
 266 SIMD-INTRINSIC: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
 267 SIMD-INTRINSIC: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
 268 SIMD-INTRINSIC: (simd-vgetmask)          ( a   rep -- n )
 269     { float-4-rep double-2-rep } member?
 270     [ uint-4-rep ((vgetmask)) ] [ uchar-16-rep ((vgetmask)) ] if ;
 271 SIMD-INTRINSIC: (simd-v>float)           ( a   rep -- c )
 272     [ [ >rep-array ] [ rep-length ] bi [ >float ] ]
 273     [ >float-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
 274 SIMD-INTRINSIC: (simd-v>integer)         ( a   rep -- c )
 275     [ [ >rep-array ] [ rep-length ] bi [ >integer ] ]
 276     [ >int-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
 277 SIMD-INTRINSIC: (simd-vpack-signed)      ( a b rep -- c )
 278     [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
 279     [ narrow-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
 280     '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
 281 SIMD-INTRINSIC: (simd-vpack-unsigned)    ( a b rep -- c )
 282     [ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
 283     [ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
 284     '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
 285 ! XXX
 286 SIMD-INTRINSIC: (simd-vunpack-head)      ( a   rep -- c )
 287     [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
 288     [ head-slice ] dip call( a' -- c' ) underlying>> ;
 289 ! XXX
 290 SIMD-INTRINSIC: (simd-vunpack-tail)      ( a   rep -- c )
 291     [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
 292     [ tail-slice ] dip call( a' -- c' ) underlying>> ;
 293 ! XXX
 294 SIMD-INTRINSIC: (simd-with)              (   n rep -- v )
 295     [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
 296     underlying>> ;
 297 SIMD-INTRINSIC: (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
 298 SIMD-INTRINSIC: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;
 299 SIMD-INTRINSIC: (simd-select)            ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
 300
 301 SIMD-INTRINSIC: alien-vector     (       c-ptr n rep -- value )
 302     [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
 303 SIMD-INTRINSIC: set-alien-vector ( value c-ptr n rep --       )
 304     [ swap <displaced-alien> swap ] dip rep-size memcpy ;
 305
 306 "compiler.cfg.intrinsics.simd" require
 307 "compiler.tree.propagation.simd" require
 308 "compiler.cfg.value-numbering.simd" require