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 ( byte-array rep -- array )
  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 ; inline
  75
  76 : >rep-array ( seq rep -- array )
  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 ; inline
  89
  90 : <rep-array> ( rep -- array )
  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 ; inline
 103
 104 : rep-tf-values ( rep -- t f )
 105     float-vector-rep? [ -1 bits>double 0.0 ] [ -1 0 ] if ;
 106
 107 : 2byte>rep-array ( a b rep -- a' b' )
 108     '[ _ byte>rep-array ] bi@ ; inline
 109
 110 : components-map ( a rep quot -- c )
 111     [ [ byte>rep-array ] [ rep-length ] bi ] dip unrolled-map-unsafe underlying>> ; inline
 112 : components-2map ( a b rep quot -- c )
 113     [ [ 2byte>rep-array ] [ rep-length ] bi ] dip unrolled-2map-unsafe underlying>> ; inline
 114 : components-reduce ( a rep quot -- x )
 115     [ byte>rep-array [ ] ] dip map-reduce ; inline
 116
 117 : bitwise-components-map ( a rep quot -- c )
 118     [ >bitwise-vector-rep [ byte>rep-array ] [ rep-length ] bi ] dip
 119     unrolled-map-unsafe underlying>> ; inline
 120 : bitwise-components-2map ( a b rep quot -- c )
 121     [ >bitwise-vector-rep [ 2byte>rep-array ] [ rep-length ] bi ] dip
 122     unrolled-2map-unsafe underlying>> ; inline
 123 : bitwise-components-reduce ( a rep quot -- x )
 124     [ >bitwise-vector-rep byte>rep-array [ ] ] dip map-reduce ; inline
 125 : bitwise-components-reduce* ( a rep identity quot -- x )
 126     [ >bitwise-vector-rep byte>rep-array ] 2dip reduce ; inline
 127
 128 :: (vshuffle) ( a elts rep -- c )
 129     a rep byte>rep-array :> a'
 130     rep <rep-array> :> c'
 131     elts rep rep-length [| from to |
 132         from rep rep-length 1 - bitand
 133            a' nth-unsafe
 134         to c' set-nth-unsafe
 135     ] unrolled-each-index-unsafe
 136     c' underlying>> ; inline
 137
 138 :: (vshuffle2) ( a b elts rep -- c )
 139     a rep byte>rep-array :> a'
 140     b rep byte>rep-array :> b'
 141     a' b' cord-append :> ab'
 142     rep <rep-array> :> c'
 143     elts rep rep-length [| from to |
 144         from rep rep-length dup + 1 - bitand
 145            ab' nth-unsafe
 146         to c' set-nth-unsafe
 147     ] unrolled-each-index-unsafe
 148     c' underlying>> ; inline
 149
 150 GENERIC: native/ ( x y -- x/y )
 151
 152 M: integer native/ /i ; inline
 153 M: float native/ /f ; inline
 154
 155 : ((vgetmask)) ( a rep -- b )
 156     0 [ [ 1 shift ] [ zero? 0 1 ? ] bi* bitor ] bitwise-components-reduce* ; inline
 157
 158 PRIVATE>
 159
 160 SIMD-INTRINSIC: (simd-v+)                ( a b rep -- c ) [ + ] components-2map ;
 161 SIMD-INTRINSIC: (simd-v-)                ( a b rep -- c ) [ - ] components-2map ;
 162 SIMD-INTRINSIC: (simd-vneg)              ( a   rep -- c ) [ neg ] components-map ;
 163 SIMD-INTRINSIC:: (simd-v+-)              ( a b rep -- c )
 164     a b rep 2byte>rep-array :> ( a' b' )
 165     rep <rep-array> :> c'
 166     0  rep rep-length [ 1 -  2 <range> ] [ 2 /i ] bi [| n |
 167         n     a' nth-unsafe n     b' nth-unsafe -
 168         n     c' set-nth-unsafe
 169
 170         n 1 + a' nth-unsafe n 1 + b' nth-unsafe +
 171         n 1 + c' set-nth-unsafe
 172     ] unrolled-each-unsafe
 173     c' underlying>> ;
 174 SIMD-INTRINSIC: (simd-vs+)               ( a b rep -- c )
 175     dup rep-component-type '[ + _ c:c-type-clamp ] components-2map ;
 176 SIMD-INTRINSIC: (simd-vs-)               ( a b rep -- c )
 177     dup rep-component-type '[ - _ c:c-type-clamp ] components-2map ;
 178 SIMD-INTRINSIC: (simd-vs*)               ( a b rep -- c )
 179     dup rep-component-type '[ * _ c:c-type-clamp ] components-2map ;
 180 SIMD-INTRINSIC: (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
 181 SIMD-INTRINSIC: (simd-v*high)            ( a b rep -- c )
 182     dup rep-component-type c:heap-size -8 * '[ * _ shift ] components-2map ;
 183 SIMD-INTRINSIC:: (simd-v*hs+)            ( a b rep -- c )
 184     rep { char-16-rep uchar-16-rep } member-eq?
 185     [ uchar-16-rep char-16-rep ]
 186     [ rep rep ] if :> ( a-rep b-rep )
 187     b-rep widen-vector-rep signed-rep :> wide-rep
 188     wide-rep rep-component-type :> wide-type
 189     a a-rep byte>rep-array 2 <groups> :> a'
 190     b b-rep byte>rep-array 2 <groups> :> b'
 191     a' b' rep rep-length 2 /i [
 192         [ [ first  ] bi@ * ]
 193         [ [ second ] bi@ * ] 2bi +
 194         wide-type c:c-type-clamp
 195     ] wide-rep <rep-array> unrolled-2map-as-unsafe underlying>> ;
 196 SIMD-INTRINSIC: (simd-v/)                ( a b rep -- c ) [ native/ ] components-2map ;
 197 SIMD-INTRINSIC: (simd-vavg)              ( a b rep -- c )
 198     [ + dup integer? [ 1 + -1 shift ] [ 0.5 * ] if ] components-2map ;
 199 SIMD-INTRINSIC: (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
 200 SIMD-INTRINSIC: (simd-vmax)              ( a b rep -- c ) [ max ] components-2map ;
 201 ! XXX
 202 SIMD-INTRINSIC: (simd-v.)                ( a b rep -- n )
 203     [ 2byte>rep-array [ [ first ] bi@ * ] 2keep ] keep
 204     1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ;
 205 SIMD-INTRINSIC: (simd-vsqrt)             ( a   rep -- c ) [ fsqrt ] components-map ;
 206 SIMD-INTRINSIC: (simd-vsad)              ( a b rep -- c ) 2byte>rep-array [ - abs ] [ + ] 2map-reduce ;
 207 SIMD-INTRINSIC: (simd-sum)               ( a   rep -- n ) [ + ] components-reduce ;
 208 SIMD-INTRINSIC: (simd-vabs)              ( a   rep -- c ) [ abs ] components-map ;
 209 SIMD-INTRINSIC: (simd-vbitand)           ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
 210 SIMD-INTRINSIC: (simd-vbitandn)          ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
 211 SIMD-INTRINSIC: (simd-vbitor)            ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
 212 SIMD-INTRINSIC: (simd-vbitxor)           ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
 213 SIMD-INTRINSIC: (simd-vbitnot)           ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
 214 SIMD-INTRINSIC: (simd-vand)              ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
 215 SIMD-INTRINSIC: (simd-vandn)             ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
 216 SIMD-INTRINSIC: (simd-vor)               ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
 217 SIMD-INTRINSIC: (simd-vxor)              ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
 218 SIMD-INTRINSIC: (simd-vnot)              ( a   rep -- c ) [ bitnot ] bitwise-components-map ;
 219 SIMD-INTRINSIC: (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
 220 SIMD-INTRINSIC: (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
 221 ! XXX
 222 SIMD-INTRINSIC: (simd-hlshift)           ( a n rep -- c )
 223     drop head-slice* 16 0 pad-head ;
 224 ! XXX
 225 SIMD-INTRINSIC: (simd-hrshift)           ( a n rep -- c )
 226     drop tail-slice 16 0 pad-tail ;
 227 SIMD-INTRINSIC: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
 228 SIMD-INTRINSIC: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
 229 SIMD-INTRINSIC: (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
 230 SIMD-INTRINSIC:: (simd-vmerge-head)      ( a b rep -- c )
 231     a b rep 2byte>rep-array :> ( a' b' )
 232     rep <rep-array> :> c'
 233     rep rep-length 2 /i [| n |
 234         n a' nth-unsafe n 2 *     c' set-nth-unsafe
 235         n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
 236     ] unrolled-each-integer
 237     c' underlying>> ;
 238 SIMD-INTRINSIC:: (simd-vmerge-tail)      ( a b rep -- c )
 239     a b rep 2byte>rep-array :> ( a' b' )
 240     rep <rep-array> :> c'
 241     rep rep-length 2 /i :> len
 242     len [| n |
 243         n len + a' nth-unsafe n 2 *     c' set-nth-unsafe
 244         n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
 245     ] unrolled-each-integer
 246     c' underlying>> ;
 247 SIMD-INTRINSIC: (simd-v<=)               ( a b rep -- c )
 248     dup rep-tf-values '[ <= _ _ ? ] components-2map ;
 249 SIMD-INTRINSIC: (simd-v<)                ( a b rep -- c )
 250     dup rep-tf-values '[ <  _ _ ? ] components-2map ;
 251 SIMD-INTRINSIC: (simd-v=)                ( a b rep -- c )
 252     dup rep-tf-values '[ =  _ _ ? ] components-2map ;
 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-vunordered?)       ( a b rep -- c )
 258     dup rep-tf-values '[ unordered? _ _ ? ] components-2map ;
 259 SIMD-INTRINSIC: (simd-vany?)             ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero? not ;
 260 SIMD-INTRINSIC: (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
 261 SIMD-INTRINSIC: (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
 262 SIMD-INTRINSIC: (simd-vgetmask)          ( a   rep -- n )
 263     { float-4-rep double-2-rep } member?
 264     [ uint-4-rep ((vgetmask)) ] [ uchar-16-rep ((vgetmask)) ] if ;
 265 SIMD-INTRINSIC: (simd-v>float)           ( a   rep -- c )
 266     [ [ byte>rep-array ] [ rep-length ] bi [ >float ] ]
 267     [ >float-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
 268 SIMD-INTRINSIC: (simd-v>integer)         ( a   rep -- c )
 269     [ [ byte>rep-array ] [ rep-length ] bi [ >integer ] ]
 270     [ >int-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
 271 SIMD-INTRINSIC: (simd-vpack-signed)      ( a b rep -- c )
 272     [ [ 2byte>rep-array cord-append ] [ rep-length 2 * ] bi ]
 273     [ narrow-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
 274     '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
 275 SIMD-INTRINSIC: (simd-vpack-unsigned)    ( a b rep -- c )
 276     [ [ 2byte>rep-array cord-append ] [ rep-length 2 * ] bi ]
 277     [ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
 278     '[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
 279 SIMD-INTRINSIC: (simd-vunpack-head)      ( a   rep -- c )
 280     [ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi
 281     [ head-slice ] dip call( a' -- c' ) underlying>> ;
 282 SIMD-INTRINSIC: (simd-vunpack-tail)      ( a   rep -- c )
 283     [ byte>rep-array ] [ widen-vector-rep [ rep-length ] [ '[ _ >rep-array ] ] bi ] bi
 284     [ tail-slice ] dip call( a' -- c' ) underlying>> ;
 285 SIMD-INTRINSIC: (simd-with)              (   n rep -- v )
 286     [ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
 287     underlying>> ;
 288 SIMD-INTRINSIC: (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
 289 SIMD-INTRINSIC: (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;
 290 SIMD-INTRINSIC: (simd-select)            ( a n rep -- x ) swapd byte>rep-array nth-unsafe ;
 291
 292 SIMD-INTRINSIC: alien-vector     (       c-ptr n rep -- value )
 293     [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
 294 SIMD-INTRINSIC: set-alien-vector ( value c-ptr n rep --       )
 295     [ swap <displaced-alien> swap ] dip rep-size memcpy ;
 296
 297 "compiler.cfg.intrinsics.simd" require
 298 "compiler.tree.propagation.simd" require
 299 "compiler.cfg.value-numbering.simd" require