1 USING: accessors alien alien.c-types arrays ascii byte-arrays combinators
2 combinators.short-circuit fry kernel math math.blas.ffi
3 math.complex math.functions math.order sequences sequences.private
4 functors words locals parser prettyprint.backend prettyprint.custom
6 FROM: alien.c-types => float ;
7 SPECIALIZED-ARRAY: float
8 SPECIALIZED-ARRAY: double
9 SPECIALIZED-ARRAY: complex-float
10 SPECIALIZED-ARRAY: complex-double
13 TUPLE: blas-vector-base underlying length inc ;
15 INSTANCE: blas-vector-base virtual-sequence
17 GENERIC: element-type ( v -- type )
19 GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
20 GENERIC: n*V! ( alpha x -- x=alpha*x )
21 GENERIC: V. ( x y -- x.y )
22 GENERIC: V.conj ( x y -- xconj.y )
23 GENERIC: Vnorm ( x -- norm )
24 GENERIC: Vasum ( x -- sum )
25 GENERIC: Vswap ( x y -- x=y y=x )
26 GENERIC: Viamax ( x -- max-i )
30 GENERIC: (blas-vector-like) ( data length inc exemplar -- vector )
32 GENERIC: (blas-direct-array) ( blas-vector -- direct-array )
34 : shorter-length ( v1 v2 -- length )
35 [ length>> ] bi@ min ; inline
36 : data-and-inc ( v -- data inc )
37 [ ] [ inc>> ] bi ; inline
38 : datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
39 [ data-and-inc ] bi@ ; inline
42 ( v element-size -- length v-data v-inc v-dest-data v-dest-inc
43 copy-data copy-length copy-inc )
44 v [ length>> ] [ data-and-inc ] bi
45 v length>> element-size * <byte-array>
50 ( v1 v2 -- length v1-data v1-inc v2-data v2-inc
52 [ shorter-length ] [ datas-and-incs ] [ ] 2tri ;
55 ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc
63 ( n v -- length n v-data v-inc
70 : (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc )
71 [ shorter-length ] [ datas-and-incs ] 2bi ;
73 : (prepare-nrm2) ( v -- length data inc )
74 [ length>> ] [ data-and-inc ] bi ;
78 : n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
79 : n*V ( alpha x -- alpha*x ) clone n*V! ; inline
82 1.0 -rot n*V+V ; inline
84 -1.0 spin n*V+V ; inline
87 -1.0 swap n*V ; inline
89 : V*n ( x alpha -- x*alpha )
91 : V/n ( x alpha -- x/alpha )
92 recip swap n*V ; inline
95 [ Viamax ] keep nth ; inline
97 :: Vsub ( v start length -- sub )
98 v inc>> start * v element-type heap-size *
99 v underlying>> <displaced-alien>
100 length v inc>> v (blas-vector-like) ;
102 : <zero-vector> ( exemplar -- zero )
103 [ element-type heap-size <byte-array> ]
105 [ (blas-vector-like) ] tri ;
107 : <empty-vector> ( length exemplar -- vector )
108 [ element-type heap-size * <byte-array> ]
112 M: blas-vector-base equal?
118 M: blas-vector-base length
120 M: blas-vector-base virtual-seq
121 (blas-direct-array) ;
122 M: blas-vector-base virtual@
123 [ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
125 : float>arg ( f -- f ) ; inline
126 : double>arg ( f -- f ) ; inline
127 : arg>float ( f -- f ) ; inline
128 : arg>double ( f -- f ) ; inline
132 FUNCTOR: (define-blas-vector) ( TYPE T -- )
134 <DIRECT-ARRAY> IS <direct-${TYPE}-array>
135 >ARRAY IS >${TYPE}-array
140 VECTOR DEFINES-CLASS ${TYPE}-blas-vector
141 <VECTOR> DEFINES <${TYPE}-blas-vector>
142 >VECTOR DEFINES >${TYPE}-blas-vector
146 XVECTOR{ DEFINES ${t}vector{
153 TUPLE: VECTOR < blas-vector-base ;
154 : <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
156 : >VECTOR ( seq -- v )
157 [ >ARRAY underlying>> ] [ length ] bi 1 <VECTOR> ;
160 TYPE heap-size (prepare-copy)
161 [ XCOPY ] 3dip <VECTOR> ;
163 M: VECTOR element-type
166 (prepare-swap) [ XSWAP ] 2dip ;
168 (prepare-nrm2) IXAMAX 1 - ;
170 M: VECTOR (blas-vector-like)
173 M: VECTOR (blas-direct-array)
175 [ [ length>> ] [ inc>> ] bi * ] bi
179 (prepare-axpy) [ XAXPY ] dip ;
181 (prepare-scal) [ XSCAL ] dip ;
183 SYNTAX: XVECTOR{ \ } [ >VECTOR ] parse-literal ;
185 M: VECTOR pprint-delims
186 drop \ XVECTOR{ \ } ;
191 FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
193 VECTOR IS ${TYPE}-blas-vector
205 (prepare-nrm2) XNRM2 ;
207 (prepare-nrm2) XASUM ;
212 FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
214 VECTOR IS ${TYPE}-blas-vector
217 XXNRM2 IS ${S}${C}NRM2
218 XXASUM IS ${S}${C}ASUM
223 (prepare-dot) XDOTU ;
225 (prepare-dot) XDOTC ;
227 (prepare-nrm2) XXNRM2 ;
229 (prepare-nrm2) XXASUM ;
234 : define-real-blas-vector ( TYPE T -- )
235 [ (define-blas-vector) ]
236 [ (define-real-blas-vector) ] 2bi ;
237 : define-complex-blas-vector ( TYPE C S -- )
238 [ drop (define-blas-vector) ]
239 [ (define-complex-blas-vector) ] 3bi ;
241 "float" "S" define-real-blas-vector
242 "double" "D" define-real-blas-vector
243 "complex-float" "C" "S" define-complex-blas-vector
244 "complex-double" "Z" "D" define-complex-blas-vector
248 M: blas-vector-base >pprint-sequence ;
249 M: blas-vector-base pprint* pprint-object ;