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 byte-arrays fry cpu.architecture kernel math
   4 sequences math.vectors.simd.intrinsics macros generalizations
   5 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 IN: compiler.cfg.intrinsics.simd
  12
  13 MACRO: check-elements ( quots -- )
  14     [ length '[ _ firstn ] ]
  15     [ '[ _ spread ] ]
  16     [ length 1 - \ and <repetition> [ ] like ]
  17     tri 3append ;
  18
  19 MACRO: if-literals-match ( quots -- )
  20     [ length ] [ ] [ length ] tri
  21     ! n quots n n
  22     '[
  23         ! node quot
  24         [
  25             dup node-input-infos
  26             _ tail-slice* [ literal>> ] map
  27             dup _ check-elements
  28         ] dip
  29         swap [
  30             ! node literals quot
  31             [ _ firstn ] dip call
  32             drop
  33         ] [ 2drop emit-primitive ] if
  34     ] ;
  35
  36 : emit-vector-op ( node quot: ( rep -- ) -- )
  37     { [ representation? ] } if-literals-match ; inline
  38
  39 : [binary] ( quot -- quot' )
  40     '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
  41
  42 : emit-binary-vector-op ( node quot -- )
  43     [binary] emit-vector-op ; inline
  44
  45 : [unary] ( quot -- quot' )
  46     '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
  47
  48 : emit-unary-vector-op ( node quot -- )
  49     [unary] emit-vector-op ; inline
  50
  51 : [unary/param] ( quot -- quot' )
  52     '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
  53
  54 : emit-horizontal-shift ( node quot -- )
  55     [unary/param]
  56     { [ integer? ] [ representation? ] } if-literals-match ; inline
  57
  58 : emit-gather-vector-2 ( node -- )
  59     [ ^^gather-vector-2 ] emit-binary-vector-op ;
  60
  61 : emit-gather-vector-4 ( node -- )
  62     [
  63         ds-drop
  64         [
  65             D 3 peek-loc
  66             D 2 peek-loc
  67             D 1 peek-loc
  68             D 0 peek-loc
  69             -4 inc-d
  70         ] dip
  71         ^^gather-vector-4
  72         ds-push
  73     ] emit-vector-op ;
  74
  75 : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
  76
  77 : emit-shuffle-vector ( node -- )
  78     ! Pad the permutation with zeroes if its too short, since we
  79     ! can't throw an error at this point.
  80     [ [ rep-components 0 pad-tail ] keep ^^shuffle-vector ] [unary/param]
  81     { [ shuffle? ] [ representation? ] } if-literals-match ;
  82
  83 : ^^broadcast-vector ( src n rep -- dst )
  84     [ rep-components swap <array> ] keep
  85     ^^shuffle-vector ;
  86
  87 : emit-broadcast-vector ( node -- )
  88     [ ^^broadcast-vector ] [unary/param]
  89     { [ integer? ] [ representation? ] } if-literals-match ;
  90
  91 : ^^with-vector ( src rep -- dst )
  92     [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
  93
  94 : ^^select-vector ( src n rep -- dst )
  95     [ ^^broadcast-vector ] keep ^^vector>scalar ;
  96
  97 : emit-select-vector ( node -- )
  98     [ ^^select-vector ] [unary/param]
  99     { [ integer? ] [ representation? ] } if-literals-match ; inline
 100
 101 : emit-alien-vector ( node -- )
 102     dup [
 103         '[
 104             ds-drop prepare-alien-getter
 105             _ ^^alien-vector ds-push
 106         ]
 107         [ inline-alien-getter? ] inline-alien
 108     ] with emit-vector-op ;
 109
 110 : emit-set-alien-vector ( node -- )
 111     dup [
 112         '[
 113             ds-drop prepare-alien-setter ds-pop
 114             _ ##set-alien-vector
 115         ]
 116         [ byte-array inline-alien-setter? ]
 117         inline-alien
 118     ] with emit-vector-op ;
 119
 120 : generate-not-vector ( src rep -- dst )
 121     dup %not-vector-reps member?
 122     [ ^^not-vector ]
 123     [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
 124
 125 :: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
 126     {cc,swap} first2 :> swap? :> cc
 127     swap?
 128     [ src2 src1 rep cc ^^compare-vector ]
 129     [ src1 src2 rep cc ^^compare-vector ] if ;
 130
 131 :: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
 132     rep orig-cc %compare-vector-ccs :> not? :> ccs
 133
 134     ccs empty?
 135     [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
 136     [
 137         ccs unclip :> first-cc :> rest-ccs
 138         src1 src2 rep first-cc (generate-compare-vector) :> first-dst
 139
 140         rest-ccs first-dst
 141         [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
 142         reduce
 143
 144         not? [ rep generate-not-vector ] when
 145     ] if ;
 146
 147 :: generate-unpack-vector-head ( src rep -- dst )
 148     {
 149         {
 150             [ rep %unpack-vector-head-reps member? ]
 151             [ src rep ^^unpack-vector-head ]
 152         }
 153         [
 154             rep ^^zero-vector :> zero
 155             zero src rep cc> ^^compare-vector :> sign
 156             src sign rep ^^merge-vector-head
 157         ]
 158     } cond ;
 159
 160 :: generate-unpack-vector-tail ( src rep -- dst )
 161     {
 162         {
 163             [ rep %unpack-vector-tail-reps member? ]
 164             [ src rep ^^unpack-vector-tail ]
 165         }
 166         {
 167             [ rep %unpack-vector-head-reps member? ]
 168             [
 169                 src rep ^^tail>head-vector :> tail
 170                 tail rep ^^unpack-vector-head
 171             ]
 172         }
 173         [
 174             rep ^^zero-vector :> zero
 175             zero src rep cc> ^^compare-vector :> sign
 176             src sign rep ^^merge-vector-tail
 177         ]
 178     } cond ;
 179