1.0.30.11: autogenerate tagname information for LDB in genesis

 * Also remove some 32-bit assumption from LDB, and
   add missing array types there.

   Patch by Luis Oliveira.

 * Also fix the DESCRIBE buglet credit in NEWS.

diff --git a/NEWS b/NEWS
index 05c25d6..907941a 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -17,6 +17,8 @@ changes relative to sbcl-1.0.30:
     absence of an explicit DEFGENERIC.
   * improvement: DESCRIBE now reports on symbols naming undefined
     but assumed or declared function as well.
+  * bug fix: the low-level debugger had 32-bit assumptions and was missing
+    information about some array types. (thanks to Luis Oliveira)
   * bug fix: moderately complex combinations of inline expansions could
     be miscompiled if the result was declared to be dynamic extent.
   * bug fix: in some cases no compiler note about failure to stack allocate
@@ -25,7 +27,7 @@ changes relative to sbcl-1.0.30:
     allocation could cause objects users might reasonably expect to
     be heap allocated to be stack allocated.
   * bug fix: DESCRIBE signalled an error for generic functions under
-    certain circumstances. (reported by Leslie Polzer)
+    certain circumstances. (thanks to Leslie Polzer)
 
 changes in sbcl-1.0.30 relative to sbcl-1.0.29:
   * minor incompatible change: SB-THREAD:JOIN-THREAD-ERROR-THREAD and

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 4978acc..db3ca48 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -2867,7 +2867,36 @@ core and return a descriptor to it."
             (c-symbol-name symbol)
             (sb!xc:mask-field (symbol-value symbol) -1))))
 
-
+#!+sb-ldb
+(defun write-tagnames-h (&optional (out *standard-output*))
+  (labels
+      ((pretty-name (symbol strip)
+         (let ((name (string-downcase symbol)))
+           (substitute #\Space #\-
+                       (subseq name 0 (- (length name) (length strip))))))
+       (list-sorted-tags (tail)
+         (loop for symbol being the external-symbols of "SB!VM"
+               when (and (constantp symbol)
+                         (tailwise-equal (string symbol) tail))
+               collect symbol into tags
+               finally (return (sort tags #'< :key #'symbol-value))))
+       (write-tags (kind limit ash-count)
+         (format out "~%static const char *~(~A~)_names[] = {~%"
+                 (subseq kind 1))
+         (let ((tags (list-sorted-tags kind)))
+           (dotimes (i limit)
+             (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count))
+                 (format out "    \"~A\"" (pretty-name (pop tags) kind))
+                 (format out "    \"unknown [~D]\"" i))
+             (unless (eql i (1- limit))
+               (write-string "," out))
+             (terpri out)))
+         (write-line "};" out)))
+    (write-tags "-LOWTAG" sb!vm:lowtag-limit 0)
+    ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG
+    ;; ending with the same 2 bits. (#b10)
+    (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2))
+  (values))
 
 (defun write-primitive-object (obj)
   ;; writing primitive object layouts
@@ -3355,6 +3384,8 @@ initially undefined function references:~2%")
             (write-map)))
         (out-to "config" (write-config-h))
         (out-to "constants" (write-constants-h))
+        #!+sb-ldb
+        (out-to "tagnames" (write-tagnames-h))
         (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
                              :key (lambda (obj)
                                     (symbol-name
@@ -3387,5 +3418,3 @@ initially undefined function references:~2%")
 
         (when core-file-name
           (write-initial-core-file core-file-name))))))
-
-

diff --git a/src/runtime/monitor.c b/src/runtime/monitor.c
index 6920df4..5bc83c3 100644 (file)
--- a/src/runtime/monitor.c
+++ b/src/runtime/monitor.c
@@ -273,8 +273,7 @@ search_cmd(char **ptr)
         end += 2;
         if (widetag_of(obj) == SIMPLE_FUN_HEADER_WIDETAG) {
             print((long)addr | FUN_POINTER_LOWTAG);
-        } else if (lowtag_of(obj) == OTHER_IMMEDIATE_0_LOWTAG ||
-                   lowtag_of(obj) == OTHER_IMMEDIATE_1_LOWTAG) {
+        } else if (other_immediate_lowtag_p(obj)) {
             print((lispobj)addr | OTHER_POINTER_LOWTAG);
         } else {
             print((lispobj)addr);

diff --git a/src/runtime/print.c b/src/runtime/print.c
index 6f3b505..a7a578c 100644 (file)
--- a/src/runtime/print.c
+++ b/src/runtime/print.c
@@ -34,10 +34,8 @@
 #include "gencgc-alloc-region.h" /* genesis/thread.h needs this */
 #include "genesis/static-symbols.h"
 #include "genesis/primitive-objects.h"
-
 #include "genesis/static-symbols.h"
-
-
+#include "genesis/tagnames.h"
 
 static int max_lines = 20, cur_lines = 0;
 static int max_depth = 5, brief_depth = 2, cur_depth = 0;
@@ -49,123 +47,6 @@ static void print_obj(char *prefix, lispobj obj);
 
 #define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return;
 
-/* FIXME: This should be auto-generated by whatever generates
-   constants.h so we don't have to maintain this twice! */
-#ifdef LISP_FEATURE_X86_64
-char *lowtag_Names[] = {
-    "even fixnum",
-    "instance pointer",
-    "other immediate [0]",
-    "unknown [3]",
-    "unknown [4]",
-    "unknown [5]",
-    "other immediate [1]",
-    "list pointer",
-    "odd fixnum",
-    "function pointer",
-    "other immediate [2]",
-    "unknown [11]",
-    "unknown [12]",
-    "unknown [13]",
-    "other immediate [3]",
-    "other pointer"
-};
-#else
-char *lowtag_Names[] = {
-    "even fixnum",
-    "instance pointer",
-    "other immediate [0]",
-    "list pointer",
-    "odd fixnum",
-    "function pointer",
-    "other immediate [1]",
-    "other pointer"
-};
-#endif
-
-/* FIXME: Yikes! This table implicitly depends on the values in sbcl.h,
- * but doesn't actually depend on them, so if they change, it gets
- * all broken. We should either get rid of it or
- * rewrite the code so that it's cleanly initialized by gc_init_tables[]
- * in a way which varies correctly with the values in sbcl.h. */
-char *subtype_Names[] = {
-    "unused 0",
-    "unused 1",
-    "bignum",
-    "ratio",
-    "single float",
-    "double float",
-#ifdef LONG_FLOAT_WIDETAG
-    "long float",
-#endif
-    "complex",
-#ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
-    "complex single float",
-#endif
-#ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
-    "complex double float",
-#endif
-#ifdef COMPLEX_LONG_FLOAT_WIDETAG
-    "complex long float",
-#endif
-    "simple-array",
-    "simple-string",
-    "simple-bit-vector",
-    "simple-vector",
-    "(simple-array (unsigned-byte 2) (*))",
-    "(simple-array (unsigned-byte 4) (*))",
-    "(simple-array (unsigned-byte 8) (*))",
-    "(simple-array (unsigned-byte 16) (*))",
-    "(simple-array (unsigned-byte 32) (*))",
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
-    "(simple-array (signed-byte 8) (*))",
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
-    "(simple-array (signed-byte 16) (*))",
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
-    "(simple-array fixnum (*))",
-#endif
-#ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
-    "(simple-array (signed-byte 32) (*))",
-#endif
-    "(simple-array single-float (*))",
-    "(simple-array double-float (*))",
-#ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
-    "(simple-array long-float (*))",
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
-    "(simple-array (complex single-float) (*))",
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
-    "(simple-array (complex double-float) (*))",
-#endif
-#ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
-    "(simple-array (complex long-float) (*))",
-#endif
-    "complex-string",
-    "complex-bit-vector",
-    "(array * (*))",
-    "array",
-    "code header",
-    "function header",
-    "closure header",
-    "funcallable-instance header",
-    "unused function header 1",
-    "unused function header 2",
-    "unused function header 3",
-    "closure function header",
-    "return PC header",
-    "value cell header",
-    "symbol header",
-    "character",
-    "SAP",
-    "unbound marker",
-    "weak pointer",
-    "instance header",
-    "fdefn"
-};
-
 static void indent(int in)
 {
     static char *spaces = "                                                                ";
@@ -241,7 +122,6 @@ static void print_fixnum(lispobj obj)
 static void brief_otherimm(lispobj obj)
 {
     int type, c;
-    unsigned int idx;
     char buffer[10];
 
     type = widetag_of(obj);
@@ -281,28 +161,14 @@ static void brief_otherimm(lispobj obj)
             break;
 
         default:
-            idx = type >> 2;
-            if (idx < (sizeof(lowtag_Names) / sizeof(char *)))
-                    printf("%s", lowtag_Names[idx]);
-            else
-                    printf("unknown type (0x%0x)", type);
+            printf("%s", widetag_names[type >> 2]);
             break;
     }
 }
 
 static void print_otherimm(lispobj obj)
 {
-    int type;
-
-    unsigned int idx;
-
-    type = widetag_of(obj);
-    idx = type >> 2;
-
-    if (idx < (sizeof(lowtag_Names) / sizeof(char *)))
-            printf(", %s", lowtag_Names[idx]);
-    else
-            printf(", unknown type (0x%0x)", type);
+    printf(", %s", widetag_names[widetag_of(obj) >> 2]);
 
     switch (widetag_of(obj)) {
         case CHARACTER_WIDETAG:
@@ -451,9 +317,9 @@ static void print_slots(char **slots, int count, lispobj *ptr)
     }
 }
 
-/* FIXME: Yikes again! This, like subtype_Names[], needs to depend
- * on the values in sbcl.h (or perhaps be generated automatically
- * by GENESIS as part of sbcl.h). */
+/* FIXME: Yikes! This needs to depend on the values in sbcl.h (or
+ * perhaps be generated automatically by GENESIS as part of
+ * sbcl.h). */
 static char *symbol_slots[] = {"value: ", "hash: ",
     "plist: ", "name: ", "package: ",
 #ifdef LISP_FEATURE_SB_THREAD
@@ -495,13 +361,12 @@ static void print_otherptr(lispobj obj)
         }
 
         header = *ptr++;
-        length = (*ptr) >> 2;
-        count = header>>8;
+        length = fixnum_value(*ptr);
+        count = HeaderValue(header);
         type = widetag_of(header);
 
         print_obj("header: ", header);
-        if (lowtag_of(header) != OTHER_IMMEDIATE_0_LOWTAG &&
-            lowtag_of(header) != OTHER_IMMEDIATE_1_LOWTAG) {
+        if (!other_immediate_lowtag_p(header)) {
             NEWLINE_OR_RETURN;
             printf("(invalid header object)");
             return;
@@ -618,9 +483,24 @@ static void print_otherptr(lispobj obj)
             case SIMPLE_BIT_VECTOR_WIDETAG:
             case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
             case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
+            case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
             case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
+            case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
             case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
+            case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG:
+#endif
+            case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
             case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
+            case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
+            case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
+            case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
+#endif
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
             case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
 #endif
@@ -633,6 +513,12 @@ static void print_otherptr(lispobj obj)
 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
             case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
 #endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
+            case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG:
+#endif
+#ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
+            case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
+#endif
             case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
             case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
@@ -764,7 +650,7 @@ static void print_obj(char *prefix, lispobj obj)
             newline(NULL);
         printf("%s0x%08lx: ", prefix, (unsigned long) obj);
         if (cur_depth < brief_depth) {
-            fputs(lowtag_Names[type], stdout);
+            fputs(lowtag_names[type], stdout);
             (*verbose_fns[type])(obj);
         }
         else

diff --git a/src/runtime/print.h b/src/runtime/print.h
index 9bfe560..f5b2844 100644 (file)
--- a/src/runtime/print.h
+++ b/src/runtime/print.h
@@ -15,8 +15,6 @@
 #include "sbcl.h"
 #include "runtime.h"
 
-extern char *lowtag_Names[], *subtype_Names[];
-
 extern void print(lispobj obj);
 extern void brief_print(lispobj obj);
 extern void reset_printer(void);

diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h
index 2d4eea7..8602432 100644 (file)
--- a/src/runtime/runtime.h
+++ b/src/runtime/runtime.h
@@ -229,6 +229,24 @@ fixnum_value(lispobj n)
 #endif
 typedef int boolean;
 
+static inline boolean
+other_immediate_lowtag_p(lispobj header)
+{
+    switch (lowtag_of(header)) {
+    case OTHER_IMMEDIATE_0_LOWTAG:
+    case OTHER_IMMEDIATE_1_LOWTAG:
+#ifdef OTHER_IMMEDIATE_2_LOWTAG
+    case OTHER_IMMEDIATE_2_LOWTAG:
+#endif
+#ifdef OTHER_IMMEDIATE_3_LOWTAG
+    case OTHER_IMMEDIATE_3_LOWTAG:
+#endif
+        return 1;
+    default:
+        return 0;
+    }
+}
+
 /* KLUDGE: As far as I can tell there's no ANSI C way of saying
  * "this function never returns". This is the way that you do it
  * in GCC later than version 2.5 or so. */

diff --git a/version.lisp-expr b/version.lisp-expr
index c65456a..fcd4f02 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.30.10"
+"1.0.30.11"