X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Froom.lisp;h=fdebda6e5d2f73e1906486397160b6421d65bace;hb=6f7128b46e9ca91de777f61e8623bf5d997b2987;hp=8c7e450e0d4f98be179d9de61691e24b1a678fe7;hpb=902e93736a0888aa6b04dc328b1eb328423bf426;p=sbcl.git

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 8c7e450..fdebda6 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -36,6 +36,28 @@
 	(size (primitive-object-size obj)))
     (cond
      ((not lowtag))
+     (;; KLUDGE described in dan_b message "Another one for the
+      ;; collection [bug 108]" (sbcl-devel 2004-01-22)
+      ;;
+      ;; In a freshly started SBCL 0.8.7.20ish, (TIME (ROOM T))  causes
+      ;;   debugger invoked on a SB-INT:BUG in thread 5911:
+      ;;     failed AVER: "(SAP= CURRENT END)"
+      ;; [WHN: Similar things happened on one but not the other of my
+      ;; machines when I just run ROOM a lot in a loop.]
+      ;;
+      ;; This appears to be due to my [DB] abuse of the primitive
+      ;; object macros to define a thread object that shares a lowtag
+      ;; with fixnums and has no widetag: it looks like the code that
+      ;; generates *META-ROOM-INFO* infers from this that even fixnums
+      ;; are thread-sized - probably undesirable.
+      ;;
+      ;; This [the fix; the EQL NAME 'THREAD clause here] is more in the
+      ;; nature of a workaround than a really good fix. I'm not sure
+      ;; what a really good fix is: I /think/ it's probably to remove
+      ;; the :LOWTAG option in DEFINE-PRIMITIVE-OBJECT THREAD, then teach
+      ;; genesis to generate the necessary OBJECT_SLOT_OFFSET macros
+      ;; for assembly source in the runtime/genesis/*.h files.
+      (eql name 'thread))
      ((not widetag)
       (let ((info (make-room-info :name name
 				  :kind :lowtag))
@@ -69,11 +91,15 @@
 		 (simple-vector-widetag . 2)
 		 (simple-array-unsigned-byte-2-widetag . -2)
 		 (simple-array-unsigned-byte-4-widetag . -1)
+		 (simple-array-unsigned-byte-7-widetag . 0)
 		 (simple-array-unsigned-byte-8-widetag . 0)
+		 (simple-array-unsigned-byte-15-widetag . 1)
 		 (simple-array-unsigned-byte-16-widetag . 1)
+		 (simple-array-unsigned-byte-31-widetag . 2)
 		 (simple-array-unsigned-byte-32-widetag . 2)
 		 (simple-array-signed-byte-8-widetag . 0)
 		 (simple-array-signed-byte-16-widetag . 1)
+		 (simple-array-unsigned-byte-29-widetag . 2)
 		 (simple-array-signed-byte-30-widetag . 2)
 		 (simple-array-signed-byte-32-widetag . 2)
 		 (simple-array-single-float-widetag . 2)
@@ -542,32 +568,6 @@
 
   (values))
 
-(defun find-holes (&rest spaces)
-  (dolist (space (or spaces '(:read-only :static :dynamic)))
-    (format t "In ~A space:~%" space)
-    (let ((start-addr nil)
-	  (total-bytes 0))
-      (declare (type (or null (unsigned-byte 32)) start-addr)
-	       (type (unsigned-byte 32) total-bytes))
-      (map-allocated-objects
-       (lambda (object typecode bytes)
-	 (declare (ignore typecode)
-		  (type (unsigned-byte 32) bytes))
-	 (if (and (consp object)
-		  (eql (car object) 0)
-		  (eql (cdr object) 0))
-	     (if start-addr
-		 (incf total-bytes bytes)
-		 (setf start-addr (sb!di::get-lisp-obj-address object)
-		       total-bytes bytes))
-	     (when start-addr
-	       (format t "~:D bytes at #X~X~%" total-bytes start-addr)
-	       (setf start-addr nil))))
-       space)
-      (when start-addr
-	(format t "~:D bytes at #X~X~%" total-bytes start-addr))))
-  (values))
-
 ;;;; PRINT-ALLOCATED-OBJECTS
 
 (defun print-allocated-objects (space &key (percent 0) (pages 5)