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