From: Gabor Melis <mega@hotpop.com>
Date: Thu, 5 Feb 2009 09:56:46 +0000 (+0000)
Subject: 1.0.25.9: INVOKE-WITH-SAVED-FP-AND-PC changes
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3cbc1e7cfb59875d7ebec4af3c7c744cab0b76ae;p=sbcl.git

1.0.25.9: INVOKE-WITH-SAVED-FP-AND-PC changes

On x86/x86-64 we stash away the fp and the pc when calling an alien
function in order to allow the debugger to get back at the lisp frames
even if the alien frames confuse the frame parsing heuristics.

This commit optimizes INVOKE-WITH-SAVED-FP-AND-PC to cancel much of
the slowdown caused by 1.0.21.32 and it makes its use conditional on
(<= speed debug).
---

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index b23613e..8c53a73 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1215,7 +1215,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%ASSOC-TEST"
                "%ASSOC-TEST-NOT"
                "%ASIN" "%ASINH"
-               "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC"
+               "%ATAN" "%ATAN2" "%ATANH"
+               "%CALLER-FRAME"
+               "%CALLER-PC"
                "%CHECK-BOUND"
                "%CHECK-GENERIC-SEQUENCE-BOUNDS"
                "%CHECK-VECTOR-SEQUENCE-BOUNDS"
diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 61cf456..5ec3f41 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -662,8 +662,9 @@
 ;;; this function.
 (defun top-frame ()
   (/noshow0 "entering TOP-FRAME")
-  (multiple-value-bind (fp pc) (%caller-frame-and-pc)
-    (compute-calling-frame (descriptor-sap fp) pc nil)))
+  (compute-calling-frame (descriptor-sap (%caller-frame))
+                         (descriptor-sap (%caller-pc))
+                         nil))
 
 ;;; Flush all of the frames above FRAME, and renumber all the frames
 ;;; below FRAME.
@@ -677,7 +678,9 @@
 (defun find-saved-frame-down (fp up-frame)
   (multiple-value-bind (saved-fp saved-pc) (sb!c:find-saved-fp-and-pc fp)
     (when saved-fp
-      (compute-calling-frame (descriptor-sap saved-fp) saved-pc up-frame))))
+      (compute-calling-frame (descriptor-sap saved-fp)
+                             (descriptor-sap saved-pc)
+                             up-frame))))
 
 ;;; Return the frame immediately below FRAME on the stack; or when
 ;;; FRAME is the bottom of the stack, return NIL.
diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp
index c2c35c2..c4ffb50 100644
--- a/src/code/stubs.lisp
+++ b/src/code/stubs.lisp
@@ -15,7 +15,8 @@
 
 (macrolet ((def (name &optional (args '(x)))
              `(defun ,name ,args (,name ,@args))))
-  (def %caller-frame-and-pc ())
+  (def %caller-frame ())
+  (def %caller-pc ())
   (def %code-code-size)
   (def %code-debug-info)
   (def %code-entry-points)
diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 3635cb4..3ac88bb 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -621,14 +621,16 @@
 (declaim (inline invoke-with-saved-fp-and-pc))
 #!+:c-stack-is-control-stack
 (defun invoke-with-saved-fp-and-pc (fn)
-  (let* ((fp-and-pc (multiple-value-bind (fp pc)
-                        (%caller-frame-and-pc)
-                      (cons fp pc)))
-         (*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 fp-and-pc *saved-fp-and-pcs*))
-    (funcall fn)))
+  (declare #-sb-xc-host (muffle-conditions compiler-note)
+           (optimize (speed 3)))
+  (let* ((fp-and-pc (cons (%caller-frame)
+                          (sap-int (%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*)
@@ -640,7 +642,7 @@
              (int-sap (get-lisp-obj-address (car x))) fp)
         (return (values (car x) (cdr x)))))))
 
-(deftransform alien-funcall ((function &rest args) * * :important t)
+(deftransform alien-funcall ((function &rest args) * * :node node :important t)
   (let ((type (lvar-type function)))
     (unless (alien-type-type-p type)
       (give-up-ir1-transform "can't tell function type at compile time"))
@@ -698,7 +700,8 @@
             ;; to it later regardless of how the foreign stack looks
             ;; like.
             #!+:c-stack-is-control-stack
-            (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body)))
+            (when (policy node (<= speed debug))
+              (setf body `(invoke-with-saved-fp-and-pc (lambda () ,body))))
             (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
             `(lambda (function ,@(params))
                ,body)))))))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index e666a3d..a814990 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1453,7 +1453,8 @@
 (defknown hairy-data-vector-set/check-bounds (array index t)
   t
   (unsafe explicit-check))
-(defknown %caller-frame-and-pc () (values t t) (flushable))
+(defknown %caller-frame () t (flushable))
+(defknown %caller-pc () system-area-pointer (flushable))
 (defknown %with-array-data (array index (or index null))
   (values (simple-array * (*)) index index index)
   (foldable flushable))
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 78513e6..ea5e1d9 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1253,15 +1253,21 @@
   (values))
 
 ;;;; debugger hooks
+;;;;
+;;;; These are used by the debugger to find the top function on the
+;;;; stack. They return the OLD-FP and RETURN-PC for the current
+;;;; function as multiple values.
+
+(defoptimizer (%caller-frame ir2-convert) (() node block)
+  (let ((ir2-physenv (physenv-info (node-physenv node))))
+    (move-lvar-result node block
+                      (list (ir2-physenv-old-fp ir2-physenv))
+                      (node-lvar node))))
 
-;;; This is used by the debugger to find the top function on the
-;;; stack. It returns the OLD-FP and RETURN-PC for the current
-;;; function as multiple values.
-(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
+(defoptimizer (%caller-pc ir2-convert) (() node block)
   (let ((ir2-physenv (physenv-info (node-physenv node))))
     (move-lvar-result node block
-                      (list (ir2-physenv-old-fp ir2-physenv)
-                            (ir2-physenv-return-pc ir2-physenv))
+                      (list (ir2-physenv-return-pc ir2-physenv))
                       (node-lvar node))))
 
 ;;;; multiple values
diff --git a/version.lisp-expr b/version.lisp-expr
index 01d5805..32e3e65 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.25.8"
+"1.0.25.9"