diff --git a/CMakeLists.txt b/CMakeLists.txt index c88d9dd3e1..27aeae1e26 100644 --- a/CMakeLists.txt +++ b/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() diff --git a/Makefile.install b/Makefile.install index e656b368a8..cbeab53f81 100644 --- a/Makefile.install +++ b/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) diff --git a/cblas.h b/cblas.h index 8395f1b8b2..3d4143256b 100644 --- a/cblas.h +++ b/cblas.h @@ -59,6 +59,18 @@ 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); +/* Set the process-wide error handler called by XERBLA. The callback's routine + * name is valid for name_length bytes and is not necessarily NUL-terminated. + * Installation is thread-safe, returns the previous handler, and accepts NULL + * to restore OpenBLAS' default handler. */ +#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); diff --git a/common.h b/common.h index a611c9cb07..336cb298e4 100644 --- a/common.h +++ b/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 diff --git a/ctest/c_c2chke.c b/ctest/c_c2chke.c index eb5b99008f..2129aad3fa 100644 --- a/ctest/c_c2chke.c +++ b/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(); + } } diff --git a/ctest/c_c3chke.c b/ctest/c_c3chke.c index 3b4764c4a7..6b6b7684d9 100644 --- a/ctest/c_c3chke.c +++ b/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(); + } } diff --git a/ctest/c_c3chke_3m.c b/ctest/c_c3chke_3m.c index 4d5de5150c..767d0cfeb2 100644 --- a/ctest/c_c3chke_3m.c +++ b/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(); + } } diff --git a/ctest/c_d2chke.c b/ctest/c_d2chke.c index 7cdd04135c..cb4ed8876a 100644 --- a/ctest/c_d2chke.c +++ b/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(); + } } diff --git a/ctest/c_d3chke.c b/ctest/c_d3chke.c index 700cff28f6..aff8380eb0 100644 --- a/ctest/c_d3chke.c +++ b/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(); + } } diff --git a/ctest/c_s2chke.c b/ctest/c_s2chke.c index 1455153005..69cf042c39 100644 --- a/ctest/c_s2chke.c +++ b/ctest/c_s2chke.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_s2chke(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_s2chke(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(); + } } diff --git a/ctest/c_s3chke.c b/ctest/c_s3chke.c index 632eaae30e..c8eae8c400 100644 --- a/ctest/c_s3chke.c +++ b/ctest/c_s3chke.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_s3chke(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 ; @@ -1268,6 +1257,8 @@ void F77_s3chke(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(); + } } diff --git a/ctest/c_xerbla.c b/ctest/c_xerbla.c index 9c53576536..6f190b0c4b 100644 --- a/ctest/c_xerbla.c +++ b/ctest/c_xerbla.c @@ -1,4 +1,5 @@ #include +#include #include #include #include @@ -8,17 +9,9 @@ void cblas_xerbla(blasint info, char *rout, char *form, ...) { extern int cblas_lerr, cblas_info, cblas_ok; - extern int link_xerbla; extern int RowMajorStrg; extern char *cblas_rout; - /* Initially, c__3chke will call this routine with - * global variable link_xerbla=1, and F77_xerbla will set link_xerbla=0. - * This is done to fool the linker into loading these subroutines first - * instead of ones in the CBLAS or the legacy BLAS library. - */ - if (link_xerbla) return; - if (cblas_rout != NULL && strcmp(cblas_rout, rout) != 0){ printf("***** XERBLA WAS CALLED WITH SRNAME = <%s> INSTEAD OF <%s> *******\n", rout, cblas_rout); cblas_ok = FALSE; @@ -78,44 +71,27 @@ void cblas_xerbla(blasint info, char *rout, char *form, ...) } if (info != cblas_info){ - printf("***** XERBLA WAS CALLED WITH INFO = %d INSTEAD OF %d in %s *******\n",info, cblas_info, rout); + printf("***** XERBLA WAS CALLED WITH INFO = %lld INSTEAD OF %lld in %s *******\n", + (long long)info, (long long)cblas_info, rout); cblas_lerr = PASSED; cblas_ok = FALSE; } else cblas_lerr = FAILED; } -#ifdef F77_Char -void F77_xerbla(F77_Char F77_srname, void *vinfo) -#else -void F77_xerbla(char *srname, void *vinfo) -#endif +static void cblas_test_xerbla(const char *srname, const blasint *info, + size_t length) { -#ifdef F77_Char - char *srname; -#endif - + extern int cblas_ok; char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'}; + blasint i; -#ifdef F77_Integer - F77_Integer *info=vinfo; - F77_Integer i; - extern F77_Integer link_xerbla; -#else - int *info=vinfo; - int i; - extern int link_xerbla; -#endif -#ifdef F77_Char - srname = F2C_STR(F77_srname, XerblaStrLen); -#endif - - /* See the comment in cblas_xerbla() above */ - if (link_xerbla) - { - link_xerbla = 0; + if (length < 6) { + printf("***** XERBLA WAS CALLED WITH AN INVALID ROUTINE NAME LENGTH *******\n"); + cblas_ok = FALSE; return; } - for(i=0; i < 6; i++) rout[i+6] = tolower(srname[i]); + + for(i=0; i < 6; i++) rout[i+6] = tolower((unsigned char)srname[i]); for(i=11; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0'; /* We increment *info by 1 since the CBLAS interface adds one more @@ -124,14 +100,10 @@ void F77_xerbla(char *srname, void *vinfo) cblas_xerbla(*info+1,rout,""); } -#ifdef USE64BITINT -#undef int -#endif - -int BLASFUNC(xerbla)(char *name, blasint *info, blasint length) { - - F77_xerbla(name, info); - return 0; -}; - +void cblas_test_set_xerbla(void) { + openblas_set_xerbla(cblas_test_xerbla); +} +void cblas_test_fail(void) { + exit(EXIT_FAILURE); +} diff --git a/ctest/c_z2chke.c b/ctest/c_z2chke.c index 8767b5201a..872b89fa8e 100644 --- a/ctest/c_z2chke.c +++ b/ctest/c_z2chke.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_z2chke(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_z2chke(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(); + } } diff --git a/ctest/c_z3chke.c b/ctest/c_z3chke.c index 054e723603..3bbb1ce10e 100644 --- a/ctest/c_z3chke.c +++ b/ctest/c_z3chke.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_z3chke(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(); @@ -1705,6 +1694,8 @@ void F77_z3chke(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(); + } } diff --git a/ctest/c_z3chke_3m.c b/ctest/c_z3chke_3m.c index 4be4457b41..7834934f59 100644 --- a/ctest/c_z3chke_3m.c +++ b/ctest/c_z3chke_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_z3chke(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(); @@ -1935,6 +1924,8 @@ void F77_z3chke(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(); + } } diff --git a/ctest/cblas_test.h b/ctest/cblas_test.h index 502a2fee20..9f86d0f5d7 100644 --- a/ctest/cblas_test.h +++ b/ctest/cblas_test.h @@ -30,6 +30,9 @@ #define INVALID -1 #define UNDEFINED -1 +void cblas_test_set_xerbla(void); +void cblas_test_fail(void); + typedef struct { float real; float imag; } CBLAS_TEST_COMPLEX; typedef struct { double real; double imag; } CBLAS_TEST_ZOMPLEX; diff --git a/docs/extensions.md b/docs/extensions.md index 30db9895d1..db7fad51ec 100644 --- a/docs/extensions.md +++ b/docs/extensions.md @@ -47,3 +47,10 @@ BLAS-like and conversion functions for `hfloat16` (available when OpenBLAS was c * `int openblas_set_affinity(int thread_index, size_t cpusetsize, cpu_set_t *cpuset)` sets the CPU affinity mask of the given thread to the provided cpuset. Only available on Linux, with semantics identical to `pthread_setaffinity_np`. * `openblas_set_thread_callback_function` overrides the default multithreading backend with the provided argument +* `openblas_set_xerbla(openblas_xerbla_handler handler)` installs a process-wide XERBLA error handler and returns the + previous handler. Passing `NULL` restores the default handler. Handlers must be thread-safe because they may be called + concurrently. Replacing a handler is thread-safe but does not wait for in-progress calls to return, so the previous handler's + code must remain loaded until those calls finish. The `name` and `info` pointers are valid only during the callback. `name` + points to `name_length` valid bytes and need not be NUL-terminated; the length stops before the first NUL but otherwise includes + trailing spaces. Handler registration works normally on ELF platforms. For backward compatibility, an application-provided + strong `xerbla` symbol still overrides the OpenBLAS dispatcher and bypasses the registered handler. diff --git a/driver/others/xerbla.c b/driver/others/xerbla.c index 290f2833c3..c7cc69b82b 100644 --- a/driver/others/xerbla.c +++ b/driver/others/xerbla.c @@ -36,8 +36,10 @@ /* or implied, of The University of Texas at Austin. */ /*********************************************************************/ +#include #include #include +#include #include "common.h" #if defined(OS_WINDOWS) && (defined(__MINGW32__) || defined(__MINGW64__)) @@ -46,31 +48,67 @@ #define printf _cprintf #endif -#ifdef INTERFACE64 -#define MSGFMT " ** On entry to %6s parameter number %2ld had an illegal value\n" -#else -#define MSGFMT " ** On entry to %6s parameter number %2d had an illegal value\n" -#endif +#define MSGFMT " ** On entry to %6.*s parameter number %2lld had an illegal value\n" -#ifdef __ELF__ -int __xerbla(char *message, blasint *info, blasint length){ +static size_t openblas_xerbla_name_length(const char *message, + blasint length) { + const char *terminator; - printf(MSGFMT, - message, *info); + if (message == NULL || length <= 0) return 0; - return 0; + terminator = memchr(message, '\0', (size_t)length); + if (terminator != NULL) return (size_t)(terminator - message); + + return (size_t)length; } -int BLASFUNC(xerbla)(char *, blasint *, blasint) __attribute__ ((weak, alias ("__xerbla"))); +static void openblas_xerbla_default(const char *message, const blasint *info, + size_t length) { + int precision = length > INT_MAX ? INT_MAX : (int)length; -#else + printf(MSGFMT, precision, message == NULL ? "" : message, + (long long)*info); +} + +static openblas_xerbla_handler openblas_xerbla = openblas_xerbla_default; +static volatile BLASULONG openblas_xerbla_lock = 0; + +openblas_xerbla_handler +openblas_set_xerbla(openblas_xerbla_handler handler) { + openblas_xerbla_handler previous; -int BLASFUNC(xerbla)(char *message, blasint *info, blasint length){ + if (handler == NULL) handler = openblas_xerbla_default; - printf(MSGFMT, - message, *info); + blas_lock(&openblas_xerbla_lock); + previous = openblas_xerbla; + openblas_xerbla = handler; + blas_unlock(&openblas_xerbla_lock); + return previous; +} + +static int openblas_xerbla_dispatch(char *message, blasint *info, + blasint length) { + openblas_xerbla_handler handler; + size_t name_length = openblas_xerbla_name_length(message, length); + + blas_lock(&openblas_xerbla_lock); + handler = openblas_xerbla; + blas_unlock(&openblas_xerbla_lock); + + handler(message, info, name_length); return 0; } +#ifdef __ELF__ +int __xerbla(char *message, blasint *info, blasint length) { + return openblas_xerbla_dispatch(message, info, length); +} + +int BLASFUNC(xerbla)(char *, blasint *, blasint) + __attribute__ ((weak, alias ("__xerbla"))); +#else +int BLASFUNC(xerbla)(char *message, blasint *info, blasint length) { + return openblas_xerbla_dispatch(message, info, length); +} #endif diff --git a/exports/gensymbol b/exports/gensymbol index 6284e6b6ae..bd4652b0c0 100755 --- a/exports/gensymbol +++ b/exports/gensymbol @@ -182,6 +182,7 @@ misc_no_underscore_objs=" openblas_get_config openblas_get_corename openblas_set_threads_callback_function + openblas_set_xerbla " misc_underscore_objs="" @@ -4111,10 +4112,13 @@ case "$p1" in done for obj in $no_underscore_objs; do + [ "$obj" = "openblas_set_xerbla" ] && continue printf '\t%s%s%s=%s @%s\n' \ "$symbolprefix" "$obj" "$symbolsuffix" "$obj" "$count" count=`expr $count + 1` done + printf '\t%sopenblas_set_xerbla%s=openblas_set_xerbla @%s\n' \ + "$symbolprefix" "$symbolsuffix" "$count" ;; win2khpl) diff --git a/exports/gensymbol.pl b/exports/gensymbol.pl index 85a6e9dbf5..72e30dff2d 100644 --- a/exports/gensymbol.pl +++ b/exports/gensymbol.pl @@ -178,6 +178,7 @@ openblas_get_config, openblas_get_corename, openblas_set_threads_callback_function, + openblas_set_xerbla, ); @misc_underscore_objs = ( @@ -4053,9 +4054,11 @@ foreach $objs (@no_underscore_objs) { + next if $objs eq "openblas_set_xerbla"; print "\t",$symbolprefix,$objs,$symbolsuffix,"=$objs"," \@", $count, "\n"; $count ++; } + print "\t",$symbolprefix,"openblas_set_xerbla",$symbolsuffix,"=openblas_set_xerbla \@",$count,"\n"; exit(0); } diff --git a/utest/test_extensions/common.h b/utest/test_extensions/common.h index f8c60d2686..c7de83cd77 100644 --- a/utest/test_extensions/common.h +++ b/utest/test_extensions/common.h @@ -45,7 +45,6 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. extern int check_error(void); extern void set_xerbla(char* current_rout, int expected_info); -extern int BLASFUNC(xerbla)(char *name, blasint *info, blasint length); extern void srand_generate(float *alpha, blasint n); extern void drand_generate(double *alpha, blasint n); diff --git a/utest/test_extensions/xerbla.c b/utest/test_extensions/xerbla.c index 8c90d4ce75..6d0b9f2de7 100644 --- a/utest/test_extensions/xerbla.c +++ b/utest/test_extensions/xerbla.c @@ -31,41 +31,57 @@ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. **********************************************************************************/ +#include +#include "utest/openblas_utest.h" #include "common.h" -static int link_xerbla=TRUE; +static int handler_installed = FALSE; static int lerr, _info, ok; static char *rout; -static void F77_xerbla(char *srname, void *vinfo) +static void test_xerbla(const char *srname, const blasint *vinfo, size_t length) { - blasint info=*(blasint*)vinfo; + blasint info = *vinfo; + int name_length = length > (size_t)INT_MAX ? INT_MAX : (int)length; - if (link_xerbla) - { - link_xerbla = 0; - return; - } - - if (rout != NULL && strcmp(rout, srname) != 0){ - printf("***** XERBLA WAS CALLED WITH SRNAME = <%s> INSTEAD OF <%s> *******\n", srname, rout); + if (rout != NULL && + (length != strlen(rout) || memcmp(rout, srname, length) != 0)) { + printf("***** XERBLA WAS CALLED WITH AN UNEXPECTED SRNAME INSTEAD OF <%s> *******\n", + rout); ok = FALSE; } if (info != _info){ - printf("***** XERBLA WAS CALLED WITH INFO = %d INSTEAD OF %d in %s *******\n",info, _info, srname); + printf("***** XERBLA WAS CALLED WITH INFO = %lld INSTEAD OF %d in %.*s *******\n", + (long long)info, _info, name_length, srname == NULL ? "" : srname); lerr = TRUE; ok = FALSE; } else lerr = FALSE; } -/** -* error function redefinition -*/ -int BLASFUNC(xerbla)(char *name, blasint *info, blasint length) +static void alternate_xerbla(const char *srname, const blasint *vinfo, + size_t length) +{ + (void) srname; + (void) vinfo; + (void) length; +} + +CTEST(openblas_extensions, xerbla_handler_registration) { - F77_xerbla(name, info); - return 0; + openblas_xerbla_handler original; + openblas_xerbla_handler previous; + openblas_xerbla_handler restored; + openblas_xerbla_handler default_handler; + + original = openblas_set_xerbla(test_xerbla); + previous = openblas_set_xerbla(alternate_xerbla); + restored = openblas_set_xerbla(NULL); + default_handler = openblas_set_xerbla(original); + + ASSERT_TRUE(previous == test_xerbla); + ASSERT_TRUE(restored == alternate_xerbla); + ASSERT_TRUE(default_handler != NULL); } int check_error(void) { @@ -78,8 +94,10 @@ int check_error(void) { } void set_xerbla(char* current_rout, int expected_info){ - if (link_xerbla) /* call these first to link */ - F77_xerbla(rout, &_info); + if (!handler_installed) { + openblas_set_xerbla(test_xerbla); + handler_installed = TRUE; + } ok = TRUE; lerr = TRUE;