From: Alastair Bridgewater <lisphacker@users.sourceforge.net>
Date: Sun, 28 Feb 2010 17:13:59 +0000 (+0000)
Subject: 1.0.36.1: Improve backtrace from THROW to unknown tag on x86oids.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8863d95f6884b753887a71f9ac98c92cb953ada6;p=sbcl.git

1.0.36.1: Improve backtrace from THROW to unknown tag on x86oids.

  * Essentially, just fake up another stack frame before hitting the
    error trap.
---

diff --git a/NEWS b/NEWS
index 1c57bc7..a602fd7 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,8 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.0.36:
+  * enhancement: Backtrace from THROW to uncaught tag on x86oids now shows
+    stack frame thrown from.
+
 changes in sbcl-1.0.36 relative to sbcl-1.0.35:
   * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and
     SB-EXT:TYPEXPAND-ALL behave exactly like their MACROEXPAND counterparts
diff --git a/src/assembly/x86-64/assem-rtns.lisp b/src/assembly/x86-64/assem-rtns.lisp
index 28b0c1c..b6ea237 100644
--- a/src/assembly/x86-64/assem-rtns.lisp
+++ b/src/assembly/x86-64/assem-rtns.lisp
@@ -218,7 +218,7 @@
                               fun-pointer-lowtag))))
 
 (define-assembly-routine (throw
-                          (:return-style :none))
+                          (:return-style :raw))
                          ((:arg target (descriptor-reg any-reg) rdx-offset)
                           (:arg start any-reg rbx-offset)
                           (:arg count any-reg rcx-offset)
@@ -230,7 +230,17 @@
 
   LOOP
 
-  (let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
+  (let ((error (gen-label)))
+    (assemble (*elsewhere*)
+      (emit-label error)
+
+      ;; Fake up a stack frame so that backtraces come out right.
+      (inst push rbp-tn)
+      (inst mov rbp-tn rsp-tn)
+
+      (emit-error-break nil error-trap
+                        (error-number-or-lose 'unseen-throw-tag-error)
+                        (list target)))
     (inst or catch catch)               ; check for NULL pointer
     (inst jmp :z error))
 
diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp
index cce719e..1ef7ed0 100644
--- a/src/assembly/x86/assem-rtns.lisp
+++ b/src/assembly/x86/assem-rtns.lisp
@@ -213,7 +213,7 @@
   (inst jmp (make-ea-for-object-slot eax closure-fun-slot fun-pointer-lowtag)))
 
 (define-assembly-routine (throw
-                          (:return-style :none))
+                          (:return-style :raw))
                          ((:arg target (descriptor-reg any-reg) edx-offset)
                           (:arg start any-reg ebx-offset)
                           (:arg count any-reg ecx-offset)
@@ -225,7 +225,17 @@
 
   LOOP
 
-  (let ((error (generate-error-code nil 'unseen-throw-tag-error target)))
+  (let ((error (gen-label)))
+    (assemble (*elsewhere*)
+      (emit-label error)
+
+      ;; Fake up a stack frame so that backtraces come out right.
+      (inst push ebp-tn)
+      (inst mov ebp-tn esp-tn)
+
+      (emit-error-break nil error-trap
+                        (error-number-or-lose 'unseen-throw-tag-error)
+                        (list target)))
     (inst or catch catch)               ; check for NULL pointer
     (inst jmp :z error))
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 0ae6203..fee349b 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.36"
+"1.0.36.1"