Catch fatal SBCL errors

.github/workflows/linux.yml

@@ -23,6 +23,7 @@ jobs:
       env:
         SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger
       run: |
+        git apply ../sbcl-librarian/.github/workflows/non-static-lossage-handler.patch
         ./make.sh  --xc-host='sbcl --dynamic-space-size 700MB --lose-on-corruption --disable-ldb --disable-debugger'
         ./make-shared-library.sh
     - name: install quicklisp
@@ -45,4 +46,4 @@ jobs:
         sudo cp libcalc.core /usr/local/lib
         echo "(+ 1 2)" | ./example | tr -d '\n' | grep "> 3> "
         echo "(+ 1 2)" | python ./example.py | tr -d '\n' | grep "> 3> "
-   
+        python ./exhaust_heap.py | grep "returned to Python with error code 2 after heap exhaustion"

.github/workflows/mac.yml

@@ -26,6 +26,7 @@ jobs:
       env:  
         SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger
       run: |
+        git apply ../sbcl-librarian/.github/workflows/non-static-lossage-handler.patch
         ./make.sh --xc-host='sbcl --lose-on-corruption --disable-ldb --disable-debugger'
         ./make-shared-library.sh
     - name: install quicklisp
@@ -46,4 +47,5 @@ jobs:
         gcc -Wall -o example example.c -lcalc -lsbcl
         echo "(+ 1 2)" | ./example | tr -d '\n' | grep "> 3> "
         echo "(+ 1 2)" | python3 ./example.py | tr -d '\n' | grep "> 3> "
+        python3 ./exhaust_heap.py | grep "returned to Python with error code 2 after heap exhaustion"
    

.github/workflows/non-static-lossage-handler-win32.patch

@@ -0,0 +1,13 @@
+diff --git a/src/runtime/interr.c b/src/runtime/interr.c
+index 921765171..8da2c6b82 100644
+--- a/src/runtime/interr.c
++++ b/src/runtime/interr.c
+@@ -51,7 +51,7 @@ default_lossage_handler(void)
+     }
+     exit(1);
+ }
+-static void (*lossage_handler)(void) = default_lossage_handler;
++void (*lossage_handler)(void) = default_lossage_handler;
+
+ #ifdef LISP_FEATURE_WIN32
+ static void

.github/workflows/non-static-lossage-handler.patch

@@ -0,0 +1,13 @@
+diff --git a/src/runtime/interr.c b/src/runtime/interr.c
+index 521a8420a..320740f4a 100644
+--- a/src/runtime/interr.c
++++ b/src/runtime/interr.c
+@@ -51,7 +51,7 @@ default_lossage_handler(void)
+     }
+     exit(1);
+ }
+-static void (*lossage_handler)(void) = default_lossage_handler;
++void (*lossage_handler)(void) = default_lossage_handler;
+
+ #if QSHOW
+ static void

.github/workflows/windows.yml

@@ -20,7 +20,7 @@ jobs:
         path: sbcl
     - uses: msys2/setup-msys2@v2
       with:
-        install: mingw-w64-x86_64-gcc make diffutils git python3
+        install: mingw-w64-x86_64-gcc make diffutils git python dos2unix
 
     - name: install host sbcl
       shell: pwsh
@@ -34,6 +34,8 @@ jobs:
       run: |
         PATH=$PATH:"/c/Program Files/Steel Bank Common Lisp/1.4.14"
         export PATH
+        dos2unix ../sbcl-librarian/.github/workflows/non-static-lossage-handler-win32.patch
+        git apply ../sbcl-librarian/.github/workflows/non-static-lossage-handler-win32.patch
         ./make.sh --xc-host='sbcl --lose-on-corruption --disable-ldb --disable-debugger' --with-sb-linkable-runtime
     - name: install quicklisp
       working-directory: ../sbcl
@@ -54,3 +56,4 @@ jobs:
         cp libcalc.core $MSYSTEM_PREFIX/bin
         echo "(+ 1 2)" | ./example.exe | tr -d '\r\n' | grep "> 3> "
         echo "(+ 1 2)" | python ./example.py | tr -d '\r\n' | grep "> 3> "
+        python ./exhaust_heap.py | grep "returned to Python with error code 2 after heap exhaustion"

examples/libcalc/bindings.lisp

