Improvements to xerbla functionality

The following improvements have been implemented:
- Option to stop in xerbla on error. This is controlled by
  setting the environment variable BLIS_STOP_ON_ERROR=1
- Option to disable printing of error message from BLIS. This
  is controlled by setting the environment variable
  BLIS_PRINT_ON_ERROR=0
- Added a function to return the value of INFO passed to xerbla,
  assuming xerbla was not set to stop on error. Example call is

     info = bli_info_get_info_value();

The default behaviour remains to print but don't stop on error,
i.e. the equivalent to

     export BLIS_PRINT_ON_ERROR=1 BLIS_STOP_ON_ERROR=0

Implementation details:
- Values of the environment variables are stored and retrieved
  from global_rntm.
- Info value is stored and retrieved from tl_rntm. It is set
  to 0 during initialization for all calls and updated by xerbla
  if an error has occurred.
- Call to bli_init_auto before calling PASTEBLACHK macro (which
  calls xerbla) will reinitialize info_value to 0 via call to
  bli_thread_update_rntm_from_env

AMD-Internal: [CPUPL-3520]
Change-Id: I151f6de9b5a437c3a6e3fcf453d5b8fa9c579b9d

frame/base/bli_info.c

@@ -5,7 +5,7 @@
    libraries.
 
    Copyright (C) 2014, The University of Texas at Austin
-   Copyright (C) 2018 - 2022, Advanced Micro Devices, Inc. All rights reserved.
+   Copyright (C) 2018 - 2023, Advanced Micro Devices, Inc. All rights reserved.
 
    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions are
@@ -35,6 +35,9 @@
 
 #include "blis.h"
 
+// Make thread settings local to each thread calling BLIS routines.
+// (The definition resides in bli_rntm.c.)
+extern BLIS_THREAD_LOCAL rntm_t tl_rntm;
 
 // -- General library information ----------------------------------------------
 
@@ -157,6 +160,11 @@ gint_t bli_info_get_enable_sandbox( void )
 #endif
 }
 
+// -- Error code produced from within xerbla (if called), otherwise 0
+gint_t bli_info_get_info_value( void )
+{
+	return tl_rntm.info_value;
+}
 
 
 // -- Kernel implementation-related --------------------------------------------

frame/base/bli_info.h

@@ -5,7 +5,7 @@
    libraries.
 
    Copyright (C) 2014, The University of Texas at Austin
-   Copyright (C) 2018 - 2019, Advanced Micro Devices, Inc.
+   Copyright (C) 2018 - 2023, Advanced Micro Devices, Inc. All rights reserved.
 
    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions are
@@ -75,6 +75,8 @@ BLIS_EXPORT_BLIS gint_t bli_info_get_thread_part_jrir_rr( void );
 BLIS_EXPORT_BLIS gint_t bli_info_get_enable_memkind( void );
 BLIS_EXPORT_BLIS gint_t bli_info_get_enable_sandbox( void );
 
+// -- Get value of info from within xerbla (if called), otherwise 0 returned
+BLIS_EXPORT_BLIS gint_t bli_info_get_info_value( void );
 
 // -- Kernel implementation-related --------------------------------------------
 

frame/base/bli_rntm.c

@@ -37,7 +37,7 @@
 
 // The global rntm_t structure, which holds the global thread settings
 // along with a few other key parameters.
-rntm_t global_rntm;
+rntm_t global_rntm = BLIS_RNTM_INITIALIZER;
 
 // Make thread settings local to each thread calling BLIS routines
 BLIS_THREAD_LOCAL rntm_t tl_rntm = BLIS_RNTM_INITIALIZER;

frame/base/bli_rntm.h

@@ -225,6 +225,21 @@ BLIS_INLINE dim_t bli_rntm_equals( rntm_t* rntm1, rntm_t* rntm2 )
 }
 #endif
 
+BLIS_INLINE bool bli_rntm_stop_on_error( rntm_t* rntm )
+{
+	return rntm->stop_on_error;
+}
+
+BLIS_INLINE bool bli_rntm_print_on_error( rntm_t* rntm )
+{
+	return rntm->print_on_error;
+}
+
+BLIS_INLINE gint_t bli_rntm_info_value( rntm_t* rntm )
+{
+	return rntm->info_value;
+}
+
 //
 // -- rntm_t modification (internal use only) ----------------------------------
 //
