Add LBT_FORCE_* environment variable overrides

This provides a flexible mechanism through which LBT's autodetection
facilities can be overridden.  It enables debugging strange behaviors
without needing to recompile LBT from scratch to disable a certain layer
of its behavior.

Author: staticfloat

src/Makefile

@@ -15,7 +15,7 @@ maintarget=$(word 1,$(TARGET_LIBRARIES))
 all: $(maintarget)
 
 # Objects we'll build
-MAIN_OBJS := libblastrampoline.o dl_utils.o config.o \
+MAIN_OBJS := libblastrampoline.o dl_utils.o env_utils.o config.o \
 			 autodetection.o \
 			 threading.o deepbindless.o trampolines/trampolines_$(ARCH).o
 

src/autodetection.c

@@ -96,6 +96,12 @@ const char * autodetect_symbol_suffix(void * handle, const char * suffix_hint) {
  * incorrect `N` to cause it to change its return value based on how it is interpreting arugments.
  */
 int32_t autodetect_blas_interface(void * isamax_addr) {
+    if (env_lowercase_match("LBT_FORCE_INTERFACE", "ilp64")) {
+        return LBT_INTERFACE_ILP64;
+    }
+    if (env_lowercase_match("LBT_FORCE_INTERFACE", "lp64")) {
+        return LBT_INTERFACE_LP64;
+    }
     // Typecast to function pointer for easier usage below
     int64_t (*isamax)(int64_t *, float *, int64_t *) = isamax_addr;
 
@@ -145,6 +151,12 @@ int32_t autodetect_blas_interface(void * isamax_addr) {
  * and determine if the internal pointer dereferences were 32-bit or 64-bit.
  */
 int32_t autodetect_lapack_interface(void * dpotrf_addr) {
+    if (env_lowercase_match("LBT_FORCE_INTERFACE", "ilp64")) {
+        return LBT_INTERFACE_ILP64;
+    }
+    if (env_lowercase_match("LBT_FORCE_INTERFACE", "lp64")) {
+        return LBT_INTERFACE_LP64;
+    }
     // Typecast to function pointer for easier usage below
     void (*dpotrf)(char *, int64_t *, double *, int64_t *, int64_t *) = dpotrf_addr;
 
@@ -196,6 +208,12 @@ int32_t autodetect_interface(void * handle, const char * suffix) {
 
 #ifdef COMPLEX_RETSTYLE_AUTODETECTION
 int32_t autodetect_complex_return_style(void * handle, const char * suffix) {
+    if (env_lowercase_match("LBT_FORCE_RETSTYLE", "normal")) {
+        return LBT_COMPLEX_RETSTYLE_NORMAL;
+    }
+    if (env_lowercase_match("LBT_FORCE_RETSTYLE", "argument")) {
+        return LBT_COMPLEX_RETSTYLE_ARGUMENT;
+    }
     char symbol_name[MAX_SYMBOL_LEN];
 
     build_symbol_name(symbol_name, "zdotc_", suffix);
@@ -241,6 +259,13 @@ int32_t autodetect_complex_return_style(void * handle, const char * suffix) {
 
 #ifdef F2C_AUTODETECTION
 int32_t autodetect_f2c(void * handle, const char * suffix) {
+    if (env_lowercase_match("LBT_FORCE_F2C", "plain")) {
+        return LBT_F2C_PLAIN;
+    }
+    if (env_lowercase_match("LBT_FORCE_F2C", "required")) {
+        return LBT_F2C_REQUIRED;
+    }
+
     char symbol_name[MAX_SYMBOL_LEN];
 
     // Attempt BLAS `sdot()` test
@@ -278,6 +303,13 @@ int32_t autodetect_f2c(void * handle, const char * suffix) {
 
 #ifdef CBLAS_DIVERGENCE_AUTODETECTION
 int32_t autodetect_cblas_divergence(void * handle, const char * suffix) {
+    if (env_lowercase_match("LBT_FORCE_CBLAS", "conformant")) {
+        return LBT_CBLAS_CONFORMANT;
+    }
+    if (env_lowercase_match("LBT_FORCE_CBLAS", "divergent")) {
+        return LBT_CBLAS_DIVERGENT;
+    }
+
     char symbol_name[MAX_SYMBOL_LEN];
 
     build_symbol_name(symbol_name, "zdotc_", suffix);

src/env_utils.c

@@ -0,0 +1,62 @@
+#include "libblastrampoline_internal.h"
+#include <ctype.h>
+
+const char * env_lowercase(const char * env_name) {
+    // Get environment value, if it's not set, return false
+    char * env_value = getenv(env_name);
+    if (env_value == NULL) {
+        return NULL;
+    }
+
+    // If it is set, convert to lowercase.
+    env_value = strdup(env_value);
+    for (size_t idx=0; idx<strlen(env_value); ++idx) {
+        env_value[idx] = tolower(env_value[idx]);
+    }
+    return env_value;
+}
+
+
+uint8_t env_lowercase_match(const char * env_name, const char * value) {
+    const char * env_value = env_lowercase(env_name);
+    if (env_value == NULL) {
+        return 0;
+    }
+
+    int ret = strcmp(env_value, value) == 0;
+    free((void *)env_value);
+    return ret;
+}
+
+uint8_t env_lowercase_match_any(const char * env_name, uint32_t num_values, ...) {
+    va_list args;
+    va_start(args, num_values);
+
+    // Get environment value
+    const char * env_value = env_lowercase(env_name);
+    if (env_value == NULL) {
+        return 0;
+    }
+
+    // Search through our varargs for a match
+    for (uint32_t idx=0; idx<num_values; idx++ ) {
+        const char *value = va_arg(args, const char *);
+        if (strcmp(env_value, value) == 0) {
+            free((void *)env_value);
+            return 1;
+        }
+    }
+    free((void *)env_value);
+    return 0;
+}
+
+// Check to see if `env_name` matches any "boolean"-like 
+uint8_t env_match_bool(const char * env_name, uint8_t default_value) {
+    if (env_lowercase_match_any(env_name, 3, "0", "false", "no")) {
+        return 0;
+    }
+    if (env_lowercase_match_any(env_name, 3, "1", "true", "yes")) {
+        return 1;
+    }
+    return default_value;
+}

src/libblastrampoline.c

@@ -416,10 +416,9 @@ __attribute__((constructor)) void init(void) {
     // Initialize config structures
     init_config();
 
-    // If LBT_VERBOSE == "1", the startup invocation should be verbose
+    // If LBT_VERBOSE is set, the startup invocation should be verbose
     int verbose = 0;
-    const char * verbose_str = getenv("LBT_VERBOSE");
-    if (verbose_str != NULL && strcmp(verbose_str, "1") == 0) {
+    if (env_match_bool("LBT_VERBOSE", 0)) {
         verbose = 1;
         printf("libblastrampoline initializing from %s\n", lookup_self_path());
     }
@@ -428,17 +427,15 @@ __attribute__((constructor)) void init(void) {
     // If LBT_USE_RTLD_DEEPBIND == "0", we avoid using RTLD_DEEPBIND on a
     // deepbind-capable system.  This is mostly useful for sanitizers, which
     // abhor such library loading shenanigans.
-    const char * deepbindless_str = getenv("LBT_USE_RTLD_DEEPBIND");
-    if (deepbindless_str != NULL && strcmp(deepbindless_str, "0") == 0) {
+    if (env_match_bool("LBT_USE_RTLD_DEEPBIND", 1)) {
         use_deepbind = 0x00;
         if (verbose) {
             printf("LBT_USE_RTLD_DEEPBIND=0 detected; avoiding usage of RTLD_DEEPBIND\n");
         }
     }
 #endif // !defined(LBT_DEEPBINDLESS)
 
-    const char * strict_str = getenv("LBT_STRICT");
-    if (strict_str != NULL && strcmp(strict_str, "1") == 0) {
+    if (env_match_bool("LBT_STRICT", 0)) {
         if (verbose) {
             printf("LBT_STRICT=1 detected; calling missing symbols will print an error, then exit\n");
         }

src/libblastrampoline_internal.h

@@ -2,6 +2,7 @@
 #include <stdint.h>
 #include <stdlib.h>
 #include <string.h>
+#include <stdarg.h>
 #include <unistd.h>
 
 // Load in our publicly-defined functions/types
@@ -75,6 +76,11 @@ void * lookup_self_symbol(const char * symbol_name);
 const char * lookup_self_path();
 void close_library(void * handle);
 
+// Functions in `env_utils.c`
+uint8_t env_lowercase_match(const char * env_name, const char * value);
+uint8_t env_lowercase_match_any(const char * env_name, uint32_t num_values, ...);
+uint8_t env_match_bool(const char * env_name, uint8_t default_value);
+
 // Functions in `autodetection.c`
 void build_symbol_name(char * out, const char *symbol_name, const char *suffix);
 const char * autodetect_symbol_suffix(void * handle, const char * suffix_hint);

test/isamax_test/Makefile

@@ -0,0 +1,15 @@
+include ../../src/Make.inc
+
+all: $(prefix)/isamax_test$(EXE)
+
+$(prefix):
+	@mkdir -p $@
+
+$(prefix)/isamax_test$(EXE): isamax_test.c | $(prefix)
+	@$(CC) -o $@ $(CFLAGS) $^ $(LDFLAGS)
+
+clean:
+	@rm -f $(prefix)/isamax_test$(EXE)
+
+run: $(prefix)/isamax_test$(EXE)
+	@$(prefix)/isamax_test$(EXE)

test/isamax_test/isamax_test.c

@@ -0,0 +1,16 @@
+#include <stdio.h>
+#include <stdint.h>
+
+extern int64_t isamax_64_(int64_t *, float *, int64_t *);
+
+#define N 4
+int main()
+{
+    int64_t n = 0xffffffff00000003;
+    float X[3] = {1.0f, 2.0f, 1.0f};
+    int64_t incx = 1;
+
+    int64_t max_idx = isamax_64_(&n, X, &incx);
+    printf("max_idx: %lld\n", max_idx);
+    return 0;
+}

test/runtests.jl

@@ -54,7 +54,7 @@ function run_test((test_name, test_expected_outputs, expect_success), libblas_na
         cmd = `$(dir)/$(test_name)`
         p, output = capture_output(addenv(cmd, env))
 
-        expected_return_value = success(p) ^ expect_success
+        expected_return_value = !xor(success(p), expect_success)
         if !expected_return_value
             @error("Test failed", env, p.exitcode, p.termsignal, expect_success)
             println(output)
@@ -63,7 +63,7 @@ function run_test((test_name, test_expected_outputs, expect_success), libblas_na
 
         # Expect to see the path to `libblastrampoline` within the output,
         # since we have `LBT_VERBOSE=1` and at startup, it announces its own path:
-        if startswith(libblas_name, "blastrampoline")
+        if startswith(libblas_name, "blastrampoline") && expect_success
             lbt_libdir = first(libdirs)
             @test occursin(lbt_libdir, output)
         end
@@ -131,12 +131,25 @@ lbt_dir = joinpath(lbt_dir, binlib)
 @testset "LBT -> OpenBLAS_jll ($(openblas_interface))" begin
     libdirs = unique(vcat(lbt_dir, OpenBLAS_jll.LIBPATH_list..., CompilerSupportLibraries_jll.LIBPATH_list...))
     run_all_tests(blastrampoline_link_name(), libdirs, openblas_interface, OpenBLAS_jll.libopenblas_path)
+
+    # Test that setting bad `LBT_FORCE_*` values actually breaks things
+    withenv("LBT_FORCE_RETSTYLE" => "ARGUMENT") do
+        zdotc_fail = ("zdotc_test", [], false)
+        run_test(zdotc_fail, blastrampoline_link_name(), libdirs, openblas_interface, OpenBLAS_jll.libopenblas_path)
+    end
 end
 
 # And again, but this time with OpenBLAS32_jll
 @testset "LBT -> OpenBLAS32_jll (LP64)" begin
     libdirs = unique(vcat(lbt_dir, OpenBLAS32_jll.LIBPATH_list..., CompilerSupportLibraries_jll.LIBPATH_list...))
     run_all_tests(blastrampoline_link_name(), libdirs, :LP64, OpenBLAS32_jll.libopenblas_path)
+
+    # Test that setting bad `LBT_FORCE_*` values actually breaks things
+    withenv("LBT_FORCE_INTERFACE" => "ILP64") do
+        # `max_idx: 2` is incorrect, it's what happens when ILP64 data is given to an LP64 backend
+        isamax_fail = ("isamax_test", ["max_idx: 2"], true)
+        run_test(isamax_fail, blastrampoline_link_name(), libdirs, :ILP64, OpenBLAS32_jll.libopenblas_path)
+    end
 end
 
 # Test against MKL_jll using `libmkl_rt`, which is :LP64 by default