widetag dispatch for MAP-INTO

[sbcl.git] / src / code / room.lisp

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 28444c6..e38ce5e 100644 (file)
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -39,28 +39,6 @@
         (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))
@@ -103,12 +81,12 @@
                  (simple-array-unsigned-byte-16-widetag . 1)
                  (simple-array-unsigned-byte-31-widetag . 2)
                  (simple-array-unsigned-byte-32-widetag . 2)
-                 (simple-array-unsigned-fixnum-widetag . 3)
+                 (simple-array-unsigned-fixnum-widetag . #.sb!vm:word-shift)
                  (simple-array-unsigned-byte-63-widetag . 3)
                  (simple-array-unsigned-byte-64-widetag . 3)
                  (simple-array-signed-byte-8-widetag . 0)
                  (simple-array-signed-byte-16-widetag . 1)
-                 (simple-array-fixnum-widetag . 2)
+                 (simple-array-fixnum-widetag . #.sb!vm:word-shift)
                  (simple-array-signed-byte-32-widetag . 2)
                  (simple-array-signed-byte-64-widetag . 3)
                  (simple-array-single-float-widetag . 2)
@@ -151,6 +129,10 @@
       (make-room-info :name 'instance
                       :kind :instance))
 
+(setf (svref *meta-room-info* funcallable-instance-header-widetag)
+      (make-room-info :name 'funcallable-instance
+                      :kind :closure))
+
 ) ; EVAL-WHEN
 
 (defparameter *room-info* '#.*meta-room-info*)
@@ -234,6 +216,7 @@
 #!-sb-fluid (declaim (maybe-inline map-allocated-objects))
 (defun map-allocated-objects (fun space &optional careful)
   (declare (type function fun) (type spaces space))
+  (declare (optimize (sb!c:alien-funcall-saves-fp-and-pc 0)))
   (flet ((make-obj (tagged-address)
            (if careful
                (make-lisp-obj tagged-address nil)
@@ -325,7 +308,7 @@
                                 list-pointer-lowtag
                                 (* cons-size n-word-bytes)
                                 ok)))
-                  ((eql header-widetag closure-header-widetag)
+                  ((eq (room-info-kind info) :closure)
                    (let* ((obj (%make-lisp-obj (logior (sap-int current)
                                                        fun-pointer-lowtag)))
                           (size (round-to-dualword