@@ -312,6 +327,21 @@ BLIS_INLINE void bli_rntm_clear_pba( rntm_t* rntm )
 	bli_rntm_set_pba( NULL, rntm );
 }
 
+BLIS_INLINE void bli_rntm_set_stop_on_error_only( bool stop_on_error, rntm_t* rntm )
+{
+	rntm->stop_on_error = stop_on_error;
+}
+
+BLIS_INLINE void bli_rntm_set_print_on_error_only( bool print_on_error, rntm_t* rntm )
+{
+	rntm->print_on_error = print_on_error;
+}
+
+BLIS_INLINE void bli_rntm_set_info_value_only( gint_t info_value, rntm_t* rntm )
+{
+	rntm->info_value = info_value;
+}
+
 //
 // -- rntm_t modification (public API) -----------------------------------------
 //
@@ -422,7 +452,10 @@ BLIS_INLINE void bli_rntm_clear_l3_sup( rntm_t* rntm )
           .blis_mt     = FALSE, \
           .sba_pool    = NULL, \
           .pba         = NULL, \
-        }  \
+          .stop_on_error  = FALSE, \
+          .print_on_error = TRUE, \
+          .info_value     = 0, \
+        }
 
 BLIS_INLINE void bli_rntm_init( rntm_t* rntm )
 {

frame/compat/bla_gemv_amd.c

@@ -54,8 +54,6 @@ void PASTEF77S(ch,blasname) \
              ftype*    y, const f77_int* incy  \
      ) \
 { \
-    AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1); \
-    AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, *MKSTR(ch), *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy); \
     trans_t blis_transa; \
     dim_t   m0, n0; \
     dim_t   m_y, n_x; \
@@ -64,6 +62,9 @@ void PASTEF77S(ch,blasname) \
     inc_t   incx0; \
     inc_t   incy0; \
     inc_t   rs_a, cs_a; \
+\
+    AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1); \
+    AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, *MKSTR(ch), *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy); \
 \
     /* Initialize BLIS. */ \
     bli_init_auto(); \
@@ -186,6 +187,9 @@ void dgemv_blis_impl
     AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1);
     AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, 'D', *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy);
 
+    /* Initialize BLIS. */
+    bli_init_auto();
+
     /* Perform BLAS parameter checking. */
     PASTEBLACHK(gemv)
     (
@@ -386,6 +390,10 @@ void sgemv_blis_impl
 
     AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1);
     AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, 'S', *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy);
+
+    /* Initialize BLIS. */
+    bli_init_auto();
+
     /* Perform BLAS parameter checking. */
     PASTEBLACHK(gemv)
     (
@@ -570,9 +578,6 @@ void cgemv_blis_impl
              scomplex* y, const f77_int* incy
      )
 {
-    AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1);
-    AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, 'C', *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy);
-
     trans_t    blis_transa;
     dim_t      m0, n0;
     dim_t      m_y, n_x;
@@ -582,6 +587,12 @@ void cgemv_blis_impl
     inc_t      incy0;
     inc_t      rs_a, cs_a;
 
+    AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1);
+    AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, 'C', *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy);
+
+    /* Initialize BLIS. */
+    bli_init_auto();
+
     /* Perform BLAS parameter checking. */
     PASTEBLACHK(gemv)
     (
@@ -808,9 +819,6 @@ void zgemv_blis_impl
              dcomplex* y, const f77_int* incy
      )
 {
-    AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1);
-    AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, 'Z', *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy);
-
     trans_t    blis_transa;
     dim_t      m0, n0;
     dim_t      m_y, n_x;
@@ -820,6 +828,12 @@ void zgemv_blis_impl
     inc_t      incy0;
     inc_t      rs_a, cs_a;
 
+    AOCL_DTL_TRACE_ENTRY(AOCL_DTL_LEVEL_TRACE_1);
+    AOCL_DTL_LOG_GEMV_INPUTS(AOCL_DTL_LEVEL_TRACE_1, 'Z', *transa, *m, *n, (void*)alpha, *lda, *incx, (void*)beta, *incy);
+
+    /* Initialize BLIS. */
+    bli_init_auto();
+
     /* Perform BLAS parameter checking. */
     PASTEBLACHK(gemv)
     (

frame/compat/blis/thread/b77_thread.c

@@ -91,3 +91,14 @@ void PASTEF770(bli_thread_set_num_threads)
 	//bli_finalize_auto();
 }
 
