fix "unable to read" compiler-error reporting during SBCL build

[sbcl.git] / src / compiler / generic / genesis.lisp

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 9dd2264..ed55374 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -282,6 +282,13 @@
 (defun is-fixnum-lowtag (lowtag)
   (zerop (logand lowtag sb!vm:fixnum-tag-mask)))
 
+(defun is-other-immediate-lowtag (lowtag)
+  ;; The other-immediate lowtags are similar to the fixnum lowtags, in
+  ;; that they have an "effective length" that is shorter than is used
+  ;; for the pointer lowtags.  Unlike the fixnum lowtags, however, the
+  ;; other-immediate lowtags are always effectively two bits wide.
+  (= (logand lowtag 3) sb!vm:other-immediate-0-lowtag))
+
 (defstruct (descriptor
             (:constructor make-descriptor
                           (high low &optional gspace word-offset))
@@ -314,12 +321,7 @@
                        (if (> unsigned #x1FFFFFFF)
                            (- unsigned #x40000000)
                            unsigned))))
-            ((or (= lowtag sb!vm:other-immediate-0-lowtag)
-                 (= lowtag sb!vm:other-immediate-1-lowtag)
-                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-                 (= lowtag sb!vm:other-immediate-2-lowtag)
-                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
-                 (= lowtag sb!vm:other-immediate-3-lowtag))
+            ((is-other-immediate-lowtag lowtag)
              (format stream
                      "for other immediate: #X~X, type #b~8,'0B"
                      (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
@@ -2121,7 +2123,7 @@ core and return a descriptor to it."
                 (let ((index (read-arg ,package-len)))
                   (push-fop-table
                    (cold-load-symbol (read-arg ,pname-len)
-                                     (svref *current-fop-table* index)))))))
+                                     (ref-fop-table index)))))))
   (frob fop-symbol-in-package-save #.sb!vm:n-word-bytes #.sb!vm:n-word-bytes)
   (frob fop-small-symbol-in-package-save 1 #.sb!vm:n-word-bytes)
   (frob fop-symbol-in-byte-package-save #.sb!vm:n-word-bytes 1)
@@ -2388,17 +2390,17 @@ core and return a descriptor to it."
 ;;;; cold fops for fixing up circularities
 
 (define-cold-fop (fop-rplaca :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))
         (idx (read-word-arg)))
     (write-memory (cold-nthcdr idx obj) (pop-stack))))
 
 (define-cold-fop (fop-rplacd :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))
         (idx (read-word-arg)))
     (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
 
 (define-cold-fop (fop-svset :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))
         (idx (read-word-arg)))
     (write-wordindexed obj
                    (+ idx
@@ -2408,7 +2410,7 @@ core and return a descriptor to it."
                    (pop-stack))))
 
 (define-cold-fop (fop-structset :pushp nil)
-  (let ((obj (svref *current-fop-table* (read-word-arg)))
+  (let ((obj (ref-fop-table (read-word-arg)))
         (idx (read-word-arg)))
     (write-wordindexed obj (1+ idx) (pop-stack))))
 
@@ -2947,14 +2949,14 @@ core and return a descriptor to it."
   (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%")
   (format t " * so they work directly on tagged addresses. */~2%")
   (let ((name (sb!vm:primitive-object-name obj))
-        (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
-    (when lowtag
-      (dolist (slot (sb!vm:primitive-object-slots obj))
-        (format t "#define ~A_~A_OFFSET ~D~%"
-                (c-symbol-name name)
-                (c-symbol-name (sb!vm:slot-name slot))
-                (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
-      (terpri)))
+        (lowtag (or (symbol-value (sb!vm:primitive-object-lowtag obj))
+                    0)))
+    (dolist (slot (sb!vm:primitive-object-slots obj))
+      (format t "#define ~A_~A_OFFSET ~D~%"
+              (c-symbol-name name)
+              (c-symbol-name (sb!vm:slot-name slot))
+              (- (* (sb!vm:slot-offset slot) sb!vm:n-word-bytes) lowtag)))
+    (terpri))
   (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
 
 (defun write-structure-object (dd)
@@ -3072,8 +3074,6 @@ initially undefined function references:~2%")
 (defconstant new-directory-core-entry-type-code 3861)
 (defconstant initial-fun-core-entry-type-code 3863)
 (defconstant page-table-core-entry-type-code 3880)
-#!+(and sb-lutex sb-thread)
-(defconstant lutex-table-core-entry-type-code 3887)
 (defconstant end-core-entry-type-code 3840)
 
 (declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))