From 8351107b855137b0fd24e8695f63a7e445be1c9d Mon Sep 17 00:00:00 2001 From: Charles Zhang Date: Sun, 9 Feb 2025 17:35:11 +0100 Subject: [PATCH] Inline alien callback Lisp wrappers. * Declare ENTER-ALIEN-CALLBACK as unsafe. * Instead of trying to share the Lisp from alien type parsing code for all callbacks with the same type signature, just inline the wrapper code directly into the body of the Lisp function. This simplifies how callbacks are handled and allows us to remove the Lisp trampoline layer as well, thereby reducing some call indirection overhead. Another benefit is that the declared types of the arguments are available to the compiler now that the type parsing code and the actual function body are in the same function, allowing the compiler to use unboxed arithmetic for addition when the arguments are both declared sb-alien:INT for example. * We dispose of the ALIEN-CALLBACK macro which associates a callback entry point directly to an existing Lisp function. This functionality was not exported and people don't seem to use callbacks in this way. If the user wants a Lisp function that is associated with multiple differently typed callbacks, the user can do so manually by declaring a separate Lisp function and defining multiple alien callables calling it. It is better to allow the user the option of using unboxed arithmetic than to default to allowing differently typed callbacks for the same function. * The desire to share these Lisp wrappers may have been due to space concerns, but generally speaking other kinds of argument and result coercion code is typically inlined and furthermore the type parsing code resides in GC-managed space, so it's okay that the code now exists per alien callable instead of per type signature. It's actually more of a concern that assembler wrappers are allocated per alien callable in uncollected static space. * A micro-benchmark with an alien-funcall of a callback that adds two numbers shows a 5-10% improvement in speed, presumably due to losing a layer of indirection. * Update the internals manual entry accordingly, noting in passing how foreign threads are handled specially. --- doc/internals/foreign-linkage.texinfo | 22 +-- src/code/alien-callback.lisp | 221 +++++++++++--------------- tests/alien.impure.lisp | 4 +- tests/callback.impure.lisp | 52 +++--- 4 files changed, 129 insertions(+), 170 deletions(-) diff --git a/doc/internals/foreign-linkage.texinfo b/doc/internals/foreign-linkage.texinfo index a15b45dfc..30ae372d4 100644 --- a/doc/internals/foreign-linkage.texinfo +++ b/doc/internals/foreign-linkage.texinfo @@ -118,7 +118,7 @@ SBCL is capable of providing C with linkage to Lisp -- the upshot of which is th C-functions can call Lisp functions thru what look like function pointers to C. These ``function pointers'' are called Alien Callbacks. An alien -callback sequence has 4 parts / stages / bounces: +callback sequence has 2 parts / stages / bounces: @itemize @item Assembler Wrapper @@ -136,22 +136,9 @@ The Assembler Wrapper is generated by @item #'ENTER-ALIEN-CALLBACK -pulls the Lisp Trampoline for the given index, and calls it with the +pulls the Lisp function for the given index, and calls it with the argument and result pointers. -@item Lisp Trampoline - -calls the Lisp Wrapper with the argument and result pointers, and the -function designator for the callback. There is one lisp trampoline per -callback. - -@item Lisp Wrapper - -parses the arguments from stack, calls the actual callback with the -arguments, and saves the return value at the result pointer. The lisp -wrapper is shared between all the callbacks having the same same -alien-fun-type. - @end itemize [1] As assembler wrappers need to be allocated in static addresses and @@ -162,3 +149,8 @@ appropriate assembler wrapper. The assembler wrapper could then be shared between all the callbacks with the same alien-fun-type. This would amortize most of the static allocation costs between multiple callbacks. + +When a foreign thread (i.e. a native thread created by foreign code +which doesn't yet have a Lisp thread structure associated with it) calls +a callback, the Lisp runtime must associate a Lisp thread structure to +it before entering Lisp. diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp index 66f847b5f..3281992e5 100644 --- a/src/code/alien-callback.lisp +++ b/src/code/alien-callback.lisp @@ -12,12 +12,9 @@ (in-package "SB-ALIEN") -;;; ALIEN-CALLBACK is supposed to be external in SB-ALIEN-INTERNALS, -;;; but the export gets lost (as this is now a warm-loaded file), and -;;; then 'chill' gets a conflict with SB-ALIEN over it. +;;; These are supposed to be external in SB-ALIEN, but the export gets +;;; lost (as this is now a warm-loaded file). (eval-when (:compile-toplevel :load-toplevel :execute) - (export (intern "ALIEN-CALLBACK" "SB-ALIEN-INTERNALS") - "SB-ALIEN-INTERNALS") (export (intern "DEFINE-ALIEN-CALLABLE" "SB-ALIEN") "SB-ALIEN") (export (intern "ALIEN-CALLABLE-FUNCTION" "SB-ALIEN") @@ -27,50 +24,35 @@ ;;;; ;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual. -(defvar *alien-callback-info* nil - "Maps SAPs to corresponding CALLBACK-INFO structures: contains all the -information we need to manipulate callbacks after their creation. Used for -changing the lisp-side function they point to, invalidation, etc.") +(define-load-time-global *alien-callback-saps* + (make-array 32 :fill-pointer 0 :adjustable t + :initial-element nil) + "An array of all callback SAPs indexed by their order of creation.") -(defstruct (callback-info - (:predicate nil) - (:copier nil)) - (specifier nil :read-only t) - function ; NULL if invalid - (wrapper nil :read-only t) - index) +(defun alien-callback-index (alien) + (position (alien-sap alien) *alien-callback-saps* :test #'sap=)) -(defun callback-info-key (info) - (cons (callback-info-specifier info) (callback-info-function info))) - -(defun alien-callback-info (alien) - (cdr (assoc (alien-sap alien) *alien-callback-info* :test #'sap=))) - -(define-load-time-global *alien-callbacks* (make-hash-table :test #'equal) - "Cache of existing callback SAPs, indexed with (SPECIFER . FUNCTION). Used for -memoization: we don't create new callbacks if one pointing to the correct -function with the same specifier already exists.") - -(define-load-time-global *alien-callback-wrappers* (make-hash-table :test #'equal) - "Cache of existing lisp wrappers, indexed with SPECIFER. Used for memoization: -we don't create new wrappers if one for the same specifier already exists.") +(define-load-time-global *alien-callbacks* (make-hash-table :test #'eq) + "Cache of existing callback SAPs, indexed by FUNCTION. Used for +memoization: we don't create new callbacks if one pointing to the same +function already exists.") (defun invalid-alien-callback (&rest arguments) (declare (ignore arguments)) (error "Invalid alien callback called.")) -(define-load-time-global *alien-callback-trampolines* +(define-load-time-global *alien-callback-functions* (make-array 32 :fill-pointer 0 :adjustable t :initial-element #'invalid-alien-callback) - "Lisp trampoline store: assembler wrappers contain indexes to this, and -ENTER-ALIEN-CALLBACK pulls the corresponding trampoline out and calls it.") + "Lisp function store: assembler wrappers contain indexes to this, and +ENTER-ALIEN-CALLBACK pulls the corresponding function out and calls it.") -(defun %alien-callback-sap (specifier result-type argument-types function wrapper +(defun %alien-callback-sap (result-type argument-types function &optional call-type) (declare #-x86 (ignore call-type)) (ensure-gethash - (list specifier function) *alien-callbacks* - (let* ((index (fill-pointer *alien-callback-trampolines*)) + function *alien-callbacks* + (let* ((index (fill-pointer *alien-callback-functions*)) ;; Aside from the INDEX this is known at ;; compile-time, which could be utilized by ;; having the two-stage assembler tramp & @@ -89,32 +71,17 @@ ENTER-ALIEN-CALLBACK pulls the corresponding trampoline out and calls it.") argument-types)) 8) 0)))) - (vector-push-extend - (alien-callback-lisp-trampoline wrapper function) - *alien-callback-trampolines*) + (vector-push-extend function *alien-callback-functions*) ;; Assembler-wrapper is static, so sap-taking is safe. (let ((sap (vector-sap assembler-wrapper))) - (push (cons sap (make-callback-info :specifier specifier - :function function - :wrapper wrapper - :index index)) - *alien-callback-info*) + (vector-push-extend sap *alien-callback-saps*) sap)))) -(defun alien-callback-lisp-trampoline (wrapper function) - (declare (function wrapper) (optimize speed)) - (lambda (args-pointer result-pointer) - (funcall wrapper args-pointer result-pointer function))) - -(defun alien-callback-lisp-wrapper-lambda (specifier result-type argument-types env) - (let* ((arguments (make-gensym-list (length argument-types))) - (argument-names arguments) - (argument-specs (cddr specifier))) - `(lambda (args-pointer result-pointer function) - ;; KLUDGE: the SAP shouldn't be consed but they are, don't - ;; bother anyone about that sad fact - (declare (muffle-conditions compiler-note) - (optimize speed)) +(defun alien-callback-lambda-expression (specifier arguments body result-type env) + (let ((argument-names arguments) + (argument-specs (cddr specifier))) + `(lambda (args-pointer result-pointer) + (declare (optimize speed)) (let ((args-sap (descriptor-sap args-pointer)) (res-sap (descriptor-sap result-pointer))) (declare (ignorable args-sap res-sap)) @@ -136,30 +103,31 @@ ENTER-ALIEN-CALLBACK pulls the corresponding trampoline out and calls it.") do (incf offset (+ (alien-callback-argument-bytes spec env) (or alignment 0)))) ,(flet ((store (spec real-type) - (if spec - `(setf (deref (sap-alien res-sap (* ,spec))) - ,(if real-type - `(the ,real-type - (funcall function ,@arguments)) - `(funcall function ,@arguments))) - `(funcall function ,@arguments)))) - (cond ((alien-void-type-p result-type) - (store nil nil)) - ((alien-integer-type-p result-type) - ;; Integer types should be padded out to a full - ;; register width, to comply with most ABI calling - ;; conventions, but should be typechecked on the - ;; declared type width, hence the following: - (if (alien-integer-type-signed result-type) - (store `(signed - ,(alien-type-word-aligned-bits result-type)) - `(signed-byte ,(alien-type-bits result-type))) - (store - `(unsigned - ,(alien-type-word-aligned-bits result-type)) - `(unsigned-byte ,(alien-type-bits result-type))))) - (t - (store (unparse-alien-type result-type) nil)))))) + (if spec + `(setf (deref (sap-alien res-sap (* ,spec))) + ,(if real-type + `(the ,real-type + (progn + ,@body)) + `(progn ,@body))) + `(progn ,@body)))) + (cond ((alien-void-type-p result-type) + (store nil nil)) + ((alien-integer-type-p result-type) + ;; Integer types should be padded out to a full + ;; register width, to comply with most ABI calling + ;; conventions, but should be typechecked on the + ;; declared type width, hence the following: + (if (alien-integer-type-signed result-type) + (store `(signed + ,(alien-type-word-aligned-bits result-type)) + `(signed-byte ,(alien-type-bits result-type))) + (store + `(unsigned + ,(alien-type-word-aligned-bits result-type)) + `(unsigned-byte ,(alien-type-bits result-type))))) + (t + (store (unparse-alien-type result-type) nil)))))) (values)))) (defun parse-callback-specification (result-type lambda-list) @@ -196,76 +164,54 @@ ENTER-ALIEN-CALLBACK pulls the corresponding trampoline out and calls it.") (error "Unsupported callback argument type: ~A" type)))) (defun enter-alien-callback (index arguments return) + (declare (optimize (safety 0) speed)) (funcall (truly-the function - (svref (sb-kernel:%array-data *alien-callback-trampolines*) + (svref (sb-kernel:%array-data *alien-callback-functions*) index)) arguments return)) ;;;; interface (not public, yet) for alien callbacks -(defmacro alien-callback (specifier function &environment env) - "Returns an alien-value of alien ftype SPECIFIER, that can be passed to -an alien function as a pointer to the FUNCTION. If a callback for the given -SPECIFIER and FUNCTION already exists, it is returned instead of consing a new -one." - ;; Pull out as much work as is convenient to macro-expansion time, specifically - ;; everything that can be done given just the SPECIFIER and ENV. - (multiple-value-bind (result-type argument-types call-type) - (parse-alien-ftype specifier env) - `(%sap-alien - (%alien-callback-sap ',specifier ',result-type ',argument-types - ,function - (ensure-gethash - ',specifier *alien-callback-wrappers* - ,(alien-callback-lisp-wrapper-lambda - specifier result-type argument-types env)) - ,call-type) - ',(parse-alien-type specifier env)))) - (defun alien-callback-p (alien) "Returns true if the alien is associated with a lisp-side callback, and a secondary return value of true if the callback is still valid." - (let ((info (alien-callback-info alien))) - (when info - (values t (and (callback-info-function info) t))))) + (let ((index (alien-callback-index alien))) + (when index + (values t (not (eq (aref *alien-callback-functions* index) + #'invalid-alien-callback)))))) (defun alien-callback-function (alien) - "Returns the lisp function designator associated with the callback." - (let ((info (alien-callback-info alien))) - (when info - (callback-info-function info)))) + "Returns the Lisp function associated with the callback." + (let ((index (alien-callback-index alien))) + (when index + (aref *alien-callback-functions* index)))) (defun (setf alien-callback-function) (function alien) - "Changes the lisp function designated by the callback." - (let ((info (alien-callback-info alien))) - (unless info + "Changes the Lisp function designated by the callback." + (let ((index (alien-callback-index alien))) + (unless index (error "Not an alien callback: ~S" alien)) ;; sap cache - (let ((key (callback-info-key info))) - (remhash key *alien-callbacks*) - (setf (gethash key *alien-callbacks*) (alien-sap alien))) - ;; trampoline - (setf (aref *alien-callback-trampolines* (callback-info-index info)) - (alien-callback-lisp-trampoline (callback-info-wrapper info) function)) - ;; metadata - (setf (callback-info-function info) function) + (let ((function (aref *alien-callback-functions* index))) + (remhash function *alien-callbacks*) + (setf (gethash function *alien-callbacks*) (alien-sap alien))) + (setf (aref *alien-callback-functions* index) function) function)) (defun invalidate-alien-callback (alien) "Invalidates the callback designated by the alien, if any, allowing the associated lisp function to be GC'd, and causing further calls to the same callback to signal an error." - (let ((info (alien-callback-info alien))) - (when (and info (callback-info-function info)) - ;; sap cache - (remhash (callback-info-key info) *alien-callbacks*) - ;; trampoline - (setf (aref *alien-callback-trampolines* (callback-info-index info)) - #'invalid-alien-callback) - ;; metadata - (setf (callback-info-function info) nil) - t))) + (let ((index (alien-callback-index alien))) + (when index + (let ((function (aref *alien-callback-functions* index))) + (unless (eq function #'invalid-alien-callback) + ;; sap cache + (remhash function *alien-callbacks*) + (setf (aref *alien-callback-functions* index) + #'invalid-alien-callback) + t))))) ;;; FIXME: This call assembles a new callback for every closure, ;;; which sucks hugely. ...not that I can think of an obvious @@ -274,10 +220,21 @@ callback to signal an error." ;;; ;;; For lambdas that result in simple-funs we get the callback from ;;; the cache on subsequent calls. -(defmacro alien-lambda (result-type typed-lambda-list &body forms) +(defmacro alien-lambda (result-type typed-lambda-list &body body + &environment env) (multiple-value-bind (specifier lambda-list) (parse-callback-specification result-type typed-lambda-list) - `(alien-callback ,specifier (lambda ,lambda-list ,@forms)))) + (multiple-value-bind (result-type argument-types call-type) + (parse-alien-ftype specifier env) + (let ((lambda-expression + (alien-callback-lambda-expression + specifier lambda-list + body result-type env))) + `(%sap-alien + (%alien-callback-sap ',result-type ',argument-types + ,lambda-expression + ,call-type) + ',(parse-alien-type specifier env)))))) ;;;; Alien callables diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index 750de563d..720734577 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -210,8 +210,8 @@ (* (function int)) unsigned-int unsigned-int unsigned-int unsigned-int)) (alien-sap - (sb-alien::alien-callback (function unsigned-int) - #'(lambda () (go up)))) + (sb-alien::alien-lambda unsigned-int () + (go up))) 0 0 0 0) up (funcall 0)) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 29e93c840..b45365161 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -22,11 +22,11 @@ ;;; simple callback for a function -(defun thunk () +(define-alien-callable thunk c-string () (write-string "hi")) (defvar *thunk* - (sb-alien::alien-callback (function c-string) #'thunk)) + (alien-callable-function 'thunk)) (with-test (:name (:callback :c-string) ;; The whole file is broken, report one test @@ -43,11 +43,11 @@ ;;; simple callback for a symbol -(defun add-two-ints (arg1 arg2) +(define-alien-callable add-two-ints int ((arg1 int) (arg2 int)) (+ arg1 arg2)) (defvar *add-two-ints* - (sb-alien::alien-callback (function int int int) 'add-two-ints)) + (alien-callable-function 'add-two-ints)) (assert (= (alien-funcall *add-two-ints* 555 444444) 444999)) @@ -135,10 +135,10 @@ ;;; tests for integer-width problems in callback result handling -(defvar *add-two-ints* - (sb-alien::alien-callback (function int int int) #'+)) +(define-alien-callable add-two-shorts short ((arg1 short) (arg2 short)) + (+ arg1 arg2)) (defvar *add-two-shorts* - (sb-alien::alien-callback (function short short short) #'+)) + (alien-callable-function 'add-two-shorts)) ;;; The original test cases here were what are now (:int-result ;;; :sign-extension) and (:int-result :underflow-detection), the latter @@ -161,19 +161,24 @@ ;;; tests for handling 64-bit arguments - this was causing problems on ;;; ppc - CLH, 2005-12-01 +(define-alien-callable add-two-long-longs (integer 64) + ((arg1 (integer 64)) (arg2 (integer 64))) + (+ arg1 arg2)) + (defvar *add-two-long-longs* - (sb-alien::alien-callback - (function (integer 64) (integer 64) (integer 64)) 'add-two-ints)) + (alien-callable-function 'add-two-long-longs)) (with-test (:name :long-long-callback-arg) (assert (= (alien-funcall *add-two-long-longs* (ash 1 60) (- (ash 1 59))) (ash 1 59)))) +(define-alien-callable add-two-unsigned-long-longs (unsigned 64) + ((arg1 (unsigned 64)) (arg2 (unsigned 64))) + (+ arg1 arg2)) + (defvar *add-two-unsigned-long-longs* - (sb-alien::alien-callback - (function (unsigned 64) (unsigned 64) (unsigned 64)) - 'add-two-ints)) + (alien-callable-function 'add-two-unsigned-long-longs)) (with-test (:name :unsigned-long-long-callback-arg) (assert (= (alien-funcall *add-two-unsigned-long-longs* (ash 1 62) @@ -212,17 +217,22 @@ collect (car (rassoc (string-downcase g) *type-abbreviations* :test #'equal))))) (defmacro define-callback-adder (&rest types) - (let ((fname (format nil "*add-~{~A~^-~}*" - (mapcar - #'(lambda (x) - (cdr (assoc x *type-abbreviations*))) + (let* ((fname (format nil "*add-~{~A~^-~}*" (mapcar - #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien)) - (cdr types)))))) + #'(lambda (x) + (cdr (assoc x *type-abbreviations*))) + (mapcar + #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien)) + (cdr types))))) + (arg-types (cdr types)) + (args (sb-int:make-gensym-list (length arg-types))) + (typed-lambda-list (mapcar (lambda (type arg) + (list arg type)) + arg-types args))) `(progn - (defparameter ,(intern - (string-upcase fname)) - (sb-alien::alien-callback (function ,@types) '+))))) + (defvar ,(intern (string-upcase fname)) + (sb-alien::alien-lambda ,(car types) ,typed-lambda-list + (+ ,@args)))))) (with-test (:name :define-2-int-callback) (define-callback-adder int int int))