X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug-int.lisp;h=df06188ed07f0519110132703308bad492ae18d7;hb=aa01df7a18a5d8747423173bda7c20eb46092514;hp=7411bc59a10f25a2997d59c9e1a2bde051de75f5;hpb=cdd026dddac3eaddbaa0221503e49e2673d54545;p=sbcl.git

diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp
index 7411bc5..df06188 100644
--- a/src/code/debug-int.lisp
+++ b/src/code/debug-int.lisp
@@ -539,8 +539,7 @@
 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
   (pc system-area-pointer))
 
-#!+gencgc (declaim (inline valid-lisp-pointer-p))
-#!+gencgc
+(declaim (inline valid-lisp-pointer-p))
 (sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
   (pointer system-area-pointer))
 
@@ -867,7 +866,15 @@
                          (component-from-component-ptr component-ptr))))
             (/noshow0 "got CODE")
             (when (null code)
-              (return (values code 0 context)))
+              ;; KLUDGE: Detect undefined functions by a range-check
+              ;; against the trampoline address and the following
+              ;; function in the runtime.
+              (if (< (foreign-symbol-address "undefined_tramp")
+                     (sap-int (sb!vm:context-pc context))
+                     (foreign-symbol-address #!+x86 "closure_tramp"
+                                             #!+x86-64 "alloc_tramp"))
+                  (return (values :undefined-function 0 context))
+                  (return (values code 0 context))))
             (let* ((code-header-len (* (get-header-data code)
                                        sb!vm:n-word-bytes))
                    (pc-offset
@@ -1974,6 +1981,18 @@ register."
 ;;; (Such values can arise in registers on machines with conservative
 ;;; GC, and might also arise in debug variable locations when
 ;;; those variables are invalid.)
+;;;
+;;; NOTE: this function is not GC-safe in the slightest when creating
+;;; a pointer to an object in dynamic space.  If a GC occurs between
+;;; the start of the call to VALID-LISP-POINTER-P and the end of
+;;; %MAKE-LISP-OBJ then the object could move before the boxed pointer
+;;; is constructed.  This can happen on CHENEYGC if an asynchronous
+;;; interrupt occurs within the window.  This can happen on GENCGC
+;;; under the same circumstances, but is more likely due to all GENCGC
+;;; platforms supporting threaded operation.  This is somewhat
+;;; mitigated on x86oids due to the conservative stack and interrupt
+;;; context "scavenging" on such platforms, but there still may be a
+;;; vulnerable window.
 (defun make-lisp-obj (val &optional (errorp t))
   (if (or
        ;; fixnum
@@ -1986,22 +2005,17 @@ register."
             (= (logand val #xff) sb!vm:character-widetag)) ; char tag
        ;; unbound marker
        (= val sb!vm:unbound-marker-widetag)
+       ;; undefined_tramp doesn't validate properly as a pointer, and
+       ;; the actual value can vary by backend (x86oids need not
+       ;; apply)
+       #!+(or alpha hppa mips ppc)
+       (= val (+ (- (foreign-symbol-address "undefined_tramp")
+                    (* sb!vm:n-word-bytes sb!vm:simple-fun-code-offset))
+                 sb!vm:fun-pointer-lowtag))
+       #!+sparc
+       (= val (foreign-symbol-address "undefined_tramp"))
        ;; pointer
-       #!+gencgc
-       (not (zerop (valid-lisp-pointer-p (int-sap val))))
-       ;; FIXME: There is no fundamental reason not to use the above
-       ;; function on other platforms as well, but I didn't have
-       ;; others available while doing this. --NS 2007-06-21
-       #!-gencgc
-       (and (logbitp 0 val)
-            (or (< sb!vm:read-only-space-start val
-                   (ash sb!vm:*read-only-space-free-pointer*
-                        sb!vm:n-fixnum-tag-bits))
-                (< sb!vm:static-space-start val
-                   (ash sb!vm:*static-space-free-pointer*
-                        sb!vm:n-fixnum-tag-bits))
-                (< (current-dynamic-space-start) val
-                   (sap-int (dynamic-space-free-pointer))))))
+       (not (zerop (valid-lisp-pointer-p (int-sap val)))))
       (values (%make-lisp-obj val) t)
       (if errorp
           (error "~S is not a valid argument to ~S"