Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv28971/src/code

Modified Files:
	alloc.lisp debug-int.lisp room.lisp 
Log Message:
1.0.7.2: fix potential GC errors due to bogus objects in backtraces

 Backtrace construction involves calling MAKE-LISP-OBJ on things we
 devoutly hope are tagged lisp pointers, but this is not always the
 case. When we fail to detect this, and a GC follows while the bogus
 object is at location visible to GC bad things will happen. (Pinning
 doesn't change anything, as the object still needs to be scavenged.)

 To fix this (mostly -- one can still construct bogus lisp-objects
 using MAKE-LISP-OBJ, it just takes more work / is less likely to
 happen by accident):

  * Rename MAKE-LISP-OBJ %MAKE-LISP-OBJ, and MAKE-VALID-LISP-OBJ
    MAKE-LISP-OBJ.

  * Add an optional ERRORP argument to the former MAKE-VALID-LISP-OBJ,
    defaulting to T.

  * Always use the function formerly known as MAKE-VALID-LISP-OBJ,
    passing in errorp=NIL when in doubt.

  * Improve the validation done on x86/x86-64: factor out the checking
    logic in possibly_valid_dynamic_space_pointer, and use it to
    implment valid_lisp_ponter_p. Could be done on other platforms as
    well, but better done by someone who can test the results...

 Adjust other code to suit:

  * MAP-ALLOCATED-OBJECTS uses %MAKE-LISP-OBJ for now, as the new
    MAKE-LISP-OBJ is too slow to use for groveling over the whole
    heap. (Though it does detect a bunch of bogus objects we're
    constructing in ROOM now, so the time would not be really
    wasted...)

 No test cases because I've been unable to construct one that calls
 MAKE-LISP-OBJ with bogus arguments while backtracing, but such
 backtraces have been seen in the wild.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/alloc.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- alloc.lisp	14 Jul 2005 16:30:12 -0000	1.2
+++ alloc.lisp	28 Jun 2007 14:24:48 -0000	1.3
@@ -23,9 +23,7 @@
            (type (unsigned-byte #.n-word-bits) words)
            (type index length))
   (handler-case
-      ;; FIXME: Is WITHOUT-GCING enough to do lisp-side allocation
-      ;; to static space, or should we have WITHOUT-INTERRUPTS here
-      ;; as well?
+      ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS
       (without-gcing
         (let* ((pointer *static-space-free-pointer*) ; in words
                (free (* pointer n-word-bytes))
@@ -38,15 +36,14 @@
           (unless (> static-space-end new-free)
             (error 'simple-storage-condition
                    :format-control "Not enough memory left in static space to ~
-                                   allocate vector."))
+                                    allocate vector."))
           (store-word widetag
                       vector 0 other-pointer-lowtag)
           (store-word (ash length word-shift)
                       vector vector-length-slot other-pointer-lowtag)
           (store-word 0 new-free)
-          (prog1
-              (make-lisp-obj vector)
-            (setf *static-space-free-pointer* new-pointer))))
+          (setf *static-space-free-pointer* new-pointer)
+          (%make-lisp-obj vector)))
     (serious-condition (c)
       ;; unwind from WITHOUT-GCING
       (error c))))

Index: debug-int.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v
retrieving revision 1.113
retrieving revision 1.114
diff -u -d -r1.113 -r1.114
--- debug-int.lisp	2 May 2007 13:07:18 -0000	1.113
+++ debug-int.lisp	28 Jun 2007 14:24:49 -0000	1.114
@@ -510,7 +510,7 @@
 (defun %set-stack-ref (s n value) (%set-stack-ref s n value))
 (defun fun-code-header (fun) (fun-code-header fun))
 (defun lra-code-header (lra) (lra-code-header lra))
-(defun make-lisp-obj (value) (make-lisp-obj value))
+(defun %make-lisp-obj (value) (%make-lisp-obj value))
 (defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
 (defun fun-word-offset (fun) (fun-word-offset fun))
 
@@ -536,6 +536,10 @@
 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
   (pc system-area-pointer))
 
+#!+(or x86 x86-64)
+(sb!alien:define-alien-routine valid-lisp-pointer-p sb!alien:int
+  (pointer system-area-pointer))
+
 (declaim (inline component-from-component-ptr))
 (defun component-from-component-ptr (component-ptr)
   (declare (type system-area-pointer component-ptr))
@@ -982,7 +986,7 @@
 #!-(or x86 x86-64)
 (defun code-object-from-bits (bits)
   (declare (type (unsigned-byte 32) bits))
-  (let ((object (make-lisp-obj bits)))
+  (let ((object (make-lisp-obj bits nil)))
     (if (functionp object)
         (or (fun-code-header object)
             :undefined-function)
@@ -1990,12 +1994,12 @@
            (compiled-debug-var-sc-offset debug-var))))))
 
 ;;; a helper function for working with possibly-invalid values:
-;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
+;;; Do (%MAKE-LISP-OBJ VAL) only if the value looks valid.
 ;;;
 ;;; (Such values can arise in registers on machines with conservative
 ;;; GC, and might also arise in debug variable locations when
 ;;; those variables are invalid.)
-(defun make-valid-lisp-obj (val)
+(defun make-lisp-obj (val &optional (errorp t))
   (if (or
        ;; fixnum
        (zerop (logand val sb!vm:fixnum-tag-mask))
@@ -2008,20 +2012,27 @@
        ;; unbound marker
        (= val sb!vm:unbound-marker-widetag)
        ;; pointer
-       (and (logbitp 0 val)
-            ;; Check that the pointer is valid. XXX Could do a better
-            ;; job. FIXME: e.g. by calling out to an is_valid_pointer
-            ;; routine in the C runtime support code
-            (or (< sb!vm:read-only-space-start val
-                   (* sb!vm:*read-only-space-free-pointer*
-                      sb!vm:n-word-bytes))
-                (< sb!vm:static-space-start val
-                   (* sb!vm:*static-space-free-pointer*
-                      sb!vm:n-word-bytes))
-                (< (current-dynamic-space-start) val
-                   (sap-int (dynamic-space-free-pointer))))))
-      (make-lisp-obj val)
-      :invalid-object))
+       #!+(or x86 x86-64)
+       (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
+      #!-(or x86 x86-64)
+      (and (logbitp 0 val)
+           (or (< sb!vm:read-only-space-start val
+                  (* sb!vm:*read-only-space-free-pointer*
+                     sb!vm:n-word-bytes))
+               (< sb!vm:static-space-start val
+                  (* sb!vm:*static-space-free-pointer*
+                     sb!vm:n-word-bytes))
+               (< (current-dynamic-space-start) val
+                  (sap-int (dynamic-space-free-pointer))))))
+      (values (%make-lisp-obj val) t)
+      (if errorp
+          (error "~S is not a valid argument to ~S"
+                 val 'make-lisp-obj)
+          (values (make-unprintable-object (format nil "invalid object #x~X" val))
+                  nil))))
 
 #!-(or x86 x86-64)
 (defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
@@ -2057,8 +2068,8 @@
         #.sb!vm:descriptor-reg-sc-number
         #!+rt #.sb!vm:word-pointer-reg-sc-number)
        (sb!sys:without-gcing
-        (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
-
+        (with-escaped-value (val)
+          (make-lisp-obj val nil))))
       (#.sb!vm:character-reg-sc-number
        (with-escaped-value (val)
          (code-char val)))
@@ -2193,7 +2204,7 @@
       ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
        (without-gcing
         (with-escaped-value (val)
-          (make-valid-lisp-obj val))))
+          (make-lisp-obj val nil))))
       (#.sb!vm:character-reg-sc-number
        (with-escaped-value (val)
          (code-char val)))
