1.0.21.32: hack around truncated backtraces with lost frames

On :C-STACK-IS-THE-CONTROL-STACK platforms when calling an alien
function stash the current frame pointer and return address away so
that no matter how the alien stack frames are laid out the debugger
can find its way back to lisp land.

diff --git a/NEWS b/NEWS
index 33888b7..cca4c0b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -47,6 +47,8 @@ changes in sbcl-1.0.22 relative to 1.0.21:
   * bug fix: using RESTRICT-COMPILER-POLICY with DEBUG 3 could cause
     PROGV miscompilation. (reported by Matthias Benkard, patch by Juho
     Snellman)
+  * bug fix: on x86 and x86-64 backtraces were sometimes truncated
+    after alien stack frames.
 
 changes in sbcl-1.0.21 relative to 1.0.20:
   * new feature: the compiler is able to track the effective type of a

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index c1643dd..af61be5 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -265,6 +265,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
                "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP"
                "PHYSENV-DEBUG-LIVE-TN" "PHYSENV-LIVE-TN"
                "FAST-SYMBOL-VALUE"
+               "FIND-SAVED-FP-AND-PC"
                "FIXUP-NOTE-KIND"
                "FIXUP-NOTE-FIXUP"
                "FIXUP-NOTE-POSITION"

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 26ca084..4b6be6d 100644 (file)
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -674,6 +674,11 @@
       ((not (frame-p frame)))
     (setf (frame-number frame) number)))
 
+(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))))
+
 ;;; Return the frame immediately below FRAME on the stack; or when
 ;;; FRAME is the bottom of the stack, return NIL.
 (defun frame-down (frame)
@@ -703,8 +708,9 @@
                      (when (control-stack-pointer-valid-p fp)
                        #!+(or x86 x86-64)
                        (multiple-value-bind (ok ra ofp) (x86-call-context fp)
-                         (and ok
-                              (compute-calling-frame ofp ra frame)))
+                         (if ok
+                             (compute-calling-frame ofp ra frame)
+                             (find-saved-frame-down fp frame)))
                        #!-(or x86 x86-64)
                        (compute-calling-frame
                         #!-alpha

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index c534ca0..bb7dbec 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -731,6 +731,7 @@ around and can be retrieved by JOIN-THREAD."
                    (*restart-clusters* nil)
                    (*handler-clusters* (sb!kernel::initial-handler-clusters))
                    (*condition-restarts* nil)
+                   (sb!c::*saved-fp-and-pcs* ())
                    (sb!impl::*deadline* nil)
                    (sb!impl::*step-out* nil)
                    ;; internal printer variables

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index eff524d..75dcf1b 100644 (file)
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -613,6 +613,29 @@
     `(lambda (function ,@names)
        (alien-funcall (deref function) ,@names))))
 
+;;; A per-thread list of frame pointer, program counter conses.
+(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)
+  (let* ((fp-and-pc (multiple-value-bind (fp pc)
+                        (%caller-frame-and-pc)
+                      (cons fp pc)))
+         (*saved-fp-and-pcs* (cons fp-and-pc *saved-fp-and-pcs*)))
+    (declare (truly-dynamic-extent fp-and-pc *saved-fp-and-pcs*))
+    (funcall fn)))
+
+(defun find-saved-fp-and-pc (fp)
+  (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))))))
+
 (deftransform alien-funcall ((function &rest args) * * :important t)
   (let ((type (lvar-type function)))
     (unless (alien-type-type-p type)
@@ -667,6 +690,11 @@
                         `(multiple-value-bind ,(temps) ,body
                            (values ,@(results)))))
                 (setf body `(naturalize ,body ',return-type)))
+            ;; Remember this frame to make sure that we can get back
+            ;; 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)))
             (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
             `(lambda (function ,@(params))
                ,body)))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 6f12975..8bf7b66 100644 (file)
--- 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.21.31"
+"1.0.21.32"