Changeset 8037

Timestamp:

Jan 10, 2008, 12:22:54 AM (17 years ago)

Author:

Gary Byers

Message:

Lots of changes to APPLY-IN-FRAME and supporting functions.
Define RETURN-FROM-FRAME in terms of APPLY-IN-FRAME.

File:

• branches/working-0711/ccl/lib/x86-backtrace.lisp (modified) (3 diffs)

branches/working-0711/ccl/lib/x86-backtrace.lisp

@@ -265 +265 @@
 
 (defun apply-in-frame (frame function arglist &optional context)
+  (setq function (coerce-to-function function))
   (let* ((parent (parent-frame frame context)))
     (when parent
@@ -278 +279 @@
             (error "Can't find process for backtrace context ~s" context)))))))
 
-(defun return-from-frame (frame context &rest values)
-  (apply-in-frame frame #'values values context))
+(defun return-from-frame (frame &rest values)
+  (apply-in-frame frame #'values values nil))
     
+
+(defun last-tsp-before (target)
+  (declare (fixnum target))
+  (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp)
+             (%fixnum-ref tsp target::tsp-frame.backptr)))
+       ((zerop tsp) nil)
+    (declare (fixnum tsp))
+    (when (> (the fixnum (%fixnum-ref tsp target::tsp-frame.rbp))
+             target)
+      (return tsp))))
+
+    
+
+
 ;;; We can't determine this reliably (yet).
-(defun last-tsp-since (target source context)
-  (declare (ignore target source context))
-  nil)
-
-;;; We can't determine this reliably (yet).
-(defun last-foreign-sp-since (target source context)
-  (declare (ignore target source context))
-  nil)
-
-
-;;; This can lose (possibly badly) if the oldest binding younger
-;;; than the stack frame "frame" was established via PROGV.
-;;; We could make PROGV establish a "normal" binding (of
-;;; something like *CURRENT-PROGV* on the vstack; otherwise,
-;;; we'd need info about how the tstack is used at each point
-;;; on the vstack.
-(defun last-binding-since (frame start context)
-  (declare (fixnum frame start))
-  (do* ((db
-         (if context (bt.db-link context) (%current-db-link))
-         (%fixnum-ref db 0))
-        (last nil))
-       ((eql db 0) last)
-    (declare (fixnum db))
-    (if (and (< db frame)
-             (< start db))
-      (setq last db))))
+(defun last-foreign-sp-before (target)
+  (declare (fixnum target))
+  (do* ((cfp (%fixnum-ref (%current-tcr) target::tcr.foreign-sp)
+             (%fixnum-ref cfp target::csp-frame.backptr)))
+       ((zerop cfp))
+    (declare (fixnum cfp))
+    (let* ((rbp (%fixnum-ref cfp target::csp-frame.rbp)))
+      (declare (fixnum rbp))
+      (if (> rbp target)
+        (return cfp)
+        (if (zerop rbp)
+          (return nil))))))
+
+
+(defun %tsp-frame-containing-progv-binding (db)
+  (declare (fixnum db))
+  (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) next)
+        (next (%fixnum-ref tsp target::tsp-frame.backptr)
+              (%fixnum-ref tsp target::tsp-frame.backptr)))
+       ()
+    (declare (fixnum tsp next))
+    (let* ((rbp (%fixnum-ref tsp target::tsp-frame.rbp)))
+      (declare (fixnum rbp))
+      (if (zerop rbp)
+        (return (values nil nil))
+        (if (and (> db tsp)
+                 (< db next))
+          (return (values tsp rbp)))))))
+
+        
+
+
+
+
+(defun last-binding-before (frame)
+  (declare (fixnum frame))
+  (do* ((db (%current-db-link) (%fixnum-ref db 0))
+        (tcr (%current-tcr))
+        (vs-area (%fixnum-ref tcr target::tcr.vs-area))
+        (vs-low (%fixnum-ref vs-area target::area.low))
+        (vs-high (%fixnum-ref vs-area target::area.high)))
+       ((eql db 0) nil)
+    (declare (fixnum db vs-low vs-high))
+    (if (and (> db vs-low)
+             (< db vs-high))
+      (if (> db frame)
+        (return db))
+      ;; db link points elsewhere; PROGV uses the temp stack
+      ;; to store an indefinite number of bindings.
+      (multiple-value-bind (tsp rbp)
+          (%tsp-frame-containing-progv-binding db)
+        (if tsp
+          (if (> rbp frame)
+            (return db)
+            ;; If the tsp frame is too young, we can skip
+            ;; all of the bindings it contains.  The tsp
+            ;; frame contains two words of overhead, followed
+            ;; by a count of binding records in the frame,
+            ;; followed by the youngest of "count" binding
+            ;; records (which happens to be the value of
+            ;; "db".)  Skip "count" binding records.
+            (dotimes (i (the fixnum (%fixnum-ref tsp target::dnode-size)))
+              (setq db (%fixnum-ref db 0))))
+          ;; If the binding record wasn't on the temp stack and wasn't
+          ;; on the value stack, that probably means that things are
+          ;; seriously screwed up.  This error will be almost
+          ;; meaningless to the user.
+          (error "binding record (#x~16,'0x/#x~16,'0x) not on temp or value stack" (index->address db) db))))))
+          
+
 
 (defun find-x8664-saved-nvrs (frame start-fp context)
@@ -349 +407 @@
                      (%get-frame-ptr)))
          (target-xcf (last-xcf-since frame start-fp nil))
-         (target-db-link (last-binding-since frame start-fp nil))
-         (target-tsp (last-tsp-since frame start-fp nil))
-         (target-foreign-sp (last-foreign-sp-since frame start-fp nil)))
+         (target-db-link (last-binding-before frame))
+         (target-tsp (last-tsp-before frame))
+         (target-foreign-sp (last-foreign-sp-before frame)))
     (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc)
         (find-x8664-saved-nvrs frame start-fp nil)