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 byte-arrays classes functors
   4 kernel math parser prettyprint.custom sequences
   5 sequences.private literals ;
   6 IN: math.vectors.simd.functor
   7
   8 ERROR: bad-length got expected ;
   9
  10 FUNCTOR: define-simd-128 ( T -- )
  11
  12 T-TYPE       IS ${T}
  13
  14 N            [ 16 T-TYPE heap-size /i ]
  15
  16 A            DEFINES-CLASS ${T}-${N}
  17 >A           DEFINES >${A}
  18 A{           DEFINES ${A}{
  19
  20 NTH          [ T-TYPE dup c-type-getter-boxer array-accessor ]
  21 SET-NTH      [ T-TYPE dup c-setter array-accessor ]
  22
  23 A-rep        IS ${A}-rep
  24 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
  25 A-v->n-op    DEFINES-PRIVATE ${A}-v->n-op
  26
  27 WHERE
  28
  29 TUPLE: A
  30 { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
  31
  32 M: A clone underlying>> clone \ A boa ; inline
  33
  34 M: A length drop N ; inline
  35
  36 M: A nth-unsafe underlying>> NTH call ; inline
  37
  38 M: A set-nth-unsafe underlying>> SET-NTH call ; inline
  39
  40 : >A ( seq -- simd-array ) \ A new clone-like ;
  41
  42 M: A like drop dup \ A instance? [ >A ] unless ; inline
  43
  44 M: A new-sequence
  45     drop dup N =
  46     [ drop 16 <byte-array> \ A boa ]
  47     [ N bad-length ]
  48     if ; inline
  49
  50 M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
  51
  52 M: A byte-length underlying>> length ; inline
  53
  54 M: A pprint-delims drop \ A{ \ } ;
  55
  56 M: A >pprint-sequence ;
  57
  58 M: A pprint* pprint-object ;
  59
  60 SYNTAX: A{ \ } [ >A ] parse-literal ;
  61
  62 INSTANCE: A sequence
  63
  64 <PRIVATE
  65
  66 : A-vv->v-op ( v1 v2 quot -- v3 )
  67     [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
  68
  69 : A-v->n-op ( v quot -- n )
  70     [ underlying>> A-rep ] dip call ; inline
  71
  72 PRIVATE>
  73
  74 ;FUNCTOR
  75
  76 ! Synthesize 256-bit vectors from a pair of 128-bit vectors
  77 FUNCTOR: define-simd-256 ( T -- )
  78
  79 T-TYPE       IS ${T}
  80
  81 N            [ 32 T-TYPE heap-size /i ]
  82
  83 N/2          [ N 2 / ]
  84 A/2          IS ${T}-${N/2}
  85
  86 A            DEFINES-CLASS ${T}-${N}
  87 >A           DEFINES >${A}
  88 A{           DEFINES ${A}{
  89
  90 A-deref      DEFINES-PRIVATE ${A}-deref
  91
  92 A-rep        IS ${A/2}-rep
  93 A-vv->v-op   DEFINES-PRIVATE ${A}-vv->v-op
  94 A-v->n-op    DEFINES-PRIVATE ${A}-v->n-op
  95
  96 WHERE
  97
  98 SLOT: underlying1
  99 SLOT: underlying2
 100
 101 TUPLE: A
 102 { underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
 103 { underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
 104
 105 M: A clone
 106     [ underlying1>> clone ] [ underlying2>> clone ] bi
 107     \ A boa ; inline
 108
 109 M: A length drop N ; inline
 110
 111 : A-deref ( n seq -- n' seq' )
 112     over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
 113
 114 M: A nth-unsafe A-deref nth-unsafe ; inline
 115
 116 M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
 117
 118 : >A ( seq -- simd-array ) \ A new clone-like ;
 119
 120 M: A like drop dup \ A instance? [ >A ] unless ; inline
 121
 122 M: A new-sequence
 123     drop dup N =
 124     [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
 125     [ N bad-length ]
 126     if ; inline
 127
 128 M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
 129
 130 M: A byte-length drop 32 ; inline
 131
 132 SYNTAX: A{ \ } [ >A ] parse-literal ;
 133
 134 M: A pprint-delims drop \ A{ \ } ;
 135
 136 M: A >pprint-sequence ;
 137
 138 M: A pprint* pprint-object ;
 139
 140 INSTANCE: A sequence
 141
 142 : A-vv->v-op ( v1 v2 quot -- v3 )
 143     [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
 144     [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
 145     \ A boa ; inline
 146
 147 : A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
 148     [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
 149     dip call ; inline
 150
 151 ;FUNCTOR