@@ -3396,7 +3407,7 @@
 (defun handle-single-step-around-trap (context callee-register-offset)
   ;; Fetch the function / fdefn we're about to call from the
   ;; appropriate register.
-  (let* ((callee (sb!kernel::make-lisp-obj
+  (let* ((callee (make-lisp-obj
                   (context-register context callee-register-offset)))
          (step-info (single-step-info-from-context context)))
     ;; If there was not enough debug information available, there's no

Index: room.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/room.lisp,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -d -r1.43 -r1.44
--- room.lisp	5 Jun 2007 09:44:12 -0000	1.43
+++ room.lisp	28 Jun 2007 14:24:49 -0000	1.44
@@ -299,13 +299,13 @@
                     (eq (room-info-kind info) :lowtag))
                 (let ((size (* cons-size n-word-bytes)))
                   (funcall fun
-                           (make-lisp-obj (logior (sap-int current)
+                           (%make-lisp-obj (logior (sap-int current)
                                                   list-pointer-lowtag))
                            list-pointer-lowtag
                            size)
                   (setq current (sap+ current size))))
                ((eql header-widetag closure-header-widetag)
-                (let* ((obj (make-lisp-obj (logior (sap-int current)
+                (let* ((obj (%make-lisp-obj (logior (sap-int current)
                                                    fun-pointer-lowtag)))
                        (size (round-to-dualword
                               (* (the fixnum (1+ (get-closure-length obj)))
@@ -313,7 +313,7 @@
                   (funcall fun obj header-widetag size)
                   (setq current (sap+ current size))))
                ((eq (room-info-kind info) :instance)
-                (let* ((obj (make-lisp-obj
+                (let* ((obj (%make-lisp-obj
                              (logior (sap-int current) instance-pointer-lowtag)))
                        (size (round-to-dualword
                               (* (+ (%instance-length obj) 1) n-word-bytes))))
@@ -322,7 +322,7 @@
                   (aver (zerop (logand size lowtag-mask)))
                   (setq current (sap+ current size))))
                (t
-                (let* ((obj (make-lisp-obj
+                (let* ((obj (%make-lisp-obj
                              (logior (sap-int current) other-pointer-lowtag)))
                        (size (ecase (room-info-kind info)
                                (:fixed