diff --git a/.github/workflows/linux.yml b/.github/workflows/linux.yml index 2829783f..9eb94b33 100644 --- a/.github/workflows/linux.yml +++ b/.github/workflows/linux.yml @@ -12,7 +12,7 @@ jobs: - uses: actions/checkout@v1 with: repository: sbcl/sbcl - ref: sbcl-2.2.4 + ref: sbcl-2.4.5 path: sbcl - name: install host sbcl run: | @@ -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> " - \ 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..21682fab 100644 --- a/.github/workflows/mac.yml +++ b/.github/workflows/mac.yml @@ -17,7 +17,7 @@ jobs: - uses: actions/checkout@v1 with: repository: sbcl/sbcl - ref: ${{ matrix.arch == 'arm64' && 'sbcl-2.2.4' || 'x86-null-tn' }} + ref: ${{ matrix.arch == 'arm64' && 'sbcl-2.4.5' || 'x86-null-tn' }} path: sbcl - name: install host sbcl run: brew install sbcl @@ -46,4 +46,4 @@ 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> " - \ No newline at end of file + python3 ./exhaust_heap.py | grep "returned to Python with error code 2 after heap exhaustion" diff --git a/.github/workflows/windows.yml b/.github/workflows/windows.yml index afd58dd2..9739dbc7 100644 --- a/.github/workflows/windows.yml +++ b/.github/workflows/windows.yml @@ -16,7 +16,7 @@ jobs: - uses: actions/checkout@v1 with: repository: sbcl/sbcl - ref: sbcl-2.4.4 + ref: sbcl-2.4.5 path: sbcl - uses: msys2/setup-msys2@v2 with: @@ -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" 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/exhaust_heap.py b/examples/libcalc/exhaust_heap.py new file mode 100644 index 00000000..70db4ca5 --- /dev/null +++ b/examples/libcalc/exhaust_heap.py @@ -0,0 +1,10 @@ +import libcalc +import sys + + +if __name__ == '__main__': + result = libcalc.calc_exhaust_heap() + # Attempting to call into Lisp again should return the same error code + assert(libcalc.calc_exhaust_heap() == result) + if result == 2: + print("returned to Python with error code %d after heap exhaustion" % result) diff --git a/examples/libcalc/script.lisp b/examples/libcalc/script.lisp index f8062059..a7855cb1 100644 --- a/examples/libcalc/script.lisp +++ b/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)) 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..2697da4e 100644 --- a/src/bindings.lisp +++ b/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,10 @@ (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 + (when (sb-sys:find-foreign-symbol-address "set_lossage_handler") + (format stream " set_lossage_handler(return_from_lisp);~%")) (format stream " return 0; }")) (defun build-bindings (library directory &key (omit-init-function nil) @@ -97,7 +105,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 +121,25 @@ :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 ~%~%") + ;; 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];~%~%") + (when (sb-sys:find-foreign-symbol-address "set_lossage_handler") + (format stream "void set_lossage_handler(void (*handler)(void));~%")) + (format stream "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 diff --git a/src/function.lisp b/src/function.lisp index 969c5edf..98a44971 100644 --- a/src/function.lisp +++ b/src/function.lisp @@ -1,13 +1,27 @@ (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" + "The name of the function/macro/builtin that implements longjmp. See +the documentation for *longjmp-operator* for rationale.") + (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 +38,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 +60,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 (!fatal_sbcl_error_occurred && !~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 +127,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 +145,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))