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 assocs byte-arrays classes classes.algebra effects fry
   4 functors generalizations kernel literals locals math math.functions
   5 math.vectors math.vectors.private math.vectors.simd.intrinsics
   6 math.vectors.conversion.backend
   7 math.vectors.specialization parser prettyprint.custom sequences
   8 sequences.private strings words definitions macros cpu.architecture
   9 namespaces arrays quotations combinators combinators.short-circuit sets
  10 layouts ;
  11 QUALIFIED-WITH: alien.c-types c
  12 QUALIFIED: math.private
  13 IN: math.vectors.simd.functor
  14
  15 ERROR: bad-length got expected ;
  16
  17 : vector-true-value ( class -- value )
  18     {
  19         { [ dup integer class<= ] [ drop -1 ] }
  20         { [ dup float   class<= ] [ drop -1 bits>double ] }
  21     } cond ; foldable
  22
  23 : vector-false-value ( class -- value )
  24     {
  25         { [ dup integer class<= ] [ drop 0   ] }
  26         { [ dup float   class<= ] [ drop 0.0 ] }
  27     } cond ; foldable
  28
  29 : boolean>element ( bool/elt class -- elt )
  30     swap {
  31         { t [ vector-true-value  ] }
  32         { f [ vector-false-value ] }
  33         [ nip ]
  34     } case ; inline
  35
  36 MACRO: simd-boa ( rep class -- simd-array )
  37     [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
  38
  39 : can-be-unboxed? ( type -- ? )
  40     {
  41         { c:float [ \ math.private:float+ "intrinsic" word-prop ] }
  42         { c:double [ \ math.private:float+ "intrinsic" word-prop ] }
  43         [ c:heap-size cell < ]
  44     } case ;
  45
  46 : simd-boa-fast? ( rep -- ? )
  47     [ dup rep-gather-word supported-simd-op? ]
  48     [ rep-component-type can-be-unboxed? ]
  49     bi and ;
  50
  51 :: define-boa-custom-inlining ( word rep class -- )
  52     word [
  53         drop
  54         rep simd-boa-fast? [
  55             [ rep (simd-boa) class boa ]
  56         ] [ word def>> ] if
  57     ] "custom-inlining" set-word-prop ;
  58
  59 : simd-with ( rep class x -- simd-array )
  60     [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
  61
  62 : simd-with/nth-fast? ( rep -- ? )
  63     [ \ (simd-vshuffle-elements) supported-simd-op? ]
  64     [ rep-component-type can-be-unboxed? ]
  65     bi and ;
  66
  67 :: define-with-custom-inlining ( word rep class -- )
  68     word [
  69         drop
  70         rep simd-with/nth-fast? [
  71             [ rep rep-coerce rep (simd-with) class boa ]
  72         ] [ word def>> ] if
  73     ] "custom-inlining" set-word-prop ;
  74
  75 : simd-nth-fast ( rep -- quot )
  76     [ rep-components ] keep
  77     '[ swap _ '[ _ _ (simd-select) ] 2array ] map-index
  78     '[ swap >fixnum _ case ] ;
  79
  80 : simd-nth-slow ( rep -- quot )
  81     rep-component-type dup c:c-type-getter-boxer c:array-accessor ;
  82
  83 MACRO: simd-nth ( rep -- x )
  84     dup simd-with/nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ;
  85
  86 : boa-effect ( rep n -- effect )
  87     [ rep-components ] dip *
  88     [ CHAR: a + 1string ] map
  89     { "simd-vector" } <effect> ;
  90
  91 : supported-simd-ops ( assoc rep -- assoc' )
  92     [ simd-ops get ] dip
  93     '[ nip _ swap supported-simd-op? ] assoc-filter
  94     '[ drop _ key? ] assoc-filter ;
  95
  96 ERROR: bad-schema op schema ;
  97
  98 :: op-wrapper ( op specials schemas -- wrapper )
  99     op {
 100         [ specials at ]
 101         [ word-schema schemas at ]
 102         [ dup word-schema bad-schema ]
 103     } 1|| ;
 104
 105 : low-level-ops ( simd-ops specials schemas -- alist )
 106     '[ 1quotation over _ _ op-wrapper [ ] 2sequence ] assoc-map ;
 107
 108 :: high-level-ops ( ctor elt-class -- assoc )
 109     ! Some SIMD operations are defined in terms of others.
 110     {
 111         { vbroadcast [ swap nth ctor execute ] }
 112         { n+v [ [ ctor execute ] dip v+ ] }
 113         { v+n [ ctor execute v+ ] }
 114         { n-v [ [ ctor execute ] dip v- ] }
 115         { v-n [ ctor execute v- ] }
 116         { n*v [ [ ctor execute ] dip v* ] }
 117         { v*n [ ctor execute v* ] }
 118         { n/v [ [ ctor execute ] dip v/ ] }
 119         { v/n [ ctor execute v/ ] }
 120         { norm-sq [ dup v. assert-positive ] }
 121         { norm [ norm-sq sqrt ] }
 122         { normalize [ dup norm v/n ] }
 123     }
 124     ! To compute dot product and distance with integer vectors, we
 125     ! have to do things less efficiently, with integer overflow checks,
 126     ! in the general case.
 127     elt-class float = [ { distance [ v- norm ] } suffix ] when ;
 128
 129 TUPLE: simd class elt-class ops special-wrappers schema-wrappers ctor rep ;
 130
 131 : define-simd ( simd -- )
 132     dup rep>> rep-component-type c:c-type-boxed-class >>elt-class
 133     {
 134         [ class>> ]
 135         [ elt-class>> ]
 136         [ [ ops>> ] [ special-wrappers>> ] [ schema-wrappers>> ] tri low-level-ops ]
 137         [ rep>> supported-simd-ops ]
 138         [ [ ctor>> ] [ elt-class>> ] bi high-level-ops assoc-union ]
 139     } cleave
 140     specialize-vector-words ;
 141
 142 :: define-simd-128-type ( class rep -- )
 143     c:<c-type>
 144         byte-array >>class
 145         class >>boxed-class
 146         [ rep alien-vector class boa ] >>getter
 147         [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
 148         16 >>size
 149         8 >>align
 150         rep >>rep
 151     class c:typedef ;
 152
 153 : (define-simd-128) ( simd -- )
 154     simd-ops get >>ops
 155     [ define-simd ]
 156     [ [ class>> ] [ rep>> ] bi define-simd-128-type ] bi ;
 157
 158 FUNCTOR: define-simd-128 ( T -- )
 159
 160 N            [ 16 T c:heap-size /i ]
 161
 162 A            DEFINES-CLASS ${T}-${N}
 163 A-boa        DEFINES ${A}-boa
 164 A-with       DEFINES ${A}-with
 165 A-cast       DEFINES ${A}-cast
 166 >A           DEFINES >${A}
 167 A{           DEFINES ${A}{
 168
 169 SET-NTH      [ T dup c:c-setter c:array-accessor ]
 170
 171 A-rep        [ A name>> "-rep" append "cpu.architecture" lookup ]
 172 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
 173 A-vn->v-op   DEFINES-PRIVATE ${A}-vn->v-op
 174 A-vv->n-op   DEFINES-PRIVATE ${A}-vv->n-op
 175 A-v->v-op    DEFINES-PRIVATE ${A}-v->v-op
 176 A-v->n-op    DEFINES-PRIVATE ${A}-v->n-op
 177 A-v-conversion-op DEFINES-PRIVATE ${A}-v-conversion-op
 178 A-vv-conversion-op DEFINES-PRIVATE ${A}-vv-conversion-op
 179
 180 A-element-class [ A-rep rep-component-type c:c-type-boxed-class ]
 181
 182 WHERE
 183
 184 TUPLE: A
 185 { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
 186
 187 INSTANCE: A simd-128
 188
 189 M: A clone underlying>> clone \ A boa ; inline
 190
 191 M: A length drop N ; inline
 192
 193 M: A equal?
 194     over \ A instance? [ v= vall? ] [ 2drop f ] if ;
 195
 196 M: A nth-unsafe underlying>> A-rep simd-nth ; inline
 197
 198 M: A set-nth-unsafe
 199     [ A-element-class boolean>element ] 2dip
 200     underlying>> SET-NTH call ; inline
 201
 202 : >A ( seq -- simd-array ) \ A new clone-like ;
 203
 204 M: A like drop dup \ A instance? [ >A ] unless ; inline
 205
 206 M: A new-underlying drop \ A boa ; inline
 207
 208 M: A new-sequence
 209     drop dup N =
 210     [ drop 16 <byte-array> \ A boa ]
 211     [ N bad-length ]
 212     if ; inline
 213
 214 M: A c:byte-length underlying>> length ; inline
 215
 216 M: A element-type drop A-rep rep-component-type ;
 217
 218 M: A pprint-delims drop \ A{ \ } ;
 219
 220 M: A >pprint-sequence ;
 221
 222 M: A pprint* pprint-object ;
 223
 224 SYNTAX: A{ \ } [ >A ] parse-literal ;
 225
 226 : A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ;
 227
 228 \ A-with \ A-rep \ A define-with-custom-inlining
 229
 230 \ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared
 231
 232 \ A-rep rep-gather-word [
 233     \ A-boa \ A-rep \ A define-boa-custom-inlining
 234 ] when
 235
 236 : A-cast ( simd-array -- simd-array' )
 237     underlying>> \ A boa ; inline
 238
 239 INSTANCE: A sequence
 240
 241 <PRIVATE
 242
 243 : A-vv->v-op ( v1 v2 quot -- v3 )
 244     [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
 245
 246 : A-vn->v-op ( v1 v2 quot -- v3 )
 247     [ [ underlying>> ] dip A-rep ] dip call \ A boa ; inline
 248
 249 : A-vv->n-op ( v1 v2 quot -- n )
 250     [ [ underlying>> ] bi@ A-rep ] dip call ; inline
 251
 252 : A-v->v-op ( v1 quot -- v2 )
 253     [ underlying>> A-rep ] dip call \ A boa ; inline
 254
 255 : A-v->n-op ( v quot -- n )
 256     [ underlying>> A-rep ] dip call ; inline
 257
 258 : A-v-conversion-op ( v1 to-type quot -- v2 )
 259     swap [ underlying>> A-rep ] [ call ] [ '[ _ boa ] call( u -- v ) ] tri* ; inline
 260
 261 : A-vv-conversion-op ( v1 v2 to-type quot -- v2 )
 262     swap {
 263         [ underlying>> ]
 264         [ underlying>> A-rep ]
 265         [ call ]
 266         [ '[ _ boa ] call( u -- v ) ]
 267     } spread ; inline
 268
 269 simd new
 270     \ A >>class
 271     \ A-with >>ctor
 272     \ A-rep >>rep
 273     {
 274         { (v>float) A-v-conversion-op }
 275         { (v>integer) A-v-conversion-op }
 276         { (vpack-signed) A-vv-conversion-op }
 277         { (vpack-unsigned) A-vv-conversion-op }
 278         { (vunpack-head) A-v-conversion-op }
 279         { (vunpack-tail) A-v-conversion-op }
 280     } >>special-wrappers
 281     {
 282         { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
 283         { { +vector+ +any-vector+ -> +vector+ } A-vv->v-op }
 284         { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
 285         { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
 286         { { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
 287         { { +vector+ +vector+ -> +boolean+ } A-vv->n-op }
 288         { { +vector+ -> +vector+ } A-v->v-op }
 289         { { +vector+ -> +scalar+ } A-v->n-op }
 290         { { +vector+ -> +boolean+ } A-v->n-op }
 291         { { +vector+ -> +nonnegative+ } A-v->n-op }
 292     } >>schema-wrappers
 293 (define-simd-128)
 294
 295 PRIVATE>
 296
 297 ;FUNCTOR
 298
 299 ! Synthesize 256-bit vectors from a pair of 128-bit vectors
 300 SLOT: underlying1
 301 SLOT: underlying2
 302
 303 :: define-simd-256-type ( class rep -- )
 304     c:<c-type>
 305         class >>class
 306         class >>boxed-class
 307         [
 308             [ rep alien-vector ]
 309             [ 16 + >fixnum rep alien-vector ] 2bi
 310             class boa
 311         ] >>getter
 312         [
 313             [ [ underlying1>> ] 2dip rep set-alien-vector ]
 314             [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
 315             3bi
 316         ] >>setter
 317         32 >>size
 318         8 >>align
 319         rep >>rep
 320     class c:typedef ;
 321
 322 : (define-simd-256) ( simd -- )
 323     simd-ops get { vshuffle-elements vshuffle-bytes hlshift hrshift } unique assoc-diff >>ops
 324     [ define-simd ]
 325     [ [ class>> ] [ rep>> ] bi define-simd-256-type ] bi ;
 326
 327 FUNCTOR: define-simd-256 ( T -- )
 328
 329 N            [ 32 T c:heap-size /i ]
 330
 331 N/2          [ N 2 /i ]
 332 A/2          IS ${T}-${N/2}
 333 A/2-boa      IS ${A/2}-boa
 334 A/2-with     IS ${A/2}-with
 335
 336 A            DEFINES-CLASS ${T}-${N}
 337 A-boa        DEFINES ${A}-boa
 338 A-with       DEFINES ${A}-with
 339 A-cast       DEFINES ${A}-cast
 340 >A           DEFINES >${A}
 341 A{           DEFINES ${A}{
 342
 343 A-deref      DEFINES-PRIVATE ${A}-deref
 344
 345 A-rep        [ A/2 name>> "-rep" append "cpu.architecture" lookup ]
 346 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
 347 A-vn->v-op   DEFINES-PRIVATE ${A}-vn->v-op
 348 A-v->v-op    DEFINES-PRIVATE ${A}-v->v-op
 349 A-v.-op      DEFINES-PRIVATE ${A}-v.-op
 350 (A-v->n-op)  DEFINES-PRIVATE (${A}-v->v-op)
 351 A-sum-op     DEFINES-PRIVATE ${A}-sum-op
 352 A-vany-op    DEFINES-PRIVATE ${A}-vany-op
 353 A-vall-op    DEFINES-PRIVATE ${A}-vall-op
 354 A-vmerge-head-op    DEFINES-PRIVATE ${A}-vmerge-head-op
 355 A-vmerge-tail-op    DEFINES-PRIVATE ${A}-vmerge-tail-op
 356 A-v-conversion-op   DEFINES-PRIVATE ${A}-v-conversion-op
 357 A-vpack-op          DEFINES-PRIVATE ${A}-vpack-op
 358 A-vunpack-head-op   DEFINES-PRIVATE ${A}-vunpack-head-op
 359 A-vunpack-tail-op   DEFINES-PRIVATE ${A}-vunpack-tail-op
 360
 361 WHERE
 362
 363 SLOT: underlying1
 364 SLOT: underlying2
 365
 366 TUPLE: A
 367 { underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
 368 { underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
 369
 370 INSTANCE: A simd-256
 371
 372 M: A clone
 373     [ underlying1>> clone ] [ underlying2>> clone ] bi
 374     \ A boa ; inline
 375
 376 M: A length drop N ; inline
 377
 378 M: A equal?
 379     over \ A instance? [ v= vall? ] [ 2drop f ] if ;
 380
 381 : A-deref ( n seq -- n' seq' )
 382     over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
 383
 384 M: A nth-unsafe A-deref nth-unsafe ; inline
 385
 386 M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
 387
 388 : >A ( seq -- simd-array ) \ A new clone-like ;
 389
 390 M: A like drop dup \ A instance? [ >A ] unless ; inline
 391
 392 M: A new-sequence
 393     drop dup N =
 394     [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
 395     [ N bad-length ]
 396     if ; inline
 397
 398 M: A c:byte-length drop 32 ; inline
 399
 400 M: A element-type drop A-rep rep-component-type ;
 401
 402 SYNTAX: A{ \ } [ >A ] parse-literal ;
 403
 404 M: A pprint-delims drop \ A{ \ } ;
 405
 406 M: A >pprint-sequence ;
 407
 408 M: A pprint* pprint-object ;
 409
 410 : A-with ( x -- simd-array )
 411     [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@
 412     \ A boa ; inline
 413
 414 : A-boa ( ... -- simd-array )
 415     [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@
 416     \ A boa ; inline
 417
 418 \ A-rep 2 boa-effect \ A-boa set-stack-effect
 419
 420 : A-cast ( simd-array -- simd-array' )
 421     [ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline
 422
 423 INSTANCE: A sequence
 424
 425 : A-vv->v-op ( v1 v2 quot -- v3 )
 426     [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
 427     [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
 428     \ A boa ; inline
 429
 430 : A-vn->v-op ( v1 v2 quot -- v3 )
 431     [ [ [ underlying1>> ] dip A-rep ] dip call ]
 432     [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi
 433     \ A boa ; inline
 434
 435 : A-v->v-op ( v1 combine-quot -- v2 )
 436     [ [ underlying1>> A-rep ] dip call ]
 437     [ [ underlying2>> A-rep ] dip call ] 2bi
 438     \ A boa ; inline
 439
 440 : A-v.-op ( v1 v2 quot -- n )
 441     [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
 442     [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
 443     + ; inline
 444
 445 : (A-v->n-op) ( v1 quot reduce-quot -- n )
 446     '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ A-rep ] dip call ; inline
 447
 448 : A-sum-op ( v1 quot -- n )
 449     [ (simd-v+) ] (A-v->n-op) ; inline
 450
 451 : A-vany-op ( v1 quot -- n )
 452     [ (simd-vbitor) ] (A-v->n-op) ; inline
 453 : A-vall-op ( v1 quot -- n )
 454     [ (simd-vbitand) ] (A-v->n-op) ; inline
 455
 456 : A-vmerge-head-op ( v1 v2 quot -- v )
 457     drop
 458     [ underlying1>> ] bi@
 459     [ A-rep (simd-(vmerge-head)) ]
 460     [ A-rep (simd-(vmerge-tail)) ] 2bi
 461     \ A boa ; inline
 462
 463 : A-vmerge-tail-op ( v1 v2 quot -- v )
 464     drop
 465     [ underlying2>> ] bi@
 466     [ A-rep (simd-(vmerge-head)) ]
 467     [ A-rep (simd-(vmerge-tail)) ] 2bi
 468     \ A boa ; inline
 469
 470 : A-v-conversion-op ( v1 to-type quot -- v )
 471     swap [
 472         [ [ underlying1>> A-rep ] dip call ]
 473         [ [ underlying2>> A-rep ] dip call ] 2bi
 474     ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
 475
 476 : A-vpack-op ( v1 v2 to-type quot -- v )
 477     swap [
 478         '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ ] bi*
 479     ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
 480
 481 : A-vunpack-head-op ( v1 to-type quot -- v )
 482     '[
 483         underlying1>>
 484         [ A-rep @ ]
 485         [ A-rep (simd-(vunpack-tail)) ] bi
 486     ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
 487
 488 : A-vunpack-tail-op ( v1 to-type quot -- v )
 489     '[
 490         underlying2>>
 491         [ A-rep (simd-(vunpack-head)) ]
 492         [ A-rep @ ] bi
 493     ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
 494
 495 simd new
 496     \ A >>class
 497     \ A-with >>ctor
 498     \ A-rep >>rep
 499     {
 500         { v.     A-v.-op   }
 501         { sum    A-sum-op  }
 502         { vnone? A-vany-op }
 503         { vany?  A-vany-op }
 504         { vall?  A-vall-op }
 505         { (vmerge-head) A-vmerge-head-op }
 506         { (vmerge-tail) A-vmerge-tail-op }
 507         { (v>integer) A-v-conversion-op }
 508         { (v>float) A-v-conversion-op }
 509         { (vpack-signed) A-vpack-op }
 510         { (vpack-unsigned) A-vpack-op }
 511         { (vunpack-head) A-vunpack-head-op }
 512         { (vunpack-tail) A-vunpack-tail-op }
 513     } >>special-wrappers
 514     {
 515         { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
 516         { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
 517         { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
 518         { { +vector+ -> +vector+ } A-v->v-op }
 519     } >>schema-wrappers
 520 (define-simd-256)
 521
 522 ;FUNCTOR