Allow inlining more calls to INVOKE-WITH-SAVED-FP-AND-PC during XC.

[sbcl.git] / src / code / early-alieneval.lisp

diff --git a/src/code/early-alieneval.lisp b/src/code/early-alieneval.lisp
index 8043bbd..206baa4 100644 (file)
--- a/src/code/early-alieneval.lisp
+++ b/src/code/early-alieneval.lisp
@@ -28,3 +28,33 @@
 (defvar *values-type-okay* nil)
 
 (defvar *default-c-string-external-format* nil)
+
+;;; Frame pointer, program counter conses. In each thread it's bound
+;;; locally or not bound at all.
+(defvar *saved-fp-and-pcs*)
+
+#!+:c-stack-is-control-stack
+(declaim (inline invoke-with-saved-fp-and-pc))
+#!+:c-stack-is-control-stack
+(defun invoke-with-saved-fp-and-pc (fn)
+  (declare #-sb-xc-host (muffle-conditions compiler-note)
+           (optimize (speed 3)))
+  (let* ((fp-and-pc (cons (sb!kernel:%caller-frame)
+                          (sap-int (sb!kernel:%caller-pc)))))
+    (declare (truly-dynamic-extent fp-and-pc))
+    (let ((*saved-fp-and-pcs* (if (boundp '*saved-fp-and-pcs*)
+                                  (cons fp-and-pc *saved-fp-and-pcs*)
+                                  (list fp-and-pc))))
+      (declare (truly-dynamic-extent *saved-fp-and-pcs*))
+      (funcall fn))))
+
+(defun find-saved-fp-and-pc (fp)
+  (when (boundp '*saved-fp-and-pcs*)
+    (dolist (x *saved-fp-and-pcs*)
+      (when (#!+:stack-grows-downward-not-upward
+             sap>
+             #!-:stack-grows-downward-not-upward
+             sap<
+             (int-sap (get-lisp-obj-address (car x))) fp)
+        (return (values (car x) (cdr x)))))))
+