Catch fatal SBCL errors

examples/libcalc/bindings.lisp

@@ -11,6 +11,11 @@
         (declare (ignore condition))
         (return-from error-map 1)))))
 
+(defun test-fatal-error ()
+  (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 +32,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)))
+   (test-fatal-error :void ())))
 
 (define-aggregate-library libcalc (:function-linkage "CALC_API")
   sbcl-librarian:handles sbcl-librarian:environment libcalc-api)

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,12 +49,13 @@
            (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)
                                              :error-map (api-error-map api))))))))))
 
+
 (defun write-api-to-source (api stream)
   (dolist (spec (api-specs api))
     (destructuring-bind (kind &rest things) spec
@@ -59,12 +65,15 @@
         (: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))))))))))
+                                             :function-prefix (concatenate 'string "_" (api-function-prefix api))
+                                             :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,13 @@
                             :if-exists :supersede)
       (format stream "#define ~A~%~%" build-flag)
       (format stream "#include ~s~%~%" header-name)
+      (format stream "#include <setjmp.h>~%~%")
+      (format stream "__thread jmp_buf fatal_lisp_error_handler;~%~%")
+      (when *non-static-lossage-handler*
+        (format stream "extern void (*lossage_handler)(void);~%~%"))
+      (format stream "extern void monitor_or_something(void);~%~%")
+      (format stream "void return_from_lisp(void) { fatal_sbcl_error_occurred = 1; longjmp(fatal_lisp_error_handler, 1); }~%~%")
+      (format stream "int fatal_sbcl_error_occurred = 0;~%~%")
       (dolist (api (library-apis library))
         (write-api-to-source api stream))
       (unless omit-init-function

src/function.lisp

@@ -28,7 +28,7 @@
   (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)    
+                           :error-map error-map)
     (format nil "~:[~;extern ~]~@[~a ~]~a ~:[~a~;(*~a)~](~{~a~^, ~})"
             externp
             linkage
@@ -44,6 +44,57 @@
              (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 monitor_or_something();, 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 (!setjmp(fatal_lisp_error_handler)) {
+        ~a
+    } else {
+        ~a
+    }" call-statement (if (and error-map (error-map-fatal-code error-map))
+                          (format nil "return ~d;" (error-map-fatal-code error-map))
+                          (format nil "monitor_or_something();"))))))))
+
 (defun callable-definition (name result-type typed-lambda-list &key
                                                                  (function-prefix "")
                                                                  error-map)
@@ -62,7 +113,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 +131,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)