GNU Octave  4.0.0
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-2015 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 #ifdef HAVE_CONFIG_H
42 #include <config.h> /* USE_BLASWRAP ? */
43 #endif
44 
45 #ifdef 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 #ifndef 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 /*
259  * Function pointer arrays, indexed by the enums
260  */
261 static void (*f2c_blas_func[f2c_BLAS_COUNT]) (void) = { 0 };
262 static void (*f2c_lapack_func[f2c_LAPACK_COUNT]) (void) = { 0 };
263 
264 /*
265  * Initialization: This is called before main ().
266  * Get the function pointers to the wrapped functions in Apple vecLib
267  */
268 
269 static void * apple_vecLib = 0;
270 
271 __attribute__((constructor))
272 static void initVecLibWrappers (void)
273 {
274  apple_vecLib = dlopen (VECLIB_FILE, RTLD_LOCAL | RTLD_NOLOAD | RTLD_FIRST);
275  if (0 == apple_vecLib)
276  abort ();
277 
278  int i;
279  for (i = 0; i < f2c_LAPACK_COUNT; i++)
280  if (0 == (f2c_lapack_func[i] = dlsym (apple_vecLib, f2c_lapack_name(i))))
281  abort ();
282  for (i = 0; i < f2c_BLAS_COUNT; i++)
283  if (0 == (f2c_blas_func[i] = dlsym (apple_vecLib, f2c_blas_name(i))))
284  abort ();
285 }
286 
287 __attribute__((destructor))
288 static void finiVecLibWrappers (void)
289 {
290  if (apple_vecLib)
291  dlclose (apple_vecLib);
292  apple_vecLib = 0;
293 }
294 
295 #endif /* USE_BLASWRAP */
a2
const octave_base_value & a2
Definition: op-int-concat.cc:165
Generated on Thu Jun 4 2015 23:30:24 for GNU Octave by   doxygen 1.8.8