GNU Octave  4.2.1
A high-level interpreted language, primarily intended for numerical computations, mostly compatible with Matlab
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Properties Friends Macros Pages
blaswrap.c
Go to the documentation of this file.
1 /*
2 
3 Copyright (C) 2012-2017 Jarno Rajahalme
4 
5 This file is part of Octave.
6 
7 Octave is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 3 of the License, or (at your
10 option) any later version.
11 
12 Octave is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16 
17 You should have received a copy of the GNU General Public License
18 along with Octave; see the file COPYING. If not, see
19 <http://www.gnu.org/licenses/>.
20 
21 */
22 
23 /*
24 
25 Wrapper for Apple libBLAS.dylib and libLAPACK.dylib
26 
27 At least on the versions of OSX 10.6 so far (up and including 10.6.6)
28 these libraries are incompatible with 64 bit builds, as some functions
29 in libBLAS.dylib are not conforming to F2C calling conventions, as
30 they should. This breaks them in 64-bit builds on the x86_64
31 architecture.
32 
33 Newer gfortran compoilers no longer default to the F2C calling
34 convention. These wrappers map the F2C conformant functions in
35 libBLAS and libLAPACK to the native gfortran calling convention, so
36 that the libraries can be used with software built for x86_64
37 architecture.
38 
39 */
40 
41 #if defined (HAVE_CONFIG_H)
42 # include "config.h" /* USE_BLASWRAP ? */
43 #endif
44 
45 #if defined (USE_BLASWRAP)
46 
47 /*
48  * vecLib is an Apple framework (collection of libraries) containing
49  * libBLAS and libLAPACK. The fortran stubs in these libraries are
50  * (mostly, but not completely) in the F2C calling convention.
51  * We access the libraries via the vecLib framework to make sure we
52  * get the Apple versions, rather than some other blas/lapack with the
53  * same name.
54  */
55 #if ! defined (VECLIB_FILE)
56 # define VECLIB_FILE "/System/Library/Frameworks/vecLib.framework/Versions/A/vecLib"
57 #endif
58 
59 /*
60  * Since this is a wrapper for fortran functions,
61  * we do not have prototypes for them.
62  */
63 #pragma GCC diagnostic ignored "-Wmissing-prototypes"
64 
65 #include <dlfcn.h>
66 #include <stdlib.h>
67 
68 /*
69  * Apple LAPACK follows F2C calling convention,
70  * Convert to normal gfortran calling convention
71  */
72 
73 static void (*f2c_blas_func[]) (void); /* forward declaration for wrapper */
74 static void (*f2c_lapack_func[]) (void); /* forward declaration for wrapper */
75 
76 /*
77  * LAPACK Wrappers, only need to convert the return value from double to float
78  */
79 
80 typedef double (*F2C_CALL_0) (void);
81 typedef double (*F2C_CALL_1) (void *a1);
82 typedef double (*F2C_CALL_2) (void *a1, void *a2);
83 typedef double (*F2C_CALL_3) (void *a1, void *a2, void *a3);
84 typedef double (*F2C_CALL_4) (void *a1, void *a2, void *a3, void *a4);
85 typedef double (*F2C_CALL_5) (void *a1, void *a2, void *a3, void *a4, void *a5);
86 typedef double (*F2C_CALL_6) (void *a1, void *a2, void *a3, void *a4, void *a5,
87  void *a6);
88 typedef double (*F2C_CALL_7) (void *a1, void *a2, void *a3, void *a4, void *a5,
89  void *a6, void *a7);
90 typedef double (*F2C_CALL_8) (void *a1, void *a2, void *a3, void *a4, void *a5,
91  void *a6, void *a7, void *a8);
92 
93 #define F2C_LAPACK_CALL_8(name) \
94  float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6, void *a7, void *a8) \
95  { \
96  return ((F2C_CALL_8)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6, a7, a8); \
97  }
98 
99 #define F2C_LAPACK_CALL_7(name) \
100  float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6, void *a7) \
101  { \
102  return ((F2C_CALL_7)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6, a7); \
103  }
104 
105 #define F2C_LAPACK_CALL_6(name) \
106  float name (void *a1, void *a2, void *a3, void *a4, void *a5, void *a6) \
107  { \
108  return ((F2C_CALL_6)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5, a6); \
109  }
110 
111 #define F2C_LAPACK_CALL_5(name) \
112  float name (void *a1, void *a2, void *a3, void *a4, void *a5) \
113  { \
114  return ((F2C_CALL_5)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4, a5); \
115  }
116 
117 #define F2C_LAPACK_CALL_4(name) \
118  float name (void *a1, void *a2, void *a3, void *a4) \
119  { \
120  return ((F2C_CALL_4)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3, a4); \
121  }
122 
123 #define F2C_LAPACK_CALL_3(name) \
124  float name (void *a1, void *a2, void *a3) \
125  { \
126  return ((F2C_CALL_3)f2c_lapack_func[f2c_ ## name]) (a1, a2, a3); \
127  }
128 
129 #define F2C_LAPACK_CALL_2(name) \
130  float name (void *a1, void *a2) \
131  { \
132  return ((F2C_CALL_2)f2c_lapack_func[f2c_ ## name]) (a1, a2); \
133  }
134 
135 #define F2C_LAPACK_CALL_1(name) \
136  float name (void *a1) \
137  { \
138  return ((F2C_CALL_1)f2c_lapack_func[f2c_ ## name]) (a1); \
139  }
140 
141 #define F2C_LAPACK_CALL_0(name) \
142  float name (void) \
143  { \
144  return ((F2C_CALL_0)f2c_lapack_func[f2c_ ## name]) (); \
145  }
146 
147 #define F2C_LAPACK_CALL_NONE(name)
148 
149 #define F2C_LAPACK_CALL(name, args) F2C_LAPACK_CALL_ ## args (name)
150 
151 #define ENUM_ITEM(name, args) \
152  f2c_ ## name,
153 
154 #define NAME_TO_STRING_CASE(name, args) \
155  case f2c_ ## name: return #name;
156 
157 #define DEFINE_LAPACK_ENUM(name, list) \
158  typedef enum { \
159  list(ENUM_ITEM) \
160  } name; \
161  static const char* \
162  f2c_ ## name ## _name (name n) { \
163  switch (n) { \
164  list(NAME_TO_STRING_CASE) \
165  default: return ""; \
166  } \
167  } \
168  list(F2C_LAPACK_CALL)
169 
170 #define DEFINE_BLAS_ENUM(name, list) \
171  typedef enum { \
172  list(ENUM_ITEM) \
173  } name; \
174  static const char* \
175  f2c_ ## name ## _name(name n) { \
176  switch (n) { \
177  list(NAME_TO_STRING_CASE) \
178  default: return ""; \
179  } \
180  }
181 
182 /*
183  * Lapack functions (with argument count) that need the return value
184  * converted from double to float
185  */
186 #define LAPACK_LIST(_) \
187  _(clangb_,7) \
188  _(clange_,6) \
189  _(clangt_,5) \
190  _(clanhb_,7) \
191  _(clanhe_,6) \
192  _(clanhp_,5) \
193  _(clanhs_,5) \
194  _(clanht_,4) \
195  _(clansb_,7) \
196  _(clansp_,5) \
197  _(clansy_,6) \
198  _(clantb_,8) \
199  _(clantp_,6) \
200  _(clantr_,8) \
201  _(scsum1_,3) \
202  _(second_,0) \
203  _(slamc3_,2) \
204  _(slamch_,1) \
205  _(slangb_,7) \
206  _(slange_,6) \
207  _(slangt_,5) \
208  _(slanhs_,5) \
209  _(slansb_,7) \
210  _(slansp_,5) \
211  _(slanst_,4) \
212  _(slansy_,6) \
213  _(slantb_,8) \
214  _(slantp_,6) \
215  _(slantr_,8) \
216  _(slapy2_,2) \
217  _(slapy3_,3) \
218  _(LAPACK_COUNT,NONE)
219 
220 /*
221  * These need a bit more complex wrappers
222  */
223 #define BLAS_LIST(_) \
224  _(cdotu_,6) \
225  _(zdotu_,6) \
226  _(cdotc_,6) \
227  _(zdotc_,6) \
228  _(BLAS_COUNT,NONE)
229 
230 DEFINE_BLAS_ENUM(blas, BLAS_LIST)
231 
232 DEFINE_LAPACK_ENUM(lapack, LAPACK_LIST)
233 
234 /*
235  * BLAS wrappers, F2C convention passes retuned complex as an extra first
236  * argument
237  */
238 typedef struct { float r, i; } complex;
239 typedef struct { double r, i; } doublecomplex;
240 
241 typedef void (*F2C_BLAS_CALL_6) (void *c, void *a1, void *a2, void *a3,
242  void *a4, void *a5);
243 
244 #define F2C_BLAS_CALL(type, name) \
245 type name (void *a1, void *a2, void *a3, void *a4, void *a5) \
246 { \
247  type cplx; \
248  ((F2C_BLAS_CALL_6)f2c_blas_func[f2c_ ## name]) (&cplx, a1, a2, a3, a4, a5); \
249  return cplx; \
250 }
251 
252 F2C_BLAS_CALL(complex, cdotu_)
253 F2C_BLAS_CALL(doublecomplex, zdotu_)
254 F2C_BLAS_CALL(complex, cdotc_)
255 F2C_BLAS_CALL(doublecomplex, zdotc_)
256 
257 /*
258  * Function pointer arrays, indexed by the enums
259  */
260 static void (*f2c_blas_func[f2c_BLAS_COUNT]) (void) = { 0 };
261 static void (*f2c_lapack_func[f2c_LAPACK_COUNT]) (void) = { 0 };
262 
263 /*
264  * Initialization: This is called before main ().
265  * Get the function pointers to the wrapped functions in Apple vecLib
266  */
267 
268 static void * apple_vecLib = 0;
269 
270 __attribute__((constructor))
271 static void initVecLibWrappers (void)
272 {
273  apple_vecLib = dlopen (VECLIB_FILE, RTLD_LOCAL | RTLD_NOLOAD | RTLD_FIRST);
274  if (0 == apple_vecLib)
275  abort ();
276 
277  int i;
278  for (i = 0; i < f2c_LAPACK_COUNT; i++)
279  if (0 == (f2c_lapack_func[i] = dlsym (apple_vecLib, f2c_lapack_name(i))))
280  abort ();
281  for (i = 0; i < f2c_BLAS_COUNT; i++)
282  if (0 == (f2c_blas_func[i] = dlsym (apple_vecLib, f2c_blas_name(i))))
283  abort ();
284 }
285 
286 __attribute__((destructor))
287 static void finiVecLibWrappers (void)
288 {
289  if (apple_vecLib)
290  dlclose (apple_vecLib);
291  apple_vecLib = 0;
292 }
293 
294 #endif /* USE_BLASWRAP */
create a structure array and initialize its values The dimensions of each cell array of values must match Singleton cells and non cell values are repeated so that they fill the entire array If the cells are create an empty structure array with the specified field names If the argument is an return the underlying struct Observe that the syntax is optimized for struct trong struct("foo", 1) esult
Definition: ov-struct.cc:1688
const octave_base_value & a2
the sparsity preserving column transformation such that that defines the pivoting threshold can be given in which case it defines the c
Definition: lu.cc:138
=val(i)}if ode{val(i)}occurs in table i
Definition: lookup.cc:239
issues an error eealso double
Definition: ov-bool-mat.cc:594