Add a portable XERBLA handler API

CMakeLists.txt

@@ -734,18 +734,46 @@ if(NOT NO_CBLAS)
   set(CBLAS_H ${CMAKE_BINARY_DIR}/generated/cblas.h)
   file(READ ${CMAKE_CURRENT_SOURCE_DIR}/cblas.h CBLAS_H_CONTENTS)
   string(REPLACE "common" "openblas_config" CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS}")
+
+  # Symbol prefix/suffix settings rename exported functions, not C typedefs.
+  # Protect callback type names from the textual function-name rewriting below.
+  string(REPLACE "openblas_dojob_callback" "OPENBLAS_DOJOB_CALLBACK_TYPE"
+    CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+  string(REPLACE "openblas_threads_callback" "OPENBLAS_THREADS_CALLBACK_TYPE"
+    CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+  string(REPLACE "openblas_xerbla_handler" "OPENBLAS_XERBLA_HANDLER_TYPE"
+    CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+
   if (NOT ${SYMBOLPREFIX} STREQUAL "")
-    string(REPLACE " cblas" " ${SYMBOLPREFIX}cblas" CBLAS_H_CONTENTS	"${CBLAS_H_CONTENTS_NEW}")
-    string(REPLACE " openblas" " ${SYMBOLPREFIX}openblas" CBLAS_H_CONTENTS_NEW	"${CBLAS_H_CONTENTS}")
-    string (REPLACE " ${SYMBOLPREFIX}openblas_complex" " openblas_complex" CBLAS_H_CONTENTS	"${CBLAS_H_CONTENTS_NEW}")
-    string(REPLACE " goto" " ${SYMBOLPREFIX}goto" CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS}")
+    string(REPLACE " cblas" " ${SYMBOLPREFIX}cblas"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+    string(REPLACE " openblas" " ${SYMBOLPREFIX}openblas"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+    string(REPLACE " ${SYMBOLPREFIX}openblas_complex" " openblas_complex"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+    string(REPLACE " goto" " ${SYMBOLPREFIX}goto"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
   endif()
   if (NOT ${SYMBOLSUFFIX} STREQUAL "")
-    string(REGEX REPLACE "(cblas[^ (]*)" "\\1${SYMBOLSUFFIX}" CBLAS_H_CONTENTS	"${CBLAS_H_CONTENTS_NEW}")
-    string(REGEX REPLACE "(openblas[^ (]*)" "\\1${SYMBOLSUFFIX}" CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS}")
-    string(REGEX REPLACE "(openblas_complex[^ ]*)${SYMBOLSUFFIX}" "\\1" CBLAS_H_CONTENTS	"${CBLAS_H_CONTENTS_NEW}")
-    string(REGEX REPLACE "(goto[^ (]*)" "\\1${SYMBOLSUFFIX}" CBLAS_H_CONTENTS_NEW	"${CBLAS_H_CONTENTS}")
-  endif()
+    string(REGEX REPLACE "(cblas[A-Za-z0-9_]*)" "\\1${SYMBOLSUFFIX}"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+    string(REGEX REPLACE "(openblas[A-Za-z0-9_]*)" "\\1${SYMBOLSUFFIX}"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+    string(REPLACE "openblas_config${SYMBOLSUFFIX}" "openblas_config"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+    string(REGEX REPLACE "(openblas_complex[A-Za-z0-9_]*)${SYMBOLSUFFIX}" "\\1"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+    string(REGEX REPLACE "(goto[A-Za-z0-9_]*)" "\\1${SYMBOLSUFFIX}"
+      CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+  endif()
+
+  string(REPLACE "OPENBLAS_DOJOB_CALLBACK_TYPE" "openblas_dojob_callback"
+    CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+  string(REPLACE "OPENBLAS_THREADS_CALLBACK_TYPE" "openblas_threads_callback"
+    CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+  string(REPLACE "OPENBLAS_XERBLA_HANDLER_TYPE" "openblas_xerbla_handler"
+    CBLAS_H_CONTENTS_NEW "${CBLAS_H_CONTENTS_NEW}")
+
   file(WRITE ${CBLAS_H} "${CBLAS_H_CONTENTS_NEW}")
   install (FILES ${CBLAS_H} DESTINATION ${CMAKE_INSTALL_INCLUDEDIR})
 endif()

Makefile.install

@@ -73,7 +73,10 @@ install : 	lib.grd
 
 ifneq ($(NO_CBLAS),1)
 	@echo Generating cblas.h in $(DESTDIR)$(OPENBLAS_INCLUDE_DIR)
-	@cp cblas.h cblas.tmp
+	@sed -e 's/openblas_dojob_callback/OPENBLAS_DOJOB_CALLBACK_TYPE/g' \
+	     -e 's/openblas_threads_callback/OPENBLAS_THREADS_CALLBACK_TYPE/g' \
+	     -e 's/openblas_xerbla_handler/OPENBLAS_XERBLA_HANDLER_TYPE/g' \
+	     cblas.h > cblas.tmp
 ifdef SYMBOLPREFIX
 	@sed 's/cblas[^() ]*/$(SYMBOLPREFIX)&/g' cblas.tmp > cblas.tmp2
 	@sed 's/openblas[^() ]*/$(SYMBOLPREFIX)&/g'  cblas.tmp2 > cblas.tmp
@@ -88,7 +91,11 @@ ifdef SYMBOLSUFFIX
 	@sed 's/\(openblas_complex_\)\([^ ]*\)$(SYMBOLSUFFIX)/\1\2 /g'  cblas.tmp > cblas.tmp2
 	@sed 's/goto[^() ]*/&$(SYMBOLSUFFIX)/g'  cblas.tmp2 > cblas.tmp
 endif
-	@sed 's/common/openblas_config/g' cblas.tmp > "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/cblas.h"
+	@sed -e 's/OPENBLAS_DOJOB_CALLBACK_TYPE/openblas_dojob_callback/g' \
+	     -e 's/OPENBLAS_THREADS_CALLBACK_TYPE/openblas_threads_callback/g' \
+	     -e 's/OPENBLAS_XERBLA_HANDLER_TYPE/openblas_xerbla_handler/g' \
+	     -e 's/common/openblas_config/g' \
+	     cblas.tmp > "$(DESTDIR)$(OPENBLAS_INCLUDE_DIR)/cblas.h"
 endif
 
 ifneq ($(OSNAME), AIX)

cblas.h

@@ -59,6 +59,20 @@ typedef void (*openblas_dojob_callback)(int thread_num, void *jobdata, int dojob
 typedef void (*openblas_threads_callback)(int sync, openblas_dojob_callback dojob, int numjobs, size_t jobdata_elsize, void *jobdata, int dojob_data);
 void openblas_set_threads_callback_function(openblas_threads_callback callback);
 
+/* Replace the XERBLA handler for this OpenBLAS instance and return the
+ * previous handler. Passing NULL restores the default. Callbacks may run
+ * concurrently and must be thread-safe. The name and info pointers are valid
+ * only during the callback; name spans name_length bytes and need not be
+ * NUL-terminated. Replacement is thread-safe but does not wait for in-flight
+ * calls, so the previous handler must remain loaded until they complete. */
+#ifndef OPENBLAS_XERBLA_HANDLER_DEFINED
+#define OPENBLAS_XERBLA_HANDLER_DEFINED
+typedef void (*openblas_xerbla_handler)(const char *name,
+                                        const blasint *info,
+                                        size_t name_length);
+#endif
+openblas_xerbla_handler openblas_set_xerbla(openblas_xerbla_handler handler);
+
 #ifdef OPENBLAS_OS_LINUX
 /* Sets thread affinity for OpenBLAS threads. `thread_idx` is in [0, openblas_get_num_threads()-1]. */
 int openblas_setaffinity(int thread_idx, size_t cpusetsize, cpu_set_t* cpu_set);

common.h

@@ -880,6 +880,26 @@ typedef struct {
 #endif
 
 #include "common_interface.h"
+
+/* Internal declaration of the public C XERBLA callback API. Keep this out of
+ * common_interface.h, whose contents are copied verbatim into f77blas.h and
+ * are not adjusted for SYMBOLPREFIX/SYMBOLSUFFIX by the CMake build. */
+#ifndef ASSEMBLER
+#ifdef __cplusplus
+extern "C" {
+#endif
+#ifndef OPENBLAS_XERBLA_HANDLER_DEFINED
+#define OPENBLAS_XERBLA_HANDLER_DEFINED
+typedef void (*openblas_xerbla_handler)(const char *name,
+                                        const blasint *info,
+                                        size_t name_length);
+#endif
+openblas_xerbla_handler openblas_set_xerbla(openblas_xerbla_handler handler);
+#ifdef __cplusplus
+}
+#endif
+#endif
+
 #ifdef SANITY_CHECK
 #include "common_reference.h"
 #endif

ctest/CMakeLists.txt

@@ -18,6 +18,7 @@ if(WIN32)
 FILE(WRITE ${CMAKE_CURRENT_BINARY_DIR}/test_cblas_helper.ps1
 "$ErrorActionPreference = \"Stop\"\n"
 "Get-Content $args[1] | & $args[0]\n"
+"exit $LASTEXITCODE\n"
 )
 set(test_helper powershell -ExecutionPolicy Bypass "${CMAKE_CURRENT_BINARY_DIR}/test_cblas_helper.ps1")
 else()

ctest/c_c2chke.c

@@ -4,21 +4,14 @@
 #include "cblas_test.h"
 
 int cblas_ok, cblas_lerr, cblas_info;
-int link_xerbla=TRUE;
 char *cblas_rout;
 
-#ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
-#else
-void F77_xerbla(char *srname, void *vinfo);
-#endif
-
 void chkxer(void) {
    extern int cblas_ok, cblas_lerr, cblas_info;
-   extern int link_xerbla;
    extern char *cblas_rout;
    if (cblas_lerr == 1 ) {
-      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout);
+      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %lld NOT DETECTED BY %s *****\n",
+             (long long)cblas_info, cblas_rout);
       cblas_ok = 0 ;
    }
    cblas_lerr = 1 ;
@@ -36,11 +29,7 @@ void F77_c2chke(char *rout) {
    extern int RowMajorStrg;
    extern char *cblas_rout;
 
-   if (link_xerbla) /* call these first to link */
-   {
-      cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
-   }
+   cblas_test_set_xerbla();
 
    cblas_ok = TRUE ;
    cblas_lerr = PASSED ;
@@ -821,6 +810,8 @@ void F77_c2chke(char *rout) {
    }
    if (cblas_ok == TRUE)
        printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout);
-   else
+   else {
        printf("******* %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout);
+       cblas_test_fail();
+   }
 }

ctest/c_c3chke.c

@@ -4,21 +4,14 @@
 #include "cblas_test.h"
 
 int cblas_ok, cblas_lerr, cblas_info;
-int link_xerbla=TRUE;
 char *cblas_rout;
 
-#ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
-#else
-void F77_xerbla(char *srname, void *vinfo);
-#endif
-
 void chkxer(void) {
    extern int cblas_ok, cblas_lerr, cblas_info;
-   extern int link_xerbla;
    extern char *cblas_rout;
    if (cblas_lerr == 1 ) {
-      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout);
+      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %lld NOT DETECTED BY %s *****\n",
+             (long long)cblas_info, cblas_rout);
       cblas_ok = 0 ;
    }
    cblas_lerr = 1 ;
@@ -39,11 +32,7 @@ void  F77_c3chke(char *  rout) {
    cblas_ok = TRUE ;
    cblas_lerr = PASSED ;
 
-   if (link_xerbla) /* call these first to link */
-   {
-      cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
-   }
+   cblas_test_set_xerbla();
 
 
    if (strncmp( sf,"cblas_cgemm"   ,11)==0) {
@@ -1703,6 +1692,8 @@ void  F77_c3chke(char *  rout) {
 
    if (cblas_ok == 1 )
        printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout);
-   else
+   else {
        printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout);
+       cblas_test_fail();
+   }
 }

ctest/c_c3chke_3m.c

@@ -4,21 +4,14 @@
 #include "cblas_test.h"
 
 int cblas_ok, cblas_lerr, cblas_info;
-int link_xerbla=TRUE;
 char *cblas_rout;
 
-#ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
-#else
-void F77_xerbla(char *srname, void *vinfo);
-#endif
-
 void chkxer(void) {
    extern int cblas_ok, cblas_lerr, cblas_info;
-   extern int link_xerbla;
    extern char *cblas_rout;
    if (cblas_lerr == 1 ) {
-      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout);
+      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %lld NOT DETECTED BY %s *****\n",
+             (long long)cblas_info, cblas_rout);
       cblas_ok = 0 ;
    }
    cblas_lerr = 1 ;
@@ -39,11 +32,7 @@ void  F77_c3chke(char *  rout) {
    cblas_ok = TRUE ;
    cblas_lerr = PASSED ;
 
-   if (link_xerbla) /* call these first to link */
-   {
-      cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
-   }
+   cblas_test_set_xerbla();
 
 
    if (strncmp( sf,"cblas_cgemm3m"   ,13)==0) {
@@ -1931,6 +1920,8 @@ void  F77_c3chke(char *  rout) {
 
    if (cblas_ok == 1 )
        printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout);
-   else
+   else {
        printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout);
+       cblas_test_fail();
+   }
 }

ctest/c_d2chke.c

@@ -4,21 +4,14 @@
 #include "cblas_test.h"
 
 int cblas_ok, cblas_lerr, cblas_info;
-int link_xerbla=TRUE;
 char *cblas_rout;
 
-#ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
-#else
-void F77_xerbla(char *srname, void *vinfo);
-#endif
-
 void chkxer(void) {
    extern int cblas_ok, cblas_lerr, cblas_info;
-   extern int link_xerbla;
    extern char *cblas_rout;
    if (cblas_lerr == 1 ) {
-      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout);
+      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %lld NOT DETECTED BY %s *****\n",
+             (long long)cblas_info, cblas_rout);
       cblas_ok = 0 ;
    }
    cblas_lerr = 1 ;
@@ -34,11 +27,7 @@ void F77_d2chke(char *rout) {
    extern int RowMajorStrg;
    extern char *cblas_rout;
 
-   if (link_xerbla) /* call these first to link */
-   {
-      cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
-   }
+   cblas_test_set_xerbla();
 
    cblas_ok = TRUE ;
    cblas_lerr = PASSED ;
@@ -784,6 +773,8 @@ void F77_d2chke(char *rout) {
    }
    if (cblas_ok == TRUE)
        printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout);
-   else
+   else {
        printf("******* %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout);
+       cblas_test_fail();
+   }
 }

ctest/c_d3chke.c

@@ -4,21 +4,14 @@
 #include "cblas_test.h"
 
 int cblas_ok, cblas_lerr, cblas_info;
-int link_xerbla=TRUE;
 char *cblas_rout;
 
-#ifdef F77_Char
-void F77_xerbla(F77_Char F77_srname, void *vinfo);
-#else
-void F77_xerbla(char *srname, void *vinfo);
-#endif
-
 void chkxer(void) {
    extern int cblas_ok, cblas_lerr, cblas_info;
-   extern int link_xerbla;
    extern char *cblas_rout;
    if (cblas_lerr == 1 ) {
-      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %d NOT DETECTED BY %s *****\n", cblas_info, cblas_rout);
+      printf("***** ILLEGAL VALUE OF PARAMETER NUMBER %lld NOT DETECTED BY %s *****\n",
+             (long long)cblas_info, cblas_rout);
       cblas_ok = 0 ;
    }
    cblas_lerr = 1 ;
@@ -34,11 +27,7 @@ void F77_d3chke(char *rout) {
    extern int RowMajorStrg;
    extern char *cblas_rout;
 
-   if (link_xerbla) /* call these first to link */
-   {
-      cblas_xerbla(cblas_info,cblas_rout,"");
-      F77_xerbla(cblas_rout,&cblas_info);
-   }
+   cblas_test_set_xerbla();
 
    cblas_ok = TRUE ;
    cblas_lerr = PASSED ;
@@ -1266,6 +1255,8 @@ void F77_d3chke(char *rout) {
    }
    if (cblas_ok == TRUE )
        printf(" %-12s PASSED THE TESTS OF ERROR-EXITS\n", cblas_rout);
-   else
+   else {
        printf("***** %s FAILED THE TESTS OF ERROR-EXITS *******\n",cblas_rout);
+       cblas_test_fail();
+   }
 }