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

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