basis/compiler/cfg/intrinsics/simd/simd.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien byte-arrays fry cpu.architecture kernel math
   4 sequences math.vectors math.vectors.simd.intrinsics macros
   5 generalizations combinators combinators.short-circuit arrays locals
   6 compiler.tree.propagation.info compiler.cfg.builder.blocks
   7 compiler.cfg.comparisons
   8 compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
   9 compiler.cfg.instructions compiler.cfg.registers
  10 compiler.cfg.intrinsics.alien
  11 specialized-arrays ;
  12 FROM: alien.c-types => heap-size char uchar float double ;
  13 SPECIALIZED-ARRAYS: float double ;
  14 IN: compiler.cfg.intrinsics.simd
  15
  16 MACRO: check-elements ( quots -- )
  17     [ length '[ _ firstn ] ]
  18     [ '[ _ spread ] ]
  19     [ length 1 - \ and <repetition> [ ] like ]
  20     tri 3append ;
  21
  22 MACRO: if-literals-match ( quots -- )
  23     [ length ] [ ] [ length ] tri
  24     ! n quots n
  25     '[
  26         ! node quot
  27         [
  28             dup node-input-infos
  29             _ tail-slice* [ literal>> ] map
  30             dup _ check-elements
  31         ] dip
  32         swap [
  33             ! node literals quot
  34             [ _ firstn ] dip call
  35             drop
  36         ] [ 2drop emit-primitive ] if
  37     ] ;
  38
  39 : emit-vector-op ( node quot: ( rep -- ) -- )
  40     { [ representation? ] } if-literals-match ; inline
  41
  42 : [binary] ( quot -- quot' )
  43     '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
  44
  45 : emit-binary-vector-op ( node quot -- )
  46     [binary] emit-vector-op ; inline
  47
  48 : [unary] ( quot -- quot' )
  49     '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
  50
  51 : emit-unary-vector-op ( node quot -- )
  52     [unary] emit-vector-op ; inline
  53
  54 : [unary/param] ( quot -- quot' )
  55     '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
  56
  57 : emit-horizontal-shift ( node quot -- )
  58     [unary/param]
  59     { [ integer? ] [ representation? ] } if-literals-match ; inline
  60
  61 : emit-gather-vector-2 ( node -- )
  62     [ ^^gather-vector-2 ] emit-binary-vector-op ;
  63
  64 : emit-gather-vector-4 ( node -- )
  65     [
  66         ds-drop
  67         [
  68             D 3 peek-loc
  69             D 2 peek-loc
  70             D 1 peek-loc
  71             D 0 peek-loc
  72             -4 inc-d
  73         ] dip
  74         ^^gather-vector-4
  75         ds-push
  76     ] emit-vector-op ;
  77
  78 : variable-shuffle? ( obj -- ? )
  79     ! the vshuffle intrinsic current doesn't allow variable shuffles
  80     drop f ;
  81
  82 : immediate-shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
  83
  84 : shuffle? ( obj -- ? ) { [ variable-shuffle? ] [ immediate-shuffle? ] } 1|| ;
  85
  86 : (>variable-shuffle) ( shuffle rep -- shuffle )
  87     rep-component-type heap-size
  88     [ dup <repetition> >byte-array ]
  89     [ iota >byte-array ] bi
  90     '[ _ n*v _ v+ ] map concat ;
  91
  92 : >variable-shuffle ( shuffle rep -- shuffle' )
  93     over immediate-shuffle? [ (>variable-shuffle) ] [ drop ] if ;
  94
  95 : generate-shuffle-vector-imm? ( shuffle rep -- ? )
  96     {
  97         [ drop immediate-shuffle? ]
  98         [ nip %shuffle-vector-imm-reps member? ]
  99     } 2&& ;
 100
 101 : generate-shuffle-vector ( src shuffle rep -- dst )
 102     2dup generate-shuffle-vector-imm?
 103     [ ^^shuffle-vector-imm ]
 104     [
 105         [ >variable-shuffle ^^load-constant ] keep
 106         ^^shuffle-vector
 107     ] if ;
 108
 109 : emit-shuffle-vector ( node -- )
 110     ! Pad the permutation with zeroes if it's too short, since we
 111     ! can't throw an error at this point.
 112     [ [ rep-components 0 pad-tail ] keep generate-shuffle-vector ] [unary/param]
 113     { [ shuffle? ] [ representation? ] } if-literals-match ;
 114
 115 : ^^broadcast-vector ( src n rep -- dst )
 116     [ rep-components swap <array> ] keep
 117     generate-shuffle-vector ;
 118
 119 : emit-broadcast-vector ( node -- )
 120     [ ^^broadcast-vector ] [unary/param]
 121     { [ integer? ] [ representation? ] } if-literals-match ;
 122
 123 : ^^with-vector ( src rep -- dst )
 124     [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
 125
 126 : ^^select-vector ( src n rep -- dst )
 127     [ ^^broadcast-vector ] keep ^^vector>scalar ;
 128
 129 : emit-select-vector ( node -- )
 130     [ ^^select-vector ] [unary/param]
 131     { [ integer? ] [ representation? ] } if-literals-match ; inline
 132
 133 : emit-alien-vector ( node -- )
 134     dup [
 135         '[
 136             ds-drop prepare-alien-getter
 137             _ ^^alien-vector ds-push
 138         ]
 139         [ inline-alien-getter? ] inline-alien
 140     ] with emit-vector-op ;
 141
 142 : emit-set-alien-vector ( node -- )
 143     dup [
 144         '[
 145             ds-drop prepare-alien-setter ds-pop
 146             _ ##set-alien-vector
 147         ]
 148         [ byte-array inline-alien-setter? ]
 149         inline-alien
 150     ] with emit-vector-op ;
 151
 152 : generate-not-vector ( src rep -- dst )
 153     dup %not-vector-reps member?
 154     [ ^^not-vector ]
 155     [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
 156
 157 :: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
 158     {cc,swap} first2 :> swap? :> cc
 159     swap?
 160     [ src2 src1 rep cc ^^compare-vector ]
 161     [ src1 src2 rep cc ^^compare-vector ] if ;
 162
 163 :: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
 164     rep orig-cc %compare-vector-ccs :> not? :> ccs
 165
 166     ccs empty?
 167     [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
 168     [
 169         ccs unclip :> first-cc :> rest-ccs
 170         src1 src2 rep first-cc (generate-compare-vector) :> first-dst
 171
 172         rest-ccs first-dst
 173         [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
 174         reduce
 175
 176         not? [ rep generate-not-vector ] when
 177     ] if ;
 178
 179 :: generate-unpack-vector-head ( src rep -- dst )
 180     {
 181         {
 182             [ rep %unpack-vector-head-reps member? ]
 183             [ src rep ^^unpack-vector-head ]
 184         }
 185         [
 186             rep ^^zero-vector :> zero
 187             zero src rep cc> ^^compare-vector :> sign
 188             src sign rep ^^merge-vector-head
 189         ]
 190     } cond ;
 191
 192 :: generate-unpack-vector-tail ( src rep -- dst )
 193     {
 194         {
 195             [ rep %unpack-vector-tail-reps member? ]
 196             [ src rep ^^unpack-vector-tail ]
 197         }
 198         {
 199             [ rep %unpack-vector-head-reps member? ]
 200             [
 201                 src rep ^^tail>head-vector :> tail
 202                 tail rep ^^unpack-vector-head
 203             ]
 204         }
 205         [
 206             rep ^^zero-vector :> zero
 207             zero src rep cc> ^^compare-vector :> sign
 208             src sign rep ^^merge-vector-tail
 209         ]
 210     } cond ;
 211
 212 :: generate-load-neg-zero-vector ( rep -- dst )
 213     rep {
 214         { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
 215         { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
 216         [ drop rep ^^zero-vector ]
 217     } case ;
 218
 219 :: generate-neg-vector ( src rep -- dst )
 220     rep generate-load-neg-zero-vector
 221     src rep ^^sub-vector ;
 222
 223 :: generate-blend-vector ( mask true false rep -- dst )
 224     mask true rep ^^and-vector
 225     mask false rep ^^andn-vector
 226     rep ^^or-vector ;
 227
 228 :: generate-abs-vector ( src rep -- dst )
 229     {
 230         {
 231             [ rep unsigned-int-vector-rep? ]
 232             [ src ]
 233         }
 234         {
 235             [ rep %abs-vector-reps member? ]
 236             [ src rep ^^abs-vector ]
 237         }
 238         {
 239             [ rep float-vector-rep? ]
 240             [
 241                 rep generate-load-neg-zero-vector
 242                 src rep ^^andn-vector
 243             ]
 244         }
 245         [
 246             rep ^^zero-vector :> zero
 247             zero src rep ^^sub-vector :> -src
 248             zero src rep cc> ^^compare-vector :> sign
 249             sign -src src rep generate-blend-vector
 250         ]
 251     } cond ;
 252