phynexis-deps/lapack
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

CBLAS: use the shared XERBLA helper in the xerbla sources

Browse Source 
Switch cblas_xerbla(), F77_xerbla_base() and the test harness over to
cblas_xerbla_internal.h. Two diagnostic bugs go away with the duplicated
code:

  - the row-major remap keyed off strstr(rout, "gemm"), which also
    matches gemmtr and so wrongly swapped its arguments 4 and 5;

  - the six-character name buffer truncated cblas_sgemmtr and
    cblas_sskewsyr2k in the library, while the harness used an
    eleven-character buffer and did not, so the two disagreed about the
    same routine.

The Fortran entry points now take FCHAR and read the argument number
through F77_INT consistently, honour the hidden string length instead of
assuming six characters, and carry doxygen comments.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
This commit is contained in:
Simon Maertens
2026-07-28 21:35:14 +02:00
co-authored by Claude Opus 5
parent bfadf61f2f
commit e2fd85389f
3 changed files with 137 additions and 189 deletions
Download Patch File Download Diff File Expand all files Collapse all files
CBLAS/src/cblas_xerbla.c
+27 -57
View File
@@ -1,72 +1,42 @@
#include <stdarg.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include "cblas.h"
#include "cblas_f77.h"
#include "cblas_xerbla_internal.h"
void
#ifdef HAS_ATTRIBUTE_WEAK_SUPPORT
__attribute__((weak))
#endif
API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *rout, const char *form, ...)
/**
* \brief CBLAS error handler: report an invalid argument and terminate.
*
* Remaps \p info to the CBLAS argument position for row-major calls, writes
* the diagnostic to stderr and exits; it does not return to its caller.
*
* \param[in] info CBLAS argument number, or 0 to report only \p form.
* \param[in] rout Routine name, e.g. "cblas_dgemm".
* \param[in] form printf-style format for further detail, followed by the
* values it refers to.
*/
void CBLAS_WEAK_SYMBOL API_SUFFIX(cblas_xerbla)(CBLAS_INT info,
const char *rout,
const char *form, ...)
{
extern int RowMajorStrg;
char empty[1] = "";
va_list argptr;
va_start(argptr, form);
if (RowMajorStrg)
{
if (strstr(rout,"gemm") != 0)
{
if (info == 5 ) info = 4;
else if (info == 4 ) info = 5;
else if (info == 11) info = 9;
else if (info == 9 ) info = 11;
}
else if (strstr(rout,"symm") != 0 || strstr(rout,"hemm") != 0)
{
if (info == 5 ) info = 4;
else if (info == 4 ) info = 5;
}
else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0)
{
if (info == 7 ) info = 6;
else if (info == 6 ) info = 7;
}
else if (strstr(rout,"gemv") != 0)
{
if (info == 4) info = 3;
else if (info == 3) info = 4;
}
else if (strstr(rout,"gbmv") != 0)
{
if (info == 4) info = 3;
else if (info == 3) info = 4;
else if (info == 6) info = 5;
else if (info == 5) info = 6;
}
else if (strstr(rout,"ger") != 0)
{
if (info == 3) info = 2;
else if (info == 2) info = 3;
else if (info == 8) info = 6;
else if (info == 6) info = 8;
}
else if ( (strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0)
&& strstr(rout,"her2k") == 0 )
{
if (info == 8) info = 6;
else if (info == 6) info = 8;
}
info = cblas_xerbla_map_info(info, rout, RowMajorStrg);
if (info) {
fprintf(stderr, "Parameter %" CBLAS_IFMT " to routine %s was incorrect\n",
info, rout);
}
if (info)
fprintf(stderr, "Parameter %" CBLAS_IFMT " to routine %s was incorrect\n", info, rout);
va_list argptr;
va_start(argptr, form);
vfprintf(stderr, form, argptr);
va_end(argptr);
if (info && !info)
if (info && !info) {
F77_xerbla(empty, &info); /* Force link of our F77 error handler */
}
exit(-1);
}
CBLAS/src/xerbla.c
+47 -36
View File
@@ -1,50 +1,61 @@
#include <stdio.h>
#include <ctype.h>
#include "cblas.h"
#include "cblas_f77.h"
#include "cblas_xerbla_internal.h"
#define XerblaStrLen 6
#define XerblaStrLen1 7
void
#ifdef HAS_ATTRIBUTE_WEAK_SUPPORT
__attribute__((weak))
#endif
F77_xerbla_base
#ifdef F77_CHAR
(F77_CHAR F77_srname, void *vinfo
#else
(char *srname, void *vinfo
#endif
/**
* \brief XERBLA implementation linked in together with the CBLAS library.
*
* An error raised beneath a CBLAS wrapper is forwarded to cblas_xerbla()
* under the CBLAS spelling of the routine name, with the argument number
* shifted by one to account for the extra layout argument. Errors from
* direct Fortran calls are reported under the Fortran name instead.
*
* \param[in] F77_srname Routine name reported by the Fortran BLAS, blank
* padded and not NUL terminated.
* \param[in] vinfo Pointer to the Fortran argument number.
* \param[in] len Hidden Fortran length of \p F77_srname, on
* compilers that pass string lengths at the end of
* the argument list.
*/
void CBLAS_WEAK_SYMBOL F77_xerbla_base(FCHAR F77_srname, void *vinfo
#ifdef BLAS_FORTRAN_STRLEN_END
, FORTRAN_STRLEN len
,
FORTRAN_STRLEN len
#endif
)
{
#ifdef F77_CHAR
char *srname;
#endif
char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0'};
int *info=vinfo;
int i;
extern int CBLAS_CallFromC;
#ifdef F77_CHAR
srname = F2C_STR(F77_srname, XerblaStrLen);
size_t srname_len;
#ifdef BLAS_FORTRAN_STRLEN_END
srname_len = len > 0 ? (size_t)len : 0;
#else
srname_len = 6;
#endif
if (CBLAS_CallFromC)
{
for(i=0; i != XerblaStrLen; i++) rout[i+6] = tolower(srname[i]);
rout[XerblaStrLen+6] = '\0';
API_SUFFIX(cblas_xerbla)(*info+1,rout,"");
}
else
{
fprintf(stderr, "Parameter %d to routine %s was incorrect\n",
*info, srname);
char *srname;
#ifdef F77_CHAR
srname = F2C_STR(F77_srname, srname_len);
#else
srname = F77_srname;
#endif
F77_INT *info = (F77_INT *)vinfo;
CBLAS_INT cblas_info = (CBLAS_INT)*info;
if (CBLAS_CallFromC) {
char rout[CBLAS_XERBLA_ROUT_BUFFER_SIZE];
cblas_xerbla_make_rout(rout, sizeof(rout), srname, srname_len);
API_SUFFIX(cblas_xerbla)(cblas_info + 1, rout, "");
} else {
size_t display_len = cblas_xerbla_trimmed_length(srname, srname_len);
fprintf(stderr, "Parameter %" CBLAS_IFMT " to routine ", cblas_info);
if (display_len > 0) {
fwrite(srname, 1, display_len, stderr);
}
fputs(" was incorrect\n", stderr);
}
}
CBLAS/testing/c_xerbla.c
+63 -96
View File
@@ -1,16 +1,32 @@
#include <stdio.h>
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <string.h>
#include "cblas.h"
#include "cblas_test.h"
#include "cblas_xerbla_internal.h"
void API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *rout, const char *form, ...)
/**
* \brief Test-harness stand-in for the CBLAS error handler.
*
* Rather than terminating, checks the reported routine name and argument
* number against the values the calling tester put in cblas_rout and
* cblas_info, and records the outcome in cblas_ok and cblas_lerr.
*
* \param[in] info CBLAS argument number reported by the caller.
* \param[in] rout Routine name, e.g. "cblas_dgemm".
* \param[in] form Unused; kept so the signature matches the library's.
*/
void API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *rout,
const char *form, ...)
{
extern CBLAS_INT cblas_lerr, cblas_info, cblas_ok;
extern CBLAS_INT link_xerbla;
extern char *cblas_rout;
(void)form;
/* Initially, c__3chke may 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
@@ -18,120 +34,71 @@ void API_SUFFIX(cblas_xerbla)(CBLAS_INT info, const char *rout, const char *form
*/
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);
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;
}
if (RowMajorStrg)
{
/* To properly check leading dimension problems in cblas__gemm, we
* need to do the following trick. When cblas__gemm is called with
* CblasRowMajor, the arguments A and B switch places in the call to
* f77__gemm. Thus when we test for bad leading dimension problems
* for A and B, lda is in position 11 instead of 9, and ldb is in
* position 9 instead of 11.
*/
if (strstr(rout,"gemm") != 0 && strstr(rout, "gemmtr") == 0)
{
if (info == 5 ) info = 4;
else if (info == 4 ) info = 5;
else if (info == 11) info = 9;
else if (info == 9 ) info = 11;
} else if (strstr(rout, "gemmtr") != 0)
{
if (info == 11) info = 9;
else if (info == 9 ) info = 11;
}
info = cblas_xerbla_map_info(info, rout, RowMajorStrg);
else if (strstr(rout,"symm") != 0 || strstr(rout,"skewsymm") != 0 || strstr(rout,"hemm") != 0)
{
if (info == 5 ) info = 4;
else if (info == 4 ) info = 5;
}
else if (strstr(rout,"trmm") != 0 || strstr(rout,"trsm") != 0)
{
if (info == 7 ) info = 6;
else if (info == 6 ) info = 7;
}
else if (strstr(rout,"gemv") != 0)
{
if (info == 4) info = 3;
else if (info == 3) info = 4;
}
else if (strstr(rout,"gbmv") != 0)
{
if (info == 4) info = 3;
else if (info == 3) info = 4;
else if (info == 6) info = 5;
else if (info == 5) info = 6;
}
else if (strstr(rout,"ger") != 0)
{
if (info == 3) info = 2;
else if (info == 2) info = 3;
else if (info == 8) info = 6;
else if (info == 6) info = 8;
}
else if ( ( strstr(rout,"her2") != 0 || strstr(rout,"hpr2") != 0 )
&& strstr(rout,"her2k") == 0 )
{
if (info == 8) info = 6;
else if (info == 6) info = 8;
}
}
if (info != cblas_info){
printf("***** XERBLA WAS CALLED WITH INFO = %" CBLAS_IFMT " INSTEAD OF %d in %s *******\n",info, (int) cblas_info, rout);
if (info != cblas_info) {
printf("***** XERBLA WAS CALLED WITH INFO = %" CBLAS_IFMT
" INSTEAD OF %d in %s *******\n",
info, (int)cblas_info, rout);
cblas_lerr = PASSED;
cblas_ok = FALSE;
} else cblas_lerr = FAILED;
} 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
/**
* \brief Test-harness XERBLA that redirects Fortran errors to cblas_xerbla().
*
* \param[in] F77_srname Routine name reported by the Fortran BLAS, blank
* padded and not NUL terminated.
* \param[in] vinfo Pointer to the Fortran argument number.
* \param[in] len Hidden Fortran length of \p F77_srname, on
* compilers that pass string lengths at the end.
*/
void F77_xerbla(FCHAR F77_srname, void *vinfo
#ifdef BLAS_FORTRAN_STRLEN_END
, FORTRAN_STRLEN srname_len
,
FORTRAN_STRLEN len
#endif
)
{
#ifdef F77_Char
char *srname;
#endif
char rout[] = {'c','b','l','a','s','_','\0','\0','\0','\0','\0','\0','\0', '\0', '\0', '\0', '\0', '\0'};
#ifdef F77_Integer
F77_Integer *info=vinfo;
F77_Integer i;
extern F77_Integer link_xerbla;
#else
CBLAS_INT *info=vinfo;
CBLAS_INT i;
extern CBLAS_INT link_xerbla;
#endif
#ifdef F77_Char
srname = F2C_STR(F77_srname, XerblaStrLen);
#endif
/* See the comment in API_SUFFIX(cblas_xerbla)() above */
if (link_xerbla)
{
extern CBLAS_INT link_xerbla;
if (link_xerbla) {
link_xerbla = 0;
return;
}
#ifndef BLAS_FORTRAN_STRLEN_END
const int srname_len = 6;
size_t srname_len;
#ifdef BLAS_FORTRAN_STRLEN_END
srname_len = len > 0 ? (size_t)len : 0;
#else
srname_len = 6;
#endif
for(i=0; i < srname_len; i++) rout[i+6] = tolower(srname[i]);
for(i=16; i >= 9; i--) if (rout[i] == ' ') rout[i] = '\0';
char *srname;
#ifdef F77_CHAR
srname = F2C_STR(F77_srname, srname_len);
#else
srname = F77_srname;
#endif
F77_INT *info = (F77_INT *)vinfo;
CBLAS_INT cblas_info = (CBLAS_INT)*info;
char rout[CBLAS_XERBLA_ROUT_BUFFER_SIZE];
cblas_xerbla_make_rout(rout, sizeof(rout), srname, srname_len);
/* We increment *info by 1 since the CBLAS interface adds one more
* argument to all level 2 and 3 routines.
*/
API_SUFFIX(cblas_xerbla)(*info+1,rout,"");
API_SUFFIX(cblas_xerbla)(cblas_info + 1, rout, "");
}