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 QUALIFIED-WITH: math m
   9 IN: math.vectors.simd.functor
  10
  11 ERROR: bad-length got expected ;
  12
  13 MACRO: simd-boa ( rep class -- simd-array )
  14     [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
  15
  16 :: define-boa-custom-inlining ( word rep class -- )
  17     word [
  18         drop
  19         rep rep rep-gather-word supported-simd-op? [
  20             [ rep (simd-boa) class boa ]
  21         ] [ word def>> ] if
  22     ] "custom-inlining" set-word-prop ;
  23
  24 : simd-with ( rep class x -- simd-array )
  25     [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
  26
  27 :: define-with-custom-inlining ( word rep class -- )
  28     word [
  29         drop
  30         rep \ (simd-broadcast) supported-simd-op? [
  31             [ rep rep-coerce rep (simd-broadcast) class boa ]
  32         ] [ word def>> ] if
  33     ] "custom-inlining" set-word-prop ;
  34
  35 : boa-effect ( rep n -- effect )
  36     [ rep-components ] dip *
  37     [ CHAR: a + 1string ] map
  38     { "simd-vector" } <effect> ;
  39
  40 : supported-simd-ops ( assoc rep -- assoc' )
  41     [
  42         {
  43             { v+ (simd-v+) }
  44             { v- (simd-v-) }
  45             { v* (simd-v*) }
  46             { v/ (simd-v/) }
  47             { vmin (simd-vmin) }
  48             { vmax (simd-vmax) }
  49             { sum (simd-sum) }
  50         }
  51     ] dip
  52     '[ nip _ swap supported-simd-op? ] assoc-filter
  53     '[ drop _ key? ] assoc-filter ;
  54
  55 :: high-level-ops ( ctor elt-class -- assoc )
  56     ! Some SIMD operations are defined in terms of others.
  57     {
  58         { vneg [ [ dup v- ] keep v- ] }
  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     }
  71     ! To compute dot product and distance with integer vectors, we
  72     ! have to do things less efficiently, with integer overflow checks,
  73     ! in the general case.
  74     elt-class m:float = [
  75         {
  76             { distance [ v- norm ] }
  77             { v. [ v* sum ] }
  78         } append
  79     ] when ;
  80
  81 :: simd-vector-words ( class ctor rep assoc -- )
  82     rep rep-component-type c-type-boxed-class :> elt-class
  83     class
  84     elt-class
  85     assoc rep supported-simd-ops
  86     ctor elt-class high-level-ops assoc-union
  87     specialize-vector-words ;
  88
  89 :: define-simd-128-type ( class rep -- )
  90     <c-type>
  91         byte-array >>class
  92         class >>boxed-class
  93         [ rep alien-vector class boa ] >>getter
  94         [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
  95         16 >>size
  96         8 >>align
  97         rep >>rep
  98     class typedef ;
  99
 100 FUNCTOR: define-simd-128 ( T -- )
 101
 102 N            [ 16 T heap-size /i ]
 103
 104 A            DEFINES-CLASS ${T}-${N}
 105 A-boa        DEFINES ${A}-boa
 106 A-with       DEFINES ${A}-with
 107 >A           DEFINES >${A}
 108 A{           DEFINES ${A}{
 109
 110 NTH          [ T dup c-type-getter-boxer array-accessor ]
 111 SET-NTH      [ T dup c-setter array-accessor ]
 112
 113 A-rep        IS ${A}-rep
 114 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
 115 A-v->n-op    DEFINES-PRIVATE ${A}-v->n-op
 116
 117 WHERE
 118
 119 TUPLE: A
 120 { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
 121
 122 M: A clone underlying>> clone \ A boa ; inline
 123
 124 M: A length drop N ; inline
 125
 126 M: A nth-unsafe underlying>> NTH call ; inline
 127
 128 M: A set-nth-unsafe underlying>> SET-NTH call ; inline
 129
 130 : >A ( seq -- simd-array ) \ A new clone-like ;
 131
 132 M: A like drop dup \ A instance? [ >A ] unless ; inline
 133
 134 M: A new-sequence
 135     drop dup N =
 136     [ drop 16 <byte-array> \ A boa ]
 137     [ N bad-length ]
 138     if ; inline
 139
 140 M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
 141
 142 M: A byte-length underlying>> length ; inline
 143
 144 M: A pprint-delims drop \ A{ \ } ;
 145
 146 M: A >pprint-sequence ;
 147
 148 M: A pprint* pprint-object ;
 149
 150 SYNTAX: A{ \ } [ >A ] parse-literal ;
 151
 152 : A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ;
 153
 154 \ A-with \ A-rep \ A define-with-custom-inlining
 155
 156 \ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared
 157
 158 \ A-rep rep-gather-word [
 159     \ A-boa \ A-rep \ A define-boa-custom-inlining
 160 ] when
 161
 162 INSTANCE: A sequence
 163
 164 <PRIVATE
 165
 166 : A-vv->v-op ( v1 v2 quot -- v3 )
 167     [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
 168
 169 : A-v->n-op ( v quot -- n )
 170     [ underlying>> A-rep ] dip call ; inline
 171
 172 \ A \ A-with \ A-rep H{
 173     { v+ [ [ (simd-v+) ] \ A-vv->v-op execute ] }
 174     { v- [ [ (simd-v-) ] \ A-vv->v-op execute ] }
 175     { v* [ [ (simd-v*) ] \ A-vv->v-op execute ] }
 176     { v/ [ [ (simd-v/) ] \ A-vv->v-op execute ] }
 177     { vmin [ [ (simd-vmin) ] \ A-vv->v-op execute ] }
 178     { vmax [ [ (simd-vmax) ] \ A-vv->v-op execute ] }
 179     { sum [ [ (simd-sum) ] \ A-v->n-op execute ] }
 180 } simd-vector-words
 181
 182 \ A \ A-rep define-simd-128-type
 183
 184 PRIVATE>
 185
 186 ;FUNCTOR
 187
 188 ! Synthesize 256-bit vectors from a pair of 128-bit vectors
 189 SLOT: underlying1
 190 SLOT: underlying2
 191
 192 :: define-simd-256-type ( class rep -- )
 193     <c-type>
 194         class >>class
 195         class >>boxed-class
 196         [
 197             [ rep alien-vector ]
 198             [ 16 + >fixnum rep alien-vector ] 2bi
 199             class boa
 200         ] >>getter
 201         [
 202             [ [ underlying1>> ] 2dip rep set-alien-vector ]
 203             [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
 204             3bi
 205         ] >>setter
 206         32 >>size
 207         8 >>align
 208         rep >>rep
 209     class typedef ;
 210
 211 FUNCTOR: define-simd-256 ( T -- )
 212
 213 N            [ 32 T heap-size /i ]
 214
 215 N/2          [ N 2 / ]
 216 A/2          IS ${T}-${N/2}
 217 A/2-boa      IS ${A/2}-boa
 218 A/2-with     IS ${A/2}-with
 219
 220 A            DEFINES-CLASS ${T}-${N}
 221 A-boa        DEFINES ${A}-boa
 222 A-with       DEFINES ${A}-with
 223 >A           DEFINES >${A}
 224 A{           DEFINES ${A}{
 225
 226 A-deref      DEFINES-PRIVATE ${A}-deref
 227
 228 A-rep        IS ${A/2}-rep
 229 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
 230 A-v->n-op    DEFINES-PRIVATE ${A}-v->n-op
 231
 232 WHERE
 233
 234 SLOT: underlying1
 235 SLOT: underlying2
 236
 237 TUPLE: A
 238 { underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
 239 { underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
 240
 241 M: A clone
 242     [ underlying1>> clone ] [ underlying2>> clone ] bi
 243     \ A boa ; inline
 244
 245 M: A length drop N ; inline
 246
 247 : A-deref ( n seq -- n' seq' )
 248     over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
 249
 250 M: A nth-unsafe A-deref nth-unsafe ; inline
 251
 252 M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
 253
 254 : >A ( seq -- simd-array ) \ A new clone-like ;
 255
 256 M: A like drop dup \ A instance? [ >A ] unless ; inline
 257
 258 M: A new-sequence
 259     drop dup N =
 260     [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
 261     [ N bad-length ]
 262     if ; inline
 263
 264 M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
 265
 266 M: A byte-length drop 32 ; inline
 267
 268 SYNTAX: A{ \ } [ >A ] parse-literal ;
 269
 270 M: A pprint-delims drop \ A{ \ } ;
 271
 272 M: A >pprint-sequence ;
 273
 274 M: A pprint* pprint-object ;
 275
 276 : A-with ( x -- simd-array )
 277     [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@
 278     \ A boa ; inline
 279
 280 : A-boa ( ... -- simd-array )
 281     [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@
 282     \ A boa ; inline
 283
 284 \ A-rep 2 boa-effect \ A-boa set-stack-effect
 285
 286 INSTANCE: A sequence
 287
 288 : A-vv->v-op ( v1 v2 quot -- v3 )
 289     [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
 290     [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
 291     \ A boa ; inline
 292
 293 : A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
 294     [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
 295     dip call ; inline
 296
 297 \ A \ A-with \ A-rep H{
 298     { v+ [ [ (simd-v+) ] \ A-vv->v-op execute ] }
 299     { v- [ [ (simd-v-) ] \ A-vv->v-op execute ] }
 300     { v* [ [ (simd-v*) ] \ A-vv->v-op execute ] }
 301     { v/ [ [ (simd-v/) ] \ A-vv->v-op execute ] }
 302     { vmin [ [ (simd-vmin) ] \ A-vv->v-op execute ] }
 303     { vmax [ [ (simd-vmax) ] \ A-vv->v-op execute ] }
 304     { sum [ [ (simd-v+) ] [ (simd-sum) ] \ A-v->n-op execute ] }
 305 } simd-vector-words
 306
 307 \ A \ A-rep define-simd-256-type
 308
 309 ;FUNCTOR