@@ -5,12 +5,18 @@
 (define-handle-type expr-type "expr_type")
 (define-enum-type error-type "err_t"
   ("ERR_SUCCESS" 0)
-  ("ERR_FAIL" 1))
-(define-error-map error-map error-type 0
+  ("ERR_FAIL" 1)
+  ("ERR_FATAL" 2))
+(define-error-map error-map error-type (:no-error 0 :fatal-error 2)
   ((t (lambda (condition)
         (declare (ignore condition))
         (return-from error-map 1)))))
 
+(defun exhaust-heap ()
+  (sb-sys:without-gcing
+    (let ((test '()))
+      (loop (push 1 test)))))
+
 (define-api libcalc-api (:error-map error-map
                          :function-prefix "calc_")
   (:literal "/* types */")
@@ -27,7 +33,8 @@
    (simplify expr-type ((expr expr-type)))
    (parse expr-type ((source :string)))
    (expression-to-string :string ((expr expr-type)))
-   (remove-zeros expr-type ((expr expr-type)))))
+   (remove-zeros expr-type ((expr expr-type)))
+   (exhaust-heap :void ())))
 
 (define-aggregate-library libcalc (:function-linkage "CALC_API")
   sbcl-librarian:handles sbcl-librarian:environment libcalc-api)

examples/libcalc/example.py

@@ -1,7 +1,8 @@
 from ctypes import *
-import libcalc
 import sys
 
+import libcalc
+
 def die(msg):
     print(msg)
     exit(1)

examples/libcalc/exhaust_heap.py

@@ -0,0 +1,10 @@
+import sys
+
+import py_over_so
+py_over_so.override_module("libcalc")
+import libcalc
+
+if __name__ == '__main__':
+    result = libcalc.calc_exhaust_heap()
+    if result == 2:
+        print("returned to Python with error code %d after heap exhaustion" % result)

examples/libcalc/py_over_so.py

@@ -0,0 +1,20 @@
+from importlib.abc import MetaPathFinder
+from importlib.util import spec_from_file_location
+import sys
+
+
+overridden_modules = []
+
+
+def override_module(name):
+    global overridden_modules
+    overridden_modules.append(name)
+
+
+class PyFinder(MetaPathFinder):
+    def find_spec(self, fullname, path, target=None):
+        if fullname in overridden_modules:
+            return spec_from_file_location(fullname, "./%s.py" % fullname)
+
+
+sys.meta_path.insert(0, PyFinder())

src/api.lisp

@@ -4,7 +4,9 @@
 
 (defgeneric error-map-type (error-map))
 
