From 30991abec73004b9af1dc160e2ee016fe2716851 Mon Sep 17 00:00:00 2001 From: Kartik Singh Date: Tue, 2 Apr 2024 12:03:08 -0700 Subject: [PATCH] Catch fatal SBCL errors --- examples/libcalc/bindings.lisp | 8 ++++- src/api.lisp | 38 +++++++++++++++++++++-- src/bindings.lisp | 28 ++++++++++++++--- src/function.lisp | 57 ++++++++++++++++++++++++++++++++-- src/library.lisp | 2 +- 5 files changed, 121 insertions(+), 12 deletions(-) diff --git a/examples/libcalc/bindings.lisp b/examples/libcalc/bindings.lisp index 8fcd8887..b286905f 100644 --- a/examples/libcalc/bindings.lisp +++ b/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) diff --git a/src/api.lisp b/src/api.lisp index a0b38bb5..6bdccd84 100644 --- a/src/api.lisp +++ b/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,7 +24,9 @@ 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))) @@ -30,6 +34,36 @@ All Lisp calls will get wrapped in a block named NAME, within which a HANDLER-BI (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)) diff --git a/src/bindings.lisp b/src/bindings.lisp index c576857f..22ab8c6b 100644 --- a/src/bindings.lisp +++ b/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 ~%~%") + (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 diff --git a/src/function.lisp b/src/function.lisp index 969c5edf..9c5241d0 100644 --- a/src/function.lisp +++ b/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 "_"))))))) diff --git a/src/library.lisp b/src/library.lisp index 694c6523..29261dfa 100644 --- a/src/library.lisp +++ b/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)