WIP: Handle defective implementations of float functions.

This is a very crude attempt to check whether BLAS functions that should
return single-precision floating point values actually do that.
Some implementations (like Apple Accelerate) don't do that. See mpimd-csc#65.

This is mainly meant for early feedback.

Author: mmuetzel

src/flexiblas.c

@@ -216,6 +216,9 @@ static void flexiblas_load_info(void *library, flexiblas_backend_t *backend)
 
 #endif
 
+    /* Check if functions return the correct type (real) */
+    backend->info.float_function_defect = __flexiblas_check_float_function(library, backend->info.intel_interface);
+
     /* Get the Integer size of the backend */
     flexiblas_interface_t interface = __flexiblas_get_interface(library);
     if ( interface == FLEXIBLAS_INTERFACE_LP64 )

src/flexiblas.h

@@ -145,6 +145,7 @@ int __flexiblas_load_fortran_function( void * handle , struct flexiblas_blasfn *
 int __flexiblas_load_blas_hooks(flexiblas_hook_t *backend, void *hook_handle);
 void * __flexiblas_lookup_fortran_function(void * handle, const char *name);
 flexiblas_complex_interface_t __flexiblas_get_complex_interface(void *handle);
+int __flexiblas_check_float_function(void *handle, int intel_interface);
 flexiblas_interface_t __flexiblas_get_interface(void *handle);
 
 void __flexiblas_backend_init( flexiblas_backend_t * backend);

src/flexiblas_backend.h

@@ -53,6 +53,7 @@ extern "C" {
         int flexiblas_integer_size;
         int backend_integer_size;
         int intel_interface;
+        int float_function_defect;
         int post_init;
     } flexiblas_info_t;
 

src/loader.c

@@ -199,6 +199,44 @@ HIDDEN flexiblas_complex_interface_t __flexiblas_get_complex_interface(void *han
 #endif
 }
 
+HIDDEN int __flexiblas_check_float_function(void *handle, int intel_interface)
+{
+    if (handle == NULL) {
+        return 0;
+    }
+    void *sdot_ptr = __flexiblas_lookup_fortran_function(handle, "sdot");
+    if ( sdot_ptr == NULL) {
+        DPRINTF(2, "Could not check for defect of functions with real return value. SDOT not found.\n");
+        return 0;
+    }
+
+    float retval = 0.0;
+    float x[2] = {1.0, 2.0};
+    float y[2] = {3.0, 4.0};
+    if (intel_interface) {
+#ifdef FLEXIBLAS_INTEGER8
+        void  (*sdot)(float *, int64_t *, float *, int64_t *, float *, int64_t *);
+#else
+        void  (*sdot)(float *, int32_t *, float *, int32_t *, float *, int32_t *);
+#endif
+
+        sdot(&retval, 2, x, 1, y, 1);
+    } else {
+#ifdef FLEXIBLAS_INTEGER8
+        float (*sdot)(int64_t *, float *, int64_t *, float *, int64_t *);
+#else
+        float (*sdot)(int32_t *, float *, int32_t *, float *, int32_t *);
+#endif
+
+        retval = sdot(2, x, 1, y, 1);
+    }
+
+    if (retval == 11.0)
+        return 0;
+    else
+        return 1;
+}
+
 HIDDEN flexiblas_interface_t __flexiblas_get_interface(void *handle)
 {
     if (handle == NULL) {

src/wrapper_blas_gnu.c

@@ -6605,20 +6605,37 @@ static TLS_STORE uint8_t hook_pos_sdot = 0;
 
 float FC_GLOBAL(sdot,SDOT)(blasint* n, float* sx, blasint* incx, float* sy, blasint* incy)
 {
-    float (*fn) (void* n, void* sx, void* incx, void* sy, void* incy);
-    float (*fn_hook) (void* n, void* sx, void* incx, void* sy, void* incy);
     float ret;
-    if ( current_backend->post_init != 0 ) {
-        __flexiblas_backend_init(current_backend);
-        current_backend->post_init = 0;
-    }
-    *(void **) &fn = current_backend->blas.sdot.f77_blas_function;
-    *(void **) &fn_hook = __flexiblas_hooks->sdot.f77_hook_function[0];
-    hook_pos_sdot = 0;
-    if ( fn_hook != NULL) {
-        ret = fn_hook((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+    if (current_backend->info.float_function_defect) {
+        double (*fn) (void* n, void* sx, void* incx, void* sy, void* incy);
+        double (*fn_hook) (void* n, void* sx, void* incx, void* sy, void* incy);
+        if ( current_backend->post_init != 0 ) {
+            __flexiblas_backend_init(current_backend);
+            current_backend->post_init = 0;
+        }
+        *(void **) &fn = current_backend->blas.sdot.f77_blas_function;
+        *(void **) &fn_hook = __flexiblas_hooks->sdot.f77_hook_function[0];
+        hook_pos_sdot = 0;
+        if ( fn_hook != NULL) {
+            ret = fn_hook((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        } else {
+            ret = fn((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        }
     } else {
-        ret = fn((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        float (*fn) (void* n, void* sx, void* incx, void* sy, void* incy);
+        float (*fn_hook) (void* n, void* sx, void* incx, void* sy, void* incy);
+        if ( current_backend->post_init != 0 ) {
+            __flexiblas_backend_init(current_backend);
+            current_backend->post_init = 0;
+        }
+        *(void **) &fn = current_backend->blas.sdot.f77_blas_function;
+        *(void **) &fn_hook = __flexiblas_hooks->sdot.f77_hook_function[0];
+        hook_pos_sdot = 0;
+        if ( fn_hook != NULL) {
+            ret = fn_hook((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        } else {
+            ret = fn((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        }
     }
     return ret;
 }

src/wrapper_blas_intel.c

@@ -6607,20 +6607,37 @@ static TLS_STORE uint8_t hook_pos_sdot = 0;
 
 float FC_GLOBAL(sdot,SDOT)(blasint* n, float* sx, blasint* incx, float* sy, blasint* incy)
 {
-    float (*fn) (void* n, void* sx, void* incx, void* sy, void* incy);
-    float (*fn_hook) (void* n, void* sx, void* incx, void* sy, void* incy);
     float ret;
-    if ( current_backend->post_init != 0 ) {
-        __flexiblas_backend_init(current_backend);
-        current_backend->post_init = 0;
-    }
-    *(void **) &fn = current_backend->blas.sdot.f77_blas_function;
-    *(void **) &fn_hook = __flexiblas_hooks->sdot.f77_hook_function[0];
-    hook_pos_sdot = 0;
-    if ( fn_hook != NULL) {
-        ret = fn_hook((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+    if (current_backend->info.float_function_defect) {
+        double (*fn) (void* n, void* sx, void* incx, void* sy, void* incy);
+        double (*fn_hook) (void* n, void* sx, void* incx, void* sy, void* incy);
+        if ( current_backend->post_init != 0 ) {
+            __flexiblas_backend_init(current_backend);
+            current_backend->post_init = 0;
+        }
+        *(void **) &fn = current_backend->blas.sdot.f77_blas_function;
+        *(void **) &fn_hook = __flexiblas_hooks->sdot.f77_hook_function[0];
+        hook_pos_sdot = 0;
+        if ( fn_hook != NULL) {
+            ret = fn_hook((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        } else {
+            ret = fn((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        }
     } else {
-        ret = fn((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        float (*fn) (void* n, void* sx, void* incx, void* sy, void* incy);
+        float (*fn_hook) (void* n, void* sx, void* incx, void* sy, void* incy);
+        if ( current_backend->post_init != 0 ) {
+            __flexiblas_backend_init(current_backend);
+            current_backend->post_init = 0;
+        }
+        *(void **) &fn = current_backend->blas.sdot.f77_blas_function;
+        *(void **) &fn_hook = __flexiblas_hooks->sdot.f77_hook_function[0];
+        hook_pos_sdot = 0;
+        if ( fn_hook != NULL) {
+            ret = fn_hook((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        } else {
+            ret = fn((void*) n, (void*) sx, (void*) incx, (void*) sy, (void*) incy);
+        }
     }
     return ret;
 }