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.

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

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"

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

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

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)))))))

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"