master: Sketch out a way to trace/intercept foreign calls

The branch "master" has been updated in SBCL:
       via  f3d711cd2af700a1ed9b22570987e7ccf94885bc (commit)
      from  9deb748799125a1ee6c4feee6bfa22ddd2b035cc (commit)

- Log -----------------------------------------------------------------
commit f3d711cd2af700a1ed9b22570987e7ccf94885bc
Author: Douglas Katzman <[email protected]>
Date:   Fri Jun 5 12:50:13 2026 -0400

    Sketch out a way to trace/intercept foreign calls
---
 src/code/alien-callback.lisp | 27 +++++++++++++++++++++++++++
 tests/callback.impure.lisp   | 21 +++++++++++++++++++++
 2 files changed, 48 insertions(+)

diff --git a/src/code/alien-callback.lisp b/src/code/alien-callback.lisp
index 1c04c7110..b55b1d695 100644
--- a/src/code/alien-callback.lisp
+++ b/src/code/alien-callback.lisp
@@ -354,6 +354,33 @@ function value."
                         (make-alien-pointer-type))
           (cast (alien-callable-function lisp-name) (* t)))))
 
+;;; Changing the entry point of an alien linkage table entry allows testing without
+;;; the foreign library, or mocking of foreign routines. This is more powerful than
+;;; encapsulatig a function defined via DEFINE-ALIEN-ROUTINE because it catches uses
+;;; from bare (ALIEN-FUNCALL (EXTERN-ALIEN "f" ...)) and WITH-ALIEN.
+;;; Note also that a nonexistent foreign function can be "overridden".
+#+(or arm64 x86-64)
+(progn
+;; Not officially part of SB-ALIEN: interface, but need to protect from tree-shaker.
+(export 'sb-alien-internals::override-alien-linkage-entrypoint 'sb-alien-internals)
+(defun sb-alien-internals::override-alien-linkage-entrypoint (c-name new-value)
+  (let* ((linkage-index (sb-impl::ensure-alien-linkage-index c-name nil))
+         (new-jump-address
+          (etypecase new-value
+            (string (int-sap (find-foreign-symbol-address new-value)))
+            (symbol (alien-sap (gethash new-value sb-alien::*alien-callables*)))
+            (integer (int-sap new-value))))
+         (address-of-jump-address
+          #+arm64 (sap+ (int-sap (sb-vm::alien-linkage-index-to-addr linkage-index nil)) 8)
+          #+x86-64
+          ;; Access the linkage index as if data, even though it's a function- this computes
+          ;; the address of the word in the linkage space which needs to get overwritten.
+          ;; Computing as a function would get the immutable address within the space.
+          (int-sap (sb-vm::alien-linkage-index-to-addr linkage-index t))) ; datap = T
+         (original-jump-address (sap-ref-word address-of-jump-address 0)))
+    (setf (sap-ref-sap address-of-jump-address 0) new-jump-address)
+    (cons address-of-jump-address original-jump-address))))
+
 (in-package "SB-THREAD")
 #+sb-thread
 (defun enter-foreign-callback (index return arguments)
diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp
index 5df538a39..3289e1947 100644
--- a/tests/callback.impure.lisp
+++ b/tests/callback.impure.lisp
@@ -491,3 +491,24 @@
           (setq sap (alien-sap callable)))
         (assert (sb-sys:sap= sap (alien-sap callable)))
         (assert (= (alien-funcall callable 1 2) (+ 3 i)))))))
+
+#+(or (and linux arm64) x86-64)
+(progn
+(defvar *got-arg*)
+(define-alien-callable intercepted-tan double ((x double))
+  (setf *got-arg* x)
+  ;; we'd have to do something to get the actual underlying function.
+  ;; For purposes of this test, just return anything.
+  42.0d0)
+(with-test (:name :trace-foreign-call)
+  (let (restorer result)
+    (unwind-protect
+         (progn
+           (setq restorer
+                 (sb-alien-internals:override-alien-linkage-entrypoint
+                  "tan" 'intercepted-tan))
+           (setq result (tan (opaque-identity 0d0))))
+      (setf (sb-sys:sap-ref-word (car restorer) 0) (cdr restorer)))
+    (assert (eql *got-arg* 0d0))
+    (assert (= result 42.0d0))
+    (assert (eql (tan 0d0) 0d0))))) ; back to normal

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL