Catch fatal SBCL errors

.github/workflows/linux.yml

@@ -45,4 +45,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

@@ -46,4 +46,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/windows.yml

@@ -54,3 +54,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/exhaust_heap.py

@@ -0,0 +1,8 @@
+import libcalc
+import sys
+
+
+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/script.lisp

@@ -7,10 +7,9 @@
 
 (in-package #:sbcl-librarian/example/libcalc)
 
-(let ((sbcl-librarian::*non-static-lossage-handler* t))
-  (build-bindings libcalc ".")
-  (build-python-bindings libcalc "." #+github-ci :library-path
-                                     #+(and github-ci win32) (concatenate 'string (uiop:getenv "MSYSTEM_PREFIX") "/bin/libcalc.dll")
-                                     #+(and github-ci linux) "/usr/local/lib/libcalc.so"
-                                     #+(and github-ci darwin) nil)
-  (build-core-and-die libcalc "." :compression nil))
+(build-bindings libcalc ".")
+(build-python-bindings libcalc "." #+github-ci :library-path
+			           #+(and github-ci win32) (concatenate 'string (uiop:getenv "MSYSTEM_PREFIX") "/bin/libcalc.dll")
+                                   #+(and github-ci linux) "/usr/local/lib/libcalc.so"
+                                   #+(and github-ci darwin) nil)
+(build-core-and-die libcalc "." :compression nil))

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

@@ -44,7 +44,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 +59,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 +84,9 @@
   (format stream "  if (initialize_lisp(~a, init_args) != 0) return -1;~%"
           (+ 4 (length initialize-lisp-args)))
   (format stream "  initialized = 1;~%")
+  ;; Set the lossage handler to a function that longjmps out of the
+  ;; most recent call-into-Lisp
+  (format stream "  set_lossage_handler(return_from_lisp);~%")
   (format stream "  return 0; }"))
 
 (defun build-bindings (library directory &key (omit-init-function nil)
@@ -97,7 +104,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 +120,24 @@
                             :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>~%~%")
+      ;; On Windows we use __builtin_setjmp and __builtin_longjmp (see
+      ;; the documentation for *longjmp-operator* for rationale) which
+      ;; use a jump buffer of type intptr_t[5] instead of jmp_buf (see
+      ;; https://gcc.gnu.org/onlinedocs/gcc/Nonlocal-Gotos.html).
+      #-win32
+      (format stream "__thread jmp_buf fatal_lisp_error_handler;~%~%")
+      #+win32
+      (format stream "__thread intptr_t fatal_lisp_error_handler[5];~%~%")
+      (format stream "extern void (*set_lossage_handler)(void (*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); }~%~%"
+              *longjmp-operator*)
       (dolist (api (library-apis library))
         (write-api-to-source api stream))
       (unless omit-init-function

src/function.lisp

@@ -1,13 +1,25 @@
 (in-package #:sbcl-librarian)
 
+(defparameter *longjmp-operator*
+  #-win32 "longjmp" #+win32 "__builtin_longjmp"
+  "The name of the function/macro/builtin that implements longjmp. Note
+that we use __builtin_longjmp on Windows because, unlike the longjmp
+provided by the UCRT, it does not perform stack unwinding, which does
+not work with Lisp stack frames.")
+
+(defparameter *setjmp-operator*
+  #-win32 "setjmp" #+win32 "__builtin_setjmp")
+
 (defvar *initialize-callables-p* nil
   "Bound to T when we are loading Lisp and want to reinitialize
   callables on load.")
 
 (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 +36,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 +58,55 @@
              (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
+}"
+  (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
+    }"
+                        *setjmp-operator*
+                        call-statement
+                        ;; If the error map does not have specify a
+                        ;; fatal error code, then drop into LDB.
+                        (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 +125,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 +143,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 "_")))))))

src/library.lisp

@@ -60,7 +60,7 @@ NOTE: Here, the APIs must already be defined elsewhere."
     (loop :for (kind . things) :in (api-specs api)
           :when (eq kind ':function)
             :append (mapcar (lambda (spec)
-                              (prefix-name (api-function-prefix api) (first spec)))
+                              (callable-name-with-c-prefix (prefix-name (api-function-prefix api) (first spec)) "_"))
                             things))))
 
 (defun build-core-and-die (library directory &key compression)

src/python-bindings.lisp

@@ -10,16 +10,23 @@
                            :function-prefix function-prefix
                            :error-map error-map)
     (format nil
-            "~a = CFUNCTYPE(~a, ~{~a~^, ~})(c_void_p.in_dll(~a, '~a').value)"
+            "~a = ~a.~a
+~a.restype = ~a
+~a.argtypes = [~{~a~^, ~}]"
+            ;; First line
+            (coerce-to-c-name callable-name)
+            library-name
+            (coerce-to-c-name callable-name)
+            ;; Second line
             (coerce-to-c-name callable-name)
             (python-type return-type)
+            ;; Third line
+            (coerce-to-c-name callable-name)
             (append
              (loop :for (name type) :in typed-lambda-list
                    :collect (python-type type))
              (and result-type
-                  (list (format nil "POINTER(~a)" (python-type result-type)))))
-            library-name
-            (coerce-to-c-name callable-name))))
+                  (list (format nil "POINTER(~a)" (python-type result-type))))))))
 
 (defun write-default-python-header (library stream &optional (omit-init-call nil)
                                                              (library-path nil))