basis/math/vectors/simd/functor/functor.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types assocs byte-arrays classes
   4 effects fry functors generalizations kernel literals locals
   5 math math.functions math.vectors math.vectors.simd.intrinsics
   6 math.vectors.specialization parser prettyprint.custom sequences
   7 sequences.private strings words definitions macros cpu.architecture ;
   8 IN: math.vectors.simd.functor
   9
  10 ERROR: bad-length got expected ;
  11
  12 MACRO: simd-boa ( rep class -- simd-array )
  13     [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
  14
  15 :: define-boa-custom-inlining ( word rep class -- )
  16     word [
  17         drop
  18         rep rep rep-gather-word supported-simd-op? [
  19             [ rep (simd-boa) class boa ]
  20         ] [ word def>> ] if
  21     ] "custom-inlining" set-word-prop ;
  22
  23 : simd-with ( rep class x -- simd-array )
  24     [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
  25
  26 :: define-with-custom-inlining ( word rep class -- )
  27     word [
  28         drop
  29         rep \ (simd-broadcast) supported-simd-op? [
  30             [ rep rep-coerce rep (simd-broadcast) class boa ]
  31         ] [ word def>> ] if
  32     ] "custom-inlining" set-word-prop ;
  33
  34 : boa-effect ( rep n -- effect )
  35     [ rep-components ] dip *
  36     [ CHAR: a + 1string ] map
  37     { "simd-vector" } <effect> ;
  38
  39 : supported-simd-ops ( assoc rep -- assoc' )
  40     [
  41         {
  42             { v+ (simd-v+) }
  43             { v- (simd-v-) }
  44             { v* (simd-v*) }
  45             { v/ (simd-v/) }
  46             { vmin (simd-vmin) }
  47             { vmax (simd-vmax) }
  48             { sum (simd-sum) }
  49         }
  50     ] dip
  51     '[ nip _ swap supported-simd-op? ] assoc-filter
  52     '[ drop _ key? ] assoc-filter ;
  53
  54 :: high-level-ops ( ctor -- assoc )
  55     ! Some SIMD operations are defined in terms of others.
  56     {
  57         { vneg [ [ dup v- ] keep v- ] }
  58         { v. [ v* sum ] }
  59         { n+v [ [ ctor execute ] dip v+ ] }
  60         { v+n [ ctor execute v+ ] }
  61         { n-v [ [ ctor execute ] dip v- ] }
  62         { v-n [ ctor execute v- ] }
  63         { n*v [ [ ctor execute ] dip v* ] }
  64         { v*n [ ctor execute v* ] }
  65         { n/v [ [ ctor execute ] dip v/ ] }
  66         { v/n [ ctor execute v/ ] }
  67         { norm-sq [ dup v. assert-positive ] }
  68         { norm [ norm-sq sqrt ] }
  69         { normalize [ dup norm v/n ] }
  70         { distance [ v- norm ] }
  71     } ;
  72
  73 :: simd-vector-words ( class ctor rep assoc -- )
  74     class
  75     rep rep-component-type c-type-boxed-class
  76     assoc rep supported-simd-ops
  77     ctor high-level-ops assoc-union
  78     specialize-vector-words ;
  79
  80 FUNCTOR: define-simd-128 ( T -- )
  81
  82 N            [ 16 T heap-size /i ]
  83
  84 A            DEFINES-CLASS ${T}-${N}
  85 A-boa        DEFINES ${A}-boa
  86 A-with       DEFINES ${A}-with
  87 >A           DEFINES >${A}
  88 A{           DEFINES ${A}{
  89
  90 NTH          [ T dup c-type-getter-boxer array-accessor ]
  91 SET-NTH      [ T dup c-setter array-accessor ]
  92
  93 A-rep        IS ${A}-rep
  94 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
  95 A-v->n-op    DEFINES-PRIVATE ${A}-v->n-op
  96
  97 WHERE
  98
  99 TUPLE: A
 100 { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
 101
 102 M: A clone underlying>> clone \ A boa ; inline
 103
 104 M: A length drop N ; inline
 105
 106 M: A nth-unsafe underlying>> NTH call ; inline
 107
 108 M: A set-nth-unsafe underlying>> SET-NTH call ; inline
 109
 110 : >A ( seq -- simd-array ) \ A new clone-like ;
 111
 112 M: A like drop dup \ A instance? [ >A ] unless ; inline
 113
 114 M: A new-sequence
 115     drop dup N =
 116     [ drop 16 <byte-array> \ A boa ]
 117     [ N bad-length ]
 118     if ; inline
 119
 120 M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
 121
 122 M: A byte-length underlying>> length ; inline
 123
 124 M: A pprint-delims drop \ A{ \ } ;
 125
 126 M: A >pprint-sequence ;
 127
 128 M: A pprint* pprint-object ;
 129
 130 SYNTAX: A{ \ } [ >A ] parse-literal ;
 131
 132 : A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ;
 133
 134 \ A-with \ A-rep \ A define-with-custom-inlining
 135
 136 \ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared
 137
 138 \ A-rep rep-gather-word [
 139     \ A-boa \ A-rep \ A define-boa-custom-inlining
 140 ] when
 141
 142 INSTANCE: A sequence
 143
 144 <PRIVATE
 145
 146 : A-vv->v-op ( v1 v2 quot -- v3 )
 147     [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
 148
 149 : A-v->n-op ( v quot -- n )
 150     [ underlying>> A-rep ] dip call ; inline
 151
 152 \ A \ A-with \ A-rep H{
 153     { v+ [ [ (simd-v+) ] \ A-vv->v-op execute ] }
 154     { v- [ [ (simd-v-) ] \ A-vv->v-op execute ] }
 155     { v* [ [ (simd-v*) ] \ A-vv->v-op execute ] }
 156     { v/ [ [ (simd-v/) ] \ A-vv->v-op execute ] }
 157     { vmin [ [ (simd-vmin) ] \ A-vv->v-op execute ] }
 158     { vmax [ [ (simd-vmax) ] \ A-vv->v-op execute ] }
 159     { sum [ [ (simd-sum) ] \ A-v->n-op execute ] }
 160 } simd-vector-words
 161
 162 PRIVATE>
 163
 164 ;FUNCTOR
 165
 166 ! Synthesize 256-bit vectors from a pair of 128-bit vectors
 167 FUNCTOR: define-simd-256 ( T -- )
 168
 169 N            [ 32 T heap-size /i ]
 170
 171 N/2          [ N 2 / ]
 172 A/2          IS ${T}-${N/2}
 173 A/2-boa      IS ${A/2}-boa
 174 A/2-with     IS ${A/2}-with
 175
 176 A            DEFINES-CLASS ${T}-${N}
 177 A-boa        DEFINES ${A}-boa
 178 A-with       DEFINES ${A}-with
 179 >A           DEFINES >${A}
 180 A{           DEFINES ${A}{
 181
 182 A-deref      DEFINES-PRIVATE ${A}-deref
 183
 184 A-rep        IS ${A/2}-rep
 185 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
 186 A-v->n-op    DEFINES-PRIVATE ${A}-v->n-op
 187
 188 WHERE
 189
 190 SLOT: underlying1
 191 SLOT: underlying2
 192
 193 TUPLE: A
 194 { underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
 195 { underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
 196
 197 M: A clone
 198     [ underlying1>> clone ] [ underlying2>> clone ] bi
 199     \ A boa ; inline
 200
 201 M: A length drop N ; inline
 202
 203 : A-deref ( n seq -- n' seq' )
 204     over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
 205
 206 M: A nth-unsafe A-deref nth-unsafe ; inline
 207
 208 M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
 209
 210 : >A ( seq -- simd-array ) \ A new clone-like ;
 211
 212 M: A like drop dup \ A instance? [ >A ] unless ; inline
 213
 214 M: A new-sequence
 215     drop dup N =
 216     [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
 217     [ N bad-length ]
 218     if ; inline
 219
 220 M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
 221
 222 M: A byte-length drop 32 ; inline
 223
 224 SYNTAX: A{ \ } [ >A ] parse-literal ;
 225
 226 M: A pprint-delims drop \ A{ \ } ;
 227
 228 M: A >pprint-sequence ;
 229
 230 M: A pprint* pprint-object ;
 231
 232 : A-with ( x -- simd-array )
 233     [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@
 234     \ A boa ; inline
 235
 236 : A-boa ( ... -- simd-array )
 237     [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@
 238     \ A boa ;
 239
 240 \ A-rep 2 boa-effect \ A-boa set-stack-effect
 241
 242 INSTANCE: A sequence
 243
 244 : A-vv->v-op ( v1 v2 quot -- v3 )
 245     [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
 246     [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
 247     \ A boa ; inline
 248
 249 : A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
 250     [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
 251     dip call ; inline
 252
 253 \ A \ A-with \ A-rep H{
 254     { v+ [ [ (simd-v+) ] \ A-vv->v-op execute ] }
 255     { v- [ [ (simd-v-) ] \ A-vv->v-op execute ] }
 256     { v* [ [ (simd-v*) ] \ A-vv->v-op execute ] }
 257     { v/ [ [ (simd-v/) ] \ A-vv->v-op execute ] }
 258     { vmin [ [ (simd-vmin) ] \ A-vv->v-op execute ] }
 259     { vmax [ [ (simd-vmax) ] \ A-vv->v-op execute ] }
 260     { sum [ [ (simd-v+) ] [ (simd-sum) ] \ A-v->n-op execute ] }
 261 } simd-vector-words
 262
 263 ;FUNCTOR