-(defmacro define-error-map (name error-type no-error bindings)
+(defgeneric error-map-fatal-code (error-map))
+
+(defmacro define-error-map (name error-type (&key no-error fatal-error) bindings)
   "Define an error map with the indicated NAME. 
 
 Error maps control how Lisp errors get translated to error codes at exported function boundaries. There are three pieces involved:
@@ -22,14 +24,46 @@ All Lisp calls will get wrapped in a block named NAME, within which a HANDLER-BI
      (defmethod error-map-type ((error-map (eql ',name)))
        ',error-type)
      (defmethod error-map-success-code ((error-map (eql ',name)))
-       ,no-error)))
+       ,no-error)
+     (defmethod error-map-fatal-code ((error-map (eql ',name)))
+       ,fatal-error)))
 
 (defun c-to-lisp-name (c-name)
   (nsubstitute #\- #\_ (string-upcase c-name)))
 
 (defun lisp-to-c-name (lisp-name)
   (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name))))
 
+(defun callable-name-with-c-prefix (callable-name prefix)
+  "Every alien callable function is associated with a callable name. A
+callable name is a two-element list: the first element is a string
+naming a C symbol, and the second element is a symbol naming a Lisp
+function. During runtime initialization, the memory address of the
+callable name's C symbol is populated with a pointer to a dynamically
+generated trampoline function wrapping the callable name's Lisp
+function.
+
+A callable name can also be referred to by one of its two elements
+alone, in which case the other element is implicitly defined by
+substituting underscores in the string for hyphens in the symbol, or
+vice versa.
+
+This function takes a callable name in any one of its three formats
+and returns a new callable name where the string naming the C symbol
+is prefixed by PREFIX, leaving the symbol naming the Lisp function unchanged.
+
+For example, if the prefix is \"_\":
+
+(\"foo_bar\" FOO-BAR) = \"foo_bar\" = FOO-BAR
+all become
+(\"_foo_bar\" FOO-BAR)"
+  (multiple-value-bind (c-name lisp-name)
+      (etypecase callable-name
+        (list (values (first callable-name) (second callable-name)))
+        (symbol (values (lisp-to-c-name callable-name) callable-name))
+        (string (values callable-name (c-to-lisp-name callable-name))))
+    (list (concatenate 'string prefix c-name) lisp-name)))
+
 (defun coerce-to-c-name (name)
   (typecase name
     (list (car name))

src/bindings.lisp

@@ -9,6 +9,11 @@
 (defparameter *elf-export-linkage*
   "__attribute__ ((visibility (\"default\")))")
 
+(defparameter *non-static-lossage-handler* nil
+  "NIL if SBCL was compiled with the lossage_handler function pointer
+marked as static, otherwise T. If this is NIL, the behavior of
+defining an error map with a non-nil FATAL-ERROR is undefined.")
+
 (defun write-linkage-macro (linkage build-name stream)
   (let ((windows "_WIN64")
         (elf "__ELF__"))
@@ -44,7 +49,7 @@
            (destructuring-bind (name result-type typed-lambda-list) spec
              (format stream "~A;~%"
                      (c-function-declaration name result-type typed-lambda-list
-                                             :datap t
+                                             :datap nil
                                              :linkage linkage
                                              :externp t
                                              :function-prefix (api-function-prefix api)
@@ -59,12 +64,16 @@
         (:function
          (dolist (spec things)
            (destructuring-bind (name result-type typed-lambda-list) spec
-             (format stream "~A;~%"
+             (format stream "~A;~%~A~%"
                      (c-function-declaration name result-type typed-lambda-list
                                              :datap t
                                              :externp nil
                                              :function-prefix (api-function-prefix api)
-                                             :error-map (api-error-map api))))))))))
+                                             :c-prefix "_"
+                                             :error-map (api-error-map api))
+                     (c-function-definition name result-type typed-lambda-list
+                                            :function-prefix (api-function-prefix api)
+                                            :error-map (api-error-map api))))))))))
 
 (defun write-init-function (name linkage stream &optional (initialize-lisp-args nil))
   (terpri stream)
@@ -80,6 +89,8 @@
   (format stream "  if (initialize_lisp(~a, init_args) != 0) return -1;~%"
           (+ 4 (length initialize-lisp-args)))
   (format stream "  initialized = 1;~%")
+  (when *non-static-lossage-handler*
+    (format stream "  lossage_handler = return_from_lisp;~%"))
   (format stream "  return 0; }"))
 
 (defun build-bindings (library directory &key (omit-init-function nil)
@@ -97,7 +108,7 @@
       (let ((guard (format nil "_~A_h" c-name)))       
         (format stream "#ifndef ~A~%" guard)
         (format stream "#define ~A~%~%" guard))
-      (when linkage        
+      (when linkage
         (write-linkage-macro linkage build-flag stream))
       (dolist (api (library-apis library))
         (write-api-to-header api linkage stream))
@@ -113,6 +124,21 @@
                             :if-exists :supersede)
       (format stream "#define ~A~%~%" build-flag)
       (format stream "#include ~s~%~%" header-name)
+      #-win32
+      (format stream "#include <setjmp.h>~%")
+      #+win32
+      (format stream "#include <stdint.h>~%")
+      (format stream "#include <stdio.h>~%~%")
+      #-win32
+      (format stream "__thread jmp_buf fatal_lisp_error_handler;~%~%")
+      #+win32
+      (format stream "__thread intptr_t fatal_lisp_error_handler[5];~%~%")
+      (when *non-static-lossage-handler*
+        (format stream "extern void (*lossage_handler)(void);~%~%"))
+      (format stream "extern void ldb_monitor(void);~%~%")
+      (format stream "int fatal_sbcl_error_occurred = 0;~%~%")
+      (format stream "void return_from_lisp(void) { fatal_sbcl_error_occurred = 1; fflush(stdout); fflush(stderr); ~a(fatal_lisp_error_handler, 1); }~%~%"
+              #-win32 "longjmp" #+win32 "__builtin_longjmp")
       (dolist (api (library-apis library))
         (write-api-to-source api stream))
       (unless omit-init-function

src/function.lisp

@@ -6,8 +6,10 @@
 
 (defun canonical-signature (name result-type typed-lambda-list &key
                                                                  (function-prefix "")
+                                                                 (c-prefix "")
                                                                  error-map)
-  (let* ((callable-name (prefix-name function-prefix name))
+  (let* ((callable-name (callable-name-with-c-prefix (prefix-name function-prefix name)
+                                                     c-prefix))
          (return-type
            (if error-map
                (error-map-type error-map)
@@ -24,11 +26,13 @@
                                &key (datap 't) (externp nil)
                                     (linkage nil)
                                     (function-prefix "")
-                                    error-map)
+                                    (c-prefix "")
+                                 error-map)
   (multiple-value-bind (callable-name return-type typed-lambda-list result-type)
       (canonical-signature name result-type typed-lambda-list
                            :function-prefix function-prefix
-                           :error-map error-map)    
+                           :c-prefix c-prefix
+                           :error-map error-map)
     (format nil "~:[~;extern ~]~@[~a ~]~a ~:[~a~;(*~a)~](~{~a~^, ~})"
             externp
             linkage
@@ -44,6 +48,58 @@
              (and result-type
                   (list (format nil "~a *result" (c-type result-type))))))))
 
+(defun c-function-definition (name result-type typed-lambda-list
+                              &key (function-prefix "")
+                                error-map)
+  "Returns a string constituting a C definition for a function called
+NAME that implements the function declaration produced by calling
+C-FUNCTION-DECLARATION on the provided arguments. The function body
+forwards the function arguments to a call to a function pointer with
+the same name as the function, except with a leading underscore.
+
+The call to the function pointer is wrapped as follows:
+
+if (!setjmp(fatal_lisp_error_handler)) {
+    // function pointer call
+} else {
+    return FATAL_ERROR_CODE;  // or ldb_monitor();, which
+                              // drops into LDB, if ERROR-MAP does not
+                              // have a FATAL-ERROR
+}
+
+If *NON-STATIC-LOSSAGE-HANDLER* is non-NIL, then the lossage_handler
+function pointer in the runtime is set to a thunk that calls
+longjmp(fatal_lisp_error_handler), ensuring that control returns to
+this function after a fatal SBCL error. If
+*NON-STATIC-LOSSAGE-HANDLER* is NIL, then a fatal SBCL error will
+cause a normal crash and not return control to this function."
+  (let ((header (c-function-declaration name result-type typed-lambda-list
+                                        :datap nil :externp nil :linkage nil
+                                        :function-prefix function-prefix :error-map error-map)))
+    (multiple-value-bind (callable-name return-type typed-lambda-list result-type)
+        (canonical-signature name result-type typed-lambda-list
+                             :function-prefix function-prefix
+                             :error-map error-map)
+      (declare (ignore return-type))
+      (let ((call-statement (format nil "return ~a(~{~a~^, ~});"
+                                    (concatenate 'string "_" (coerce-to-c-name callable-name))
+                                    (append
+                                     (mapcar (lambda (item)
+                                               (lisp-to-c-name (first item)))
+                                             typed-lambda-list)
+                                     (and result-type
+                                          (list "result"))))))
+        (format nil "~a {~%~a~%}~%"
+                header
+                (format nil "    if (!~a(fatal_lisp_error_handler)) {
+        ~a
+    } else {
+        ~a
+    }" #-win32 "setjmp" #+win32 "__builtin_setjmp"
+       call-statement (if (and error-map (error-map-fatal-code error-map))
+                          (format nil "return ~d;" (error-map-fatal-code error-map))
+                          (format nil "ldb_monitor();"))))))))
+
 (defun callable-definition (name result-type typed-lambda-list &key
                                                                  (function-prefix "")
                                                                  error-map)
@@ -62,7 +118,7 @@
                              :error-map error-map)
       `(progn
          (sb-alien:define-alien-callable
-             ,callable-name
+             ,(callable-name-with-c-prefix callable-name "_")
              ,(sb-alien-type return-type)
              (,@(loop :for (arg type) :in typed-lambda-list
                       :collect (list arg (sb-alien-type type)))
@@ -80,4 +136,4 @@
                     (wrap-error-handling result error-map)
                     result))))
          (when *initialize-callables-p*
-           (sb-alien::initialize-alien-callable-symbol ',callable-name))))))
+           (sb-alien::initialize-alien-callable-symbol ',(callable-name-with-c-prefix callable-name "_")))))))