Recover full backtraces with generic arithmetic on x86 and x86-64

 * Errors in generic arithmetic (or comparisons) used to hide the caller
   in the backtrace: it was replaced with a frame in the anonymous
   assembly stub.

 * Regression since 1.0.24.35, fixes lp#800343.

 * Also remove a misleading FIXME in typed-accessor-definitions
   (reported by Matt Novenstern in lp#1171646).

diff --git a/NEWS b/NEWS
index 1cb0834..884f06e 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -35,6 +35,8 @@ changes relative to sbcl-1.1.7:
   * bug fix: some LOOP statements couldn't be compiled.
     (lp#1178989)
   * bug fix: sb-sequence:dosequence works on literal vectors.
+  * bug fix: errors in generic arithmetic show the assembly routine's
+    caller on x86 and x86-64. (lp#800343)
   * optimization: faster ISQRT on fixnums and small bignums
   * optimization: faster and smaller INTEGER-LENGTH on fixnums on x86-64.
   * optimization: On x86-64, the number of multi-byte NOP instructions used

diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp
index 684d16e..c816bdf 100644 (file)
--- a/src/assembly/x86-64/arith.lisp
+++ b/src/assembly/x86-64/arith.lisp
@@ -176,6 +176,8 @@
                 (inst ret)
 
                 DO-STATIC-FUN
+                (inst push rbp-tn)
+                (inst mov rbp-tn rsp-tn)
                 (inst sub rsp-tn (* n-word-bytes 3))
                 (inst mov (make-ea :qword :base rsp-tn
                                    :disp (frame-byte-offset
@@ -198,6 +200,7 @@
                     (:l `((inst mov y (1+ nil-value))
                           (inst cmp y x)))
                     (:g `((inst cmp x (1+ nil-value)))))
+                (inst pop rbp-tn)
                 (inst ret))
              #-sb-assembling
              `(define-vop (,name)
@@ -246,6 +249,8 @@
   (inst ret)
 
   DO-STATIC-FUN
+  (inst push rbp-tn)
+  (inst mov rbp-tn rsp-tn)
   (inst sub rsp-tn (* n-word-bytes 3))
   (inst mov (make-ea :qword :base rsp-tn
                      :disp (frame-byte-offset
@@ -263,6 +268,7 @@
                       :disp (+ nil-value (static-fun-offset 'eql))))
   (load-symbol y t)
   (inst cmp x y)
+  (inst pop rbp-tn)
   (inst ret))
 
 #-sb-assembling
@@ -308,6 +314,8 @@
   (inst ret)
 
   DO-STATIC-FUN
+  (inst push rbp-tn)
+  (inst mov rbp-tn rsp-tn)
   (inst sub rsp-tn (* n-word-bytes 3))
   (inst mov (make-ea :qword :base rsp-tn
                      :disp (frame-byte-offset
@@ -326,6 +334,7 @@
                       :disp (+ nil-value (static-fun-offset 'two-arg-=))))
   (load-symbol y t)
   (inst cmp x y)
+  (inst pop rbp-tn)
   (inst ret))
 
 #-sb-assembling

diff --git a/src/assembly/x86/arith.lisp b/src/assembly/x86/arith.lisp
index 53ba95e..52b3efc 100644 (file)
--- a/src/assembly/x86/arith.lisp
+++ b/src/assembly/x86/arith.lisp
@@ -170,6 +170,8 @@
                 (inst ret)
 
                 DO-STATIC-FUN
+                (inst push ebp-tn)
+                (inst mov ebp-tn esp-tn)
                 (inst sub esp-tn (fixnumize 3))
                 (inst mov (make-ea :dword :base esp-tn
                                    :disp (frame-byte-offset
@@ -192,6 +194,7 @@
                     (:l `((inst mov y (1+ nil-value))
                           (inst cmp y x)))
                     (:g `((inst cmp x (1+ nil-value)))))
+                (inst pop ebp-tn)
                 (inst ret))
              #-sb-assembling
              `(define-vop (,name)
@@ -239,6 +242,8 @@
   (inst cmp x y)
   (inst jmp :e RET)
 
+  (inst push ebp-tn)
+  (inst mov ebp-tn esp-tn)
   (inst sub esp-tn (fixnumize 3))
   (inst mov (make-ea :dword :base esp-tn
                      :disp (frame-byte-offset
@@ -256,6 +261,7 @@
                       :disp (+ nil-value (static-fun-offset 'eql))))
   (load-symbol y t)
   (inst cmp x y)
+  (inst pop ebp-tn)
   (inst ret))
 
 #-sb-assembling
@@ -296,6 +302,8 @@
   (inst ret)
 
   DO-STATIC-FUN
+  (inst push ebp-tn)
+  (inst mov ebp-tn esp-tn)
   (inst sub esp-tn (fixnumize 3))
   (inst mov (make-ea :dword :base esp-tn
                      :disp (frame-byte-offset
@@ -313,6 +321,7 @@
                       :disp (+ nil-value (static-fun-offset 'two-arg-=))))
   (load-symbol y t)
   (inst cmp x y)
+  (inst pop ebp-tn)
   (inst ret))
 
 #-sb-assembling

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 9ff1cb9..a2ee93a 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -527,10 +527,6 @@
               ((not inherited)
                (stuff `(declaim (inline ,name ,@(unless (dsd-read-only slot)
                                                         `((setf ,name))))))
-               ;; FIXME: The arguments in the next two DEFUNs should
-               ;; be gensyms. (Otherwise e.g. if NEW-VALUE happened to
-               ;; be the name of a special variable, things could get
-               ;; weird.)
                (stuff `(defun ,name (structure)
                         (declare (type ,ltype structure))
                         (the ,slot-type (elt structure ,index))))

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index cfa16d6..1804a08 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -273,6 +273,44 @@
                             '(((flet bar :in bug-308926) 13)
                               (bug-308926 &rest t)))))
 
+;;; Test backtrace through assembly routines
+;;; :bug-800343
+(macrolet ((test (predicate fun
+                    &optional (two-arg
+                               (find-symbol (format nil "TWO-ARG-~A" fun)
+                                            "SB-KERNEL")))
+               (let ((test-name (make-symbol (format nil "TEST-~A" fun))))
+                 `(flet ((,test-name (x y)
+                           ;; make sure it's not in tail position
+                           (list (,fun x y))))
+                    (with-test (:name (:bug-800343 ,fun))
+                      (assert (verify-backtrace
+                               (lambda ()
+                                 (eval `(funcall ,#',test-name 42 t)))
+                               '((,two-arg 42 t)
+                                 #+(or x86 x86-64)
+                                 ,@(and predicate
+                                    '(("no debug information for frame")))
+                                 ((flet ,test-name :in ,*p*) 42 t))))))))
+             (test-predicates (&rest functions)
+               `(progn ,@(mapcar (lambda (function)
+                                   (if (consp function)
+                                       `(test t ,@function)
+                                       `(test t ,function)))
+                                 functions)))
+             (test-functions (&rest functions)
+               `(progn ,@(mapcar (lambda (function)
+                                   (if (consp function)
+                                       `(test nil ,@function)
+                                       `(test nil ,function)))
+                                 functions))))
+    (test-predicates = < >)
+    (test-functions + - * /
+                    gcd lcm
+                    (logand sb-kernel:two-arg-and)
+                    (logior sb-kernel:two-arg-ior)
+                    (logxor sb-kernel:two-arg-xor)))
+
 ;;; test entry point handling in backtraces
 
 (defun oops ()