+f77_int PASTEF770(bli_info_get_info_value)
+     (
+     )
+{
+	// Call the BLIS function.
+	gint_t info_value = bli_info_get_info_value();
+	f77_int f77_info_value = (f77_int) info_value;
+
+	return f77_info_value;
+}
+

frame/compat/blis/thread/b77_thread.h

@@ -51,3 +51,7 @@ BLIS_EXPORT_BLAS void PASTEF770(bli_thread_set_num_threads)
        const f77_int* nt
      );
 
+BLIS_EXPORT_BLAS f77_int PASTEF770(bli_info_get_info_value)
+     (
+     );
+

frame/compat/f2c/bla_xerbla.c

@@ -35,6 +35,13 @@
 
 #include "blis.h"
 
+// The global rntm_t structure. (The definition resides in bli_rntm.c.)
+extern rntm_t global_rntm;
+
+// Make thread settings local to each thread calling BLIS routines.
+// (The definition resides in bli_rntm.c.)
+extern BLIS_THREAD_LOCAL rntm_t tl_rntm;
+
 /* xerbla.f -- translated by f2c (version 19991025).
    You must link the resulting object file with the libraries:
 	-lf2c -lm   (in that order)
@@ -76,10 +83,25 @@
     //for ( i = 0; i < srname_len; ++i )
     //    srname[i] = toupper( srname[i] );
 
-    printf("** On entry to %6s, parameter number %2i had an illegal value\n",
+    // Make sure rntm variables are initialized.
-        srname, (int)*info);
+    bli_init_once();
 
-    //bli_abort();
+    // Store info value in thread-local rntm data structure.
+    gint_t info_value = (gint_t) *info;
+    bli_rntm_set_info_value_only( info_value, &tl_rntm );
+
+    bool print_on_error = bli_rntm_print_on_error( &global_rntm );
+    if (print_on_error)
+    {
+        printf("** On entry to %6s, parameter number %2i had an illegal value\n",
+            srname, (int)*info);
+    }
+
+    bool stop_on_error = bli_rntm_stop_on_error( &global_rntm );
+    if (stop_on_error)
+    {
+        bli_abort();
+    }
 
 /*     End of XERBLA */
 

frame/include/bli_type_defs.h

@@ -1534,6 +1534,12 @@ typedef struct rntm_s
 	// The packing block allocator, which is attached in the l3 thread decorator.
 	pba_t*    pba;
 
+	// Store values of environment variables to control BLIS version of xerbla
+	// and error code from xerbla
+	bool      stop_on_error;
+	bool      print_on_error;
+	gint_t    info_value;
+
 } rntm_t;
 
 

frame/thread/bli_thread.c

@@ -1853,6 +1853,35 @@ void bli_thread_init_rntm_from_env
 
 #endif // BLIS_ENABLE_MULTITHREADING
 
+	// Check environment for options to control xerbla
+
+	// Default: Don't stop on error
+	gint_t bli_stop_on_error_int  = bli_env_get_var( "BLIS_STOP_ON_ERROR", 0 );
+	bool bli_stop_on_error;
+
+	if ( bli_stop_on_error_int != 0 )
+	{
+		bli_stop_on_error = TRUE;
+	}
+	else
+	{
+		bli_stop_on_error = FALSE;
+	}
+	bli_rntm_set_stop_on_error_only(bli_stop_on_error, rntm);
+
+	// Default: print on error
+	gint_t bli_print_on_error_int = bli_env_get_var( "BLIS_PRINT_ON_ERROR", 1 );
+	bool bli_print_on_error;
+	if (bli_print_on_error_int  != 0 )
+        {
+		bli_print_on_error = TRUE;
+	}
+	else
+        {
+		bli_print_on_error = FALSE;
+	}
+	bli_rntm_set_print_on_error_only(bli_print_on_error, rntm);
+
 	// Save the results back in the runtime object.
 	bli_rntm_set_auto_factor_only( auto_factor, rntm );
 	bli_rntm_set_num_threads_only( nt, rntm );
@@ -2025,6 +2054,10 @@ void bli_thread_update_rntm_from_env
 	bli_rntm_set_ways_only( jc, pc, ic, jr, ir, rntm );
 	bli_rntm_set_blis_mt_only( blis_mt, rntm );
 
+	// Initialize info_value to 0
+	gint_t info_value = 0;
+	bli_rntm_set_info_value_only( info_value, rntm );
+
 #ifdef PRINT_THREADING
 	printf( "bli_thread_update_rntm_from_env(): tl_rntm\n" );
 	bli_rntm_print( rntm );