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