diff --git a/.github/workflows/linux.yml b/.github/workflows/linux.yml index 2829783f..d656279a 100644 --- a/.github/workflows/linux.yml +++ b/.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> " - \ No newline at end of file + python ./exhaust_heap.py | grep "returned to Python with error code 2 after heap exhaustion" diff --git a/.github/workflows/mac.yml b/.github/workflows/mac.yml index a0e5a45c..8183d870 100644 --- a/.github/workflows/mac.yml +++ b/.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" \ No newline at end of file diff --git a/.github/workflows/non-static-lossage-handler-win32.patch b/.github/workflows/non-static-lossage-handler-win32.patch new file mode 100644 index 00000000..d9498052 --- /dev/null +++ b/.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 diff --git a/.github/workflows/non-static-lossage-handler.patch b/.github/workflows/non-static-lossage-handler.patch new file mode 100644 index 00000000..261e982d --- /dev/null +++ b/.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 diff --git a/.github/workflows/windows.yml b/.github/workflows/windows.yml index afd58dd2..438406d7 100644 --- a/.github/workflows/windows.yml +++ b/.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" diff --git a/examples/libcalc/bindings.lisp b/examples/libcalc/bindings.lisp index 8fcd8887..5fe8ff42 100644 --- a/examples/libcalc/bindings.lisp +++ b/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) diff --git a/examples/libcalc/example.py b/examples/libcalc/example.py index dcbbedfa..94de0bfb 100644 --- a/examples/libcalc/example.py +++ b/examples/libcalc/example.py @@ -1,7 +1,8 @@ from ctypes import * -import libcalc import sys +import libcalc + def die(msg): print(msg) exit(1) diff --git a/examples/libcalc/exhaust_heap.py b/examples/libcalc/exhaust_heap.py new file mode 100644 index 00000000..0014dd7b --- /dev/null +++ b/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) diff --git a/examples/libcalc/py_over_so.py b/examples/libcalc/py_over_so.py new file mode 100644 index 00000000..e2aa9391 --- /dev/null +++ b/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()) 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..ad39dfd1 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,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 ~%") + #+win32 + (format stream "#include ~%") + (format stream "#include ~%~%") + #-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 diff --git a/src/function.lisp b/src/function.lisp index 969c5edf..e8019c6a 100644 --- a/src/function.lisp +++ b/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 "_"))))))) 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) diff --git a/src/python-bindings.lisp b/src/python-bindings.lisp index 97f18fa6..8881d7bf 100644 --- a/src/python-bindings.lisp +++ b/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))