src/runtime/print.c

   1 /* code for low-level debugging/diagnostic output */
   2
   3 /*
   4  * This software is part of the SBCL system. See the README file for
   5  * more information.
   6  *
   7  * This software is derived from the CMU CL system, which was
   8  * written at Carnegie Mellon University and released into the
   9  * public domain. The software is in the public domain and is
  10  * provided with absolutely no warranty. See the COPYING and CREDITS
  11  * files for more information.
  12  */
  13
  14 /*
  15  * FIXME:
  16  *   Some of the code in here (the various
  17  *   foo_slots[], at least) is deeply broken, depending on guessing
  18  *   already out-of-date values instead of getting them from sbcl.h.
  19  */
  20
  21 #include <stdio.h>
  22 #include <string.h>
  23
  24 #include "sbcl.h"
  25 #include "print.h"
  26 #include "runtime.h"
  27 #include <stdarg.h>
  28 #include "thread.h"              /* genesis/primitive-objects.h needs this */
  29 #include <errno.h>
  30 #include <stdlib.h>
  31
  32 /* FSHOW and odxprint provide debugging output for low-level information
  33  * (signal handling, exceptions, safepoints) which is hard to debug by
  34  * other means.
  35  *
  36  * If enabled at all, environment variables control whether calls of the
  37  * form odxprint(name, ...) are enabled at run-time, e.g. using
  38  * SBCL_DYNDEBUG="fshow fshow_signal safepoints".
  39  *
  40  * In the case of FSHOW and FSHOW_SIGNAL, old-style code from runtime.h
  41  * can also be used to enable or disable these more aggressively.
  42  */
  43
  44 struct dyndebug_config dyndebug_config = {
  45     QSHOW == 2, QSHOW_SIGNALS == 2
  46 };
  47
  48 void
  49 dyndebug_init()
  50 {
  51 #define DYNDEBUG_NFLAGS (sizeof(struct dyndebug_config) / sizeof(int))
  52 #define dyndebug_init1(lowercase, uppercase)                    \
  53     do {                                                        \
  54         int *ptr = &dyndebug_config.dyndebug_##lowercase;       \
  55         ptrs[n] = ptr;                                          \
  56         names[n] = #lowercase;                                  \
  57         char *val = getenv("SBCL_DYNDEBUG__" uppercase);        \
  58         *ptr = val && strlen(val);                              \
  59         n++;                                                    \
  60     } while (0)
  61     int n = 0;
  62     char *names[DYNDEBUG_NFLAGS];
  63     int *ptrs[DYNDEBUG_NFLAGS];
  64
  65     dyndebug_init1(fshow,          "FSHOW");
  66     dyndebug_init1(fshow_signal,   "FSHOW_SIGNAL");
  67     dyndebug_init1(gencgc_verbose, "GENCGC_VERBOSE");
  68     dyndebug_init1(safepoints,     "SAFEPOINTS");
  69     dyndebug_init1(seh,            "SEH");
  70     dyndebug_init1(misc,           "MISC");
  71     dyndebug_init1(pagefaults,     "PAGEFAULTS");
  72
  73     int n_output_flags = n;
  74     dyndebug_init1(backtrace_when_lost, "BACKTRACE_WHEN_LOST");
  75     dyndebug_init1(sleep_when_lost,     "SLEEP_WHEN_LOST");
  76
  77     if (n != DYNDEBUG_NFLAGS)
  78         fprintf(stderr, "Bug in dyndebug_init\n");
  79
  80     gencgc_verbose = dyndebug_config.dyndebug_gencgc_verbose;
  81
  82     char *featurelist = getenv("SBCL_DYNDEBUG");
  83     if (featurelist) {
  84         int err = 0;
  85         featurelist = strdup(featurelist);
  86         char *ptr = featurelist;
  87         for (;;) {
  88             char *token = strtok(ptr, " ");
  89             if (!token) break;
  90             unsigned i;
  91             if (!strcmp(token, "all"))
  92                 for (i = 0; i < n_output_flags; i++)
  93                     *ptrs[i] = 1;
  94             else {
  95                 for (i = 0; i < DYNDEBUG_NFLAGS; i++)
  96                     if (!strcmp(token, names[i])) {
  97                         *ptrs[i] = 1;
  98                         break;
  99                     }
 100                 if (i == DYNDEBUG_NFLAGS) {
 101                     fprintf(stderr, "No such dyndebug flag: `%s'\n", token);
 102                     err = 1;
 103                 }
 104             }
 105             ptr = 0;
 106         }
 107         free(featurelist);
 108         if (err) {
 109             fprintf(stderr, "Valid flags are:\n");
 110             fprintf(stderr, "  all  ;enables all of the following:\n");
 111             unsigned i;
 112             for (i = 0; i < DYNDEBUG_NFLAGS; i++) {
 113                 if (i == n_output_flags)
 114                     fprintf(stderr, "Additional options:\n");
 115                 fprintf(stderr, "  %s\n", names[i]);
 116             }
 117         }
 118     }
 119
 120 #undef dyndebug_init1
 121 #undef DYNDEBUG_NFLAGS
 122 }
 123
 124 /* Temporarily, odxprint merely performs the equivalent of a traditional
 125  * FSHOW call, i.e. it merely formats to stderr.  Ultimately, it should
 126  * be restored to its full win32 branch functionality, where output to a
 127  * file or to the debugger can be selected at runtime. */
 128
 129 void vodxprint_fun(const char *, va_list);
 130
 131 void
 132 odxprint_fun(const char *fmt, ...)
 133 {
 134     va_list args;
 135     va_start(args, fmt);
 136     vodxprint_fun(fmt, args);
 137     va_end(args);
 138 }
 139
 140 void
 141 vodxprint_fun(const char *fmt, va_list args)
 142 {
 143 #ifdef LISP_FEATURE_WIN32
 144     DWORD lastError = GetLastError();
 145 #else
 146     int original_errno = errno;
 147 #endif
 148
 149     QSHOW_BLOCK;
 150
 151     char buf[1024];
 152
 153 #ifdef LISP_FEATURE_SB_THREAD
 154     struct thread *arch_os_get_current_thread(void);
 155     struct thread *self = arch_os_get_current_thread();
 156     void *pth = self ? (void *) self->os_thread : 0;
 157     snprintf(buf, sizeof(buf), "[%p/%p] ", self, pth);
 158 #endif
 159
 160     int n = strlen(buf);
 161     vsnprintf(buf + n, sizeof(buf) - n - 1, fmt, args);
 162     /* buf is now zero-terminated (even in case of overflow).
 163      * Our caller took care of the newline (if any) through `fmt'. */
 164
 165     /* A sufficiently POSIXy implementation of stdio will provide
 166      * per-FILE locking, as defined in the spec for flockfile.  At least
 167      * glibc complies with this.  Hence we do not need to perform
 168      * locking ourselves here.  (Should it turn out, of course, that
 169      * other libraries opt for speed rather than safety, we need to
 170      * revisit this decision.) */
 171     fputs(buf, stderr);
 172
 173 #ifdef LISP_FEATURE_WIN32
 174     /* stdio's stderr is line-bufferred, i.e. \n ought to flush it.
 175      * Unfortunately, MinGW does not behave the way I would expect it
 176      * to.  Let's be safe: */
 177     fflush(stderr);
 178 #endif
 179
 180     QSHOW_UNBLOCK;
 181
 182 #ifdef LISP_FEATURE_WIN32
 183     SetLastError(lastError);
 184 #else
 185     errno = original_errno;
 186 #endif
 187 }
 188
 189 /* Translate the rather awkward syntax
 190  *   FSHOW((stderr, "xyz"))
 191  * into the new and cleaner
 192  *   odxprint("xyz").
 193  * If we were willing to clean up all existing call sites, we could remove
 194  * this wrapper function.  (This is a function, because I don't know how to
 195  * strip the extra parens in a macro.) */
 196 void
 197 fshow_fun(void __attribute__((__unused__)) *ignored,
 198           const char *fmt,
 199           ...)
 200 {
 201     va_list args;
 202     va_start(args, fmt);
 203     vodxprint_fun(fmt, args);
 204     va_end(args);
 205 }
 206
 207 /* This file can be skipped if we're not supporting LDB. */
 208 #if defined(LISP_FEATURE_SB_LDB)
 209
 210 #include "monitor.h"
 211 #include "vars.h"
 212 #include "os.h"
 213 #ifdef LISP_FEATURE_GENCGC
 214 #include "gencgc-alloc-region.h" /* genesis/thread.h needs this */
 215 #endif
 216 #include "genesis/static-symbols.h"
 217 #include "genesis/primitive-objects.h"
 218 #include "genesis/static-symbols.h"
 219 #include "genesis/tagnames.h"
 220
 221 static int max_lines = 20, cur_lines = 0;
 222 static int max_depth = 5, brief_depth = 2, cur_depth = 0;
 223 static int max_length = 5;
 224 static boolean dont_descend = 0, skip_newline = 0;
 225 static int cur_clock = 0;
 226
 227 static void print_obj(char *prefix, lispobj obj);
 228
 229 #define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return;
 230
 231 static void indent(int in)
 232 {
 233     static char *spaces = "                                                                ";
 234
 235     while (in > 64) {
 236         fputs(spaces, stdout);
 237         in -= 64;
 238     }
 239     if (in != 0)
 240         fputs(spaces + 64 - in, stdout);
 241 }
 242
 243 static boolean continue_p(boolean newline)
 244 {
 245     char buffer[256];
 246
 247     if (cur_depth >= max_depth || dont_descend)
 248         return 0;
 249
 250     if (newline) {
 251         if (skip_newline)
 252             skip_newline = 0;
 253         else
 254             putchar('\n');
 255
 256         if (cur_lines >= max_lines) {
 257             printf("More? [y] ");
 258             fflush(stdout);
 259
 260             if (fgets(buffer, sizeof(buffer), stdin)) {
 261                 if (buffer[0] == 'n' || buffer[0] == 'N')
 262                     throw_to_monitor();
 263                 else
 264                     cur_lines = 0;
 265             } else {
 266                 printf("\nUnable to read response, assuming y.\n");
 267                 cur_lines = 0;
 268             }
 269         }
 270     }
 271
 272     return 1;
 273 }
 274
 275 static void newline(char *label)
 276 {
 277     cur_lines++;
 278     if (label != NULL)
 279         fputs(label, stdout);
 280     putchar('\t');
 281     indent(cur_depth * 2);
 282 }
 283
 284
 285 static void print_unknown(lispobj obj)
 286 {
 287   printf("unknown object: %p", (void *)obj);
 288 }
 289
 290 static void brief_fixnum(lispobj obj)
 291 {
 292     /* KLUDGE: Rather than update the tables in print_obj(), we
 293        declare all fixnum-or-unknown tags to be fixnums and sort it
 294        out here with a guard clause. */
 295     if (!fixnump(obj)) return print_unknown(obj);
 296
 297 #ifndef LISP_FEATURE_ALPHA
 298     printf("%ld", ((long)obj)>>2);
 299 #else
 300     printf("%d", ((s32)obj)>>2);
 301 #endif
 302 }
 303
 304 static void print_fixnum(lispobj obj)
 305 {
 306     /* KLUDGE: Rather than update the tables in print_obj(), we
 307        declare all fixnum-or-unknown tags to be fixnums and sort it
 308        out here with a guard clause. */
 309     if (!fixnump(obj)) return print_unknown(obj);
 310
 311 #ifndef LISP_FEATURE_ALPHA
 312     printf(": %ld", ((long)obj)>>2);
 313 #else
 314     printf(": %d", ((s32)obj)>>2);
 315 #endif
 316 }
 317
 318 static void brief_otherimm(lispobj obj)
 319 {
 320     int type, c;
 321     char buffer[10];
 322
 323     type = widetag_of(obj);
 324     switch (type) {
 325         case CHARACTER_WIDETAG:
 326             c = (obj>>8)&0xff;
 327             switch (c) {
 328                 case '\0':
 329                     printf("#\\Null");
 330                     break;
 331                 case '\n':
 332                     printf("#\\Newline");
 333                     break;
 334                 case '\b':
 335                     printf("#\\Backspace");
 336                     break;
 337                 case '\177':
 338                     printf("#\\Delete");
 339                     break;
 340                 default:
 341                     strcpy(buffer, "#\\");
 342                     if (c >= 128) {
 343                         strcat(buffer, "m-");
 344                         c -= 128;
 345                     }
 346                     if (c < 32) {
 347                         strcat(buffer, "c-");
 348                         c += '@';
 349                     }
 350                     printf("%s%c", buffer, c);
 351                     break;
 352             }
 353             break;
 354
 355         case UNBOUND_MARKER_WIDETAG:
 356             printf("<unbound marker>");
 357             break;
 358
 359         default:
 360             printf("%s", widetag_names[type >> 2]);
 361             break;
 362     }
 363 }
 364
 365 static void print_otherimm(lispobj obj)
 366 {
 367     printf(", %s", widetag_names[widetag_of(obj) >> 2]);
 368
 369     switch (widetag_of(obj)) {
 370         case CHARACTER_WIDETAG:
 371             printf(": ");
 372             brief_otherimm(obj);
 373             break;
 374
 375         case SAP_WIDETAG:
 376         case UNBOUND_MARKER_WIDETAG:
 377             break;
 378
 379         default:
 380             printf(": data=%ld", (long) (obj>>8)&0xffffff);
 381             break;
 382     }
 383 }
 384
 385 static void brief_list(lispobj obj)
 386 {
 387     int space = 0;
 388     int length = 0;
 389
 390     if (!is_valid_lisp_addr((os_vm_address_t)native_pointer(obj)))
 391         printf("(invalid Lisp-level address)");
 392     else if (obj == NIL)
 393         printf("NIL");
 394     else {
 395         putchar('(');
 396         while (lowtag_of(obj) == LIST_POINTER_LOWTAG) {
 397             struct cons *cons = (struct cons *)native_pointer(obj);
 398
 399             if (space)
 400                 putchar(' ');
 401             if (++length >= max_length) {
 402                 printf("...");
 403                 obj = NIL;
 404                 break;
 405             }
 406             print_obj("", cons->car);
 407             obj = cons->cdr;
 408             space = 1;
 409             if (obj == NIL)
 410                 break;
 411         }
 412         if (obj != NIL) {
 413             printf(" . ");
 414             print_obj("", obj);
 415         }
 416         putchar(')');
 417     }
 418 }
 419
 420 static void print_list(lispobj obj)
 421 {
 422     if (!is_valid_lisp_addr((os_vm_address_t)native_pointer(obj))) {
 423         printf("(invalid address)");
 424     } else if (obj == NIL) {
 425         printf(" (NIL)");
 426     } else {
 427         struct cons *cons = (struct cons *)native_pointer(obj);
 428
 429         print_obj("car: ", cons->car);
 430         print_obj("cdr: ", cons->cdr);
 431     }
 432 }
 433
 434 static void brief_struct(lispobj obj)
 435 {
 436     struct instance *instance = (struct instance *)native_pointer(obj);
 437     if (!is_valid_lisp_addr((os_vm_address_t)instance)) {
 438         printf("(invalid address)");
 439     } else {
 440         printf("#<ptr to 0x%08lx instance>",
 441                (unsigned long) instance->slots[0]);
 442     }
 443 }
 444
 445 static void print_struct(lispobj obj)
 446 {
 447     struct instance *instance = (struct instance *)native_pointer(obj);
 448     unsigned int i;
 449     char buffer[16];
 450     if (!is_valid_lisp_addr((os_vm_address_t)instance)) {
 451         printf("(invalid address)");
 452     } else {
 453         print_obj("type: ", ((struct instance *)native_pointer(obj))->slots[0]);
 454         for (i = 1; i < HeaderValue(instance->header); i++) {
 455             sprintf(buffer, "slot %d: ", i);
 456             print_obj(buffer, instance->slots[i]);
 457         }
 458     }
 459 }
 460
 461 static void brief_otherptr(lispobj obj)
 462 {
 463     lispobj *ptr, header;
 464     int type;
 465     struct symbol *symbol;
 466     struct vector *vector;
 467     char *charptr;
 468
 469     ptr = (lispobj *) native_pointer(obj);
 470
 471     if (!is_valid_lisp_addr((os_vm_address_t)obj)) {
 472             printf("(invalid address)");
 473             return;
 474     }
 475
 476     header = *ptr;
 477     type = widetag_of(header);
 478     switch (type) {
 479         case SYMBOL_HEADER_WIDETAG:
 480             symbol = (struct symbol *)ptr;
 481             vector = (struct vector *)native_pointer(symbol->name);
 482             for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
 483                 if (*charptr == '"')
 484                     putchar('\\');
 485                 putchar(*charptr);
 486             }
 487             break;
 488
 489         case SIMPLE_BASE_STRING_WIDETAG:
 490             vector = (struct vector *)ptr;
 491             putchar('"');
 492             for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
 493                 if (*charptr == '"')
 494                     putchar('\\');
 495                 putchar(*charptr);
 496             }
 497             putchar('"');
 498             break;
 499
 500         default:
 501             printf("#<ptr to ");
 502             brief_otherimm(header);
 503             putchar('>');
 504     }
 505 }
 506
 507 static void print_slots(char **slots, int count, lispobj *ptr)
 508 {
 509     while (count-- > 0) {
 510         if (*slots) {
 511             print_obj(*slots++, *ptr++);
 512         } else {
 513             print_obj("???: ", *ptr++);
 514         }
 515     }
 516 }
 517
 518 /* FIXME: Yikes! This needs to depend on the values in sbcl.h (or
 519  * perhaps be generated automatically by GENESIS as part of
 520  * sbcl.h). */
 521 static char *symbol_slots[] = {"value: ", "hash: ",
 522     "plist: ", "name: ", "package: ",
 523 #ifdef LISP_FEATURE_SB_THREAD
 524     "tls-index: " ,
 525 #endif
 526     NULL};
 527 static char *ratio_slots[] = {"numer: ", "denom: ", NULL};
 528 static char *complex_slots[] = {"real: ", "imag: ", NULL};
 529 static char *code_slots[] = {"words: ", "entry: ", "debug: ", NULL};
 530 static char *fn_slots[] = {
 531     "self: ", "next: ", "name: ", "arglist: ", "type: ", NULL};
 532 static char *closure_slots[] = {"fn: ", NULL};
 533 static char *funcallable_instance_slots[] = {"fn: ", "lexenv: ", "layout: ", NULL};
 534 static char *weak_pointer_slots[] = {"value: ", NULL};
 535 static char *fdefn_slots[] = {"name: ", "function: ", "raw_addr: ", NULL};
 536 static char *value_cell_slots[] = {"value: ", NULL};
 537
 538 static void print_otherptr(lispobj obj)
 539 {
 540     if (!is_valid_lisp_addr((os_vm_address_t)obj)) {
 541         printf("(invalid address)");
 542     } else {
 543 #ifndef LISP_FEATURE_ALPHA
 544         lispobj *ptr;
 545         unsigned long header;
 546         unsigned long length;
 547 #else
 548         u32 *ptr;
 549         u32 header;
 550         u32 length;
 551 #endif
 552         int count, type, index;
 553         char *cptr, buffer[16];
 554
 555         ptr = (lispobj*) native_pointer(obj);
 556         if (ptr == NULL) {
 557                 printf(" (NULL Pointer)");
 558                 return;
 559         }
 560
 561         header = *ptr++;
 562         length = fixnum_value(*ptr);
 563         count = HeaderValue(header);
 564         type = widetag_of(header);
 565
 566         print_obj("header: ", header);
 567         if (!other_immediate_lowtag_p(header)) {
 568             NEWLINE_OR_RETURN;
 569             printf("(invalid header object)");
 570             return;
 571         }
 572
 573         switch (type) {
 574             case BIGNUM_WIDETAG:
 575                 ptr += count;
 576                 NEWLINE_OR_RETURN;
 577                 printf("0x");
 578                 while (count-- > 0)
 579                     printf("%08lx", (unsigned long) *--ptr);
 580                 break;
 581
 582             case RATIO_WIDETAG:
 583                 print_slots(ratio_slots, count, ptr);
 584                 break;
 585
 586             case COMPLEX_WIDETAG:
 587                 print_slots(complex_slots, count, ptr);
 588                 break;
 589
 590             case SYMBOL_HEADER_WIDETAG:
 591                 print_slots(symbol_slots, count, ptr);
 592                 break;
 593
 594 #if N_WORD_BITS == 32
 595             case SINGLE_FLOAT_WIDETAG:
 596                 NEWLINE_OR_RETURN;
 597                 printf("%g", ((struct single_float *)native_pointer(obj))->value);
 598                 break;
 599 #endif
 600             case DOUBLE_FLOAT_WIDETAG:
 601                 NEWLINE_OR_RETURN;
 602                 printf("%g", ((struct double_float *)native_pointer(obj))->value);
 603                 break;
 604
 605 #ifdef LONG_FLOAT_WIDETAG
 606             case LONG_FLOAT_WIDETAG:
 607                 NEWLINE_OR_RETURN;
 608                 printf("%Lg", ((struct long_float *)native_pointer(obj))->value);
 609                 break;
 610 #endif
 611
 612 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
 613             case COMPLEX_SINGLE_FLOAT_WIDETAG:
 614                 NEWLINE_OR_RETURN;
 615 #ifdef LISP_FEATURE_X86_64
 616                 printf("%g", ((struct complex_single_float *)native_pointer(obj))->data.data[0]);
 617 #else
 618                 printf("%g", ((struct complex_single_float *)native_pointer(obj))->real);
 619 #endif
 620                 NEWLINE_OR_RETURN;
 621 #ifdef LISP_FEATURE_X86_64
 622                 printf("%g", ((struct complex_single_float *)native_pointer(obj))->data.data[1]);
 623 #else
 624                 printf("%g", ((struct complex_single_float *)native_pointer(obj))->imag);
 625 #endif
 626                 break;
 627 #endif
 628
 629 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
 630             case COMPLEX_DOUBLE_FLOAT_WIDETAG:
 631                 NEWLINE_OR_RETURN;
 632                 printf("%g", ((struct complex_double_float *)native_pointer(obj))->real);
 633                 NEWLINE_OR_RETURN;
 634                 printf("%g", ((struct complex_double_float *)native_pointer(obj))->imag);
 635                 break;
 636 #endif
 637
 638 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
 639             case COMPLEX_LONG_FLOAT_WIDETAG:
 640                 NEWLINE_OR_RETURN;
 641                 printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->real);
 642                 NEWLINE_OR_RETURN;
 643                 printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->imag);
 644                 break;
 645 #endif
 646
 647             case SIMPLE_BASE_STRING_WIDETAG:
 648 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
 649         case SIMPLE_CHARACTER_STRING_WIDETAG: /* FIXME */
 650 #endif
 651                 NEWLINE_OR_RETURN;
 652                 cptr = (char *)(ptr+1);
 653                 putchar('"');
 654                 while (length-- > 0)
 655                     putchar(*cptr++);
 656                 putchar('"');
 657                 break;
 658
 659             case SIMPLE_VECTOR_WIDETAG:
 660                 NEWLINE_OR_RETURN;
 661                 printf("length = %ld", length);
 662                 ptr++;
 663                 index = 0;
 664                 while (length-- > 0) {
 665                     sprintf(buffer, "%d: ", index++);
 666                     print_obj(buffer, *ptr++);
 667                 }
 668                 break;
 669
 670             case INSTANCE_HEADER_WIDETAG:
 671                 NEWLINE_OR_RETURN;
 672                 printf("length = %ld", (long) count);
 673                 index = 0;
 674                 while (count-- > 0) {
 675                     sprintf(buffer, "%d: ", index++);
 676                     print_obj(buffer, *ptr++);
 677                 }
 678                 break;
 679
 680             case SIMPLE_ARRAY_WIDETAG:
 681             case SIMPLE_BIT_VECTOR_WIDETAG:
 682             case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG:
 683             case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG:
 684             case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG:
 685             case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG:
 686             case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG:
 687             case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG:
 688
 689             case SIMPLE_ARRAY_UNSIGNED_FIXNUM_WIDETAG:
 690
 691             case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG:
 692             case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
 693 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
 694             case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG:
 695 #endif
 696 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
 697             case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG:
 698 #endif
 699 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
 700             case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG:
 701 #endif
 702 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
 703             case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG:
 704 #endif
 705
 706             case SIMPLE_ARRAY_FIXNUM_WIDETAG:
 707
 708 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
 709             case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG:
 710 #endif
 711 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
 712             case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG:
 713 #endif
 714             case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG:
 715             case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG:
 716 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
 717             case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG:
 718 #endif
 719 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
 720             case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG:
 721 #endif
 722 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
 723             case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG:
 724 #endif
 725 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
 726             case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG:
 727 #endif
 728             case COMPLEX_BASE_STRING_WIDETAG:
 729 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
 730         case COMPLEX_CHARACTER_STRING_WIDETAG:
 731 #endif
 732             case COMPLEX_VECTOR_NIL_WIDETAG:
 733             case COMPLEX_BIT_VECTOR_WIDETAG:
 734             case COMPLEX_VECTOR_WIDETAG:
 735             case COMPLEX_ARRAY_WIDETAG:
 736                 break;
 737
 738             case CODE_HEADER_WIDETAG:
 739                 print_slots(code_slots, count-1, ptr);
 740                 break;
 741
 742             case SIMPLE_FUN_HEADER_WIDETAG:
 743                 print_slots(fn_slots, 5, ptr);
 744                 break;
 745
 746             case RETURN_PC_HEADER_WIDETAG:
 747                 print_obj("code: ", obj - (count * 4));
 748                 break;
 749
 750             case CLOSURE_HEADER_WIDETAG:
 751                 print_slots(closure_slots, count, ptr);
 752                 break;
 753
 754             case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
 755                 print_slots(funcallable_instance_slots, count, ptr);
 756                 break;
 757
 758             case VALUE_CELL_HEADER_WIDETAG:
 759                 print_slots(value_cell_slots, 1, ptr);
 760                 break;
 761
 762             case SAP_WIDETAG:
 763                 NEWLINE_OR_RETURN;
 764 #ifndef LISP_FEATURE_ALPHA
 765                 printf("0x%08lx", (unsigned long) *ptr);
 766 #else
 767                 printf("0x%016lx", *(lispobj*)(ptr+1));
 768 #endif
 769                 break;
 770
 771             case WEAK_POINTER_WIDETAG:
 772                 print_slots(weak_pointer_slots, 1, ptr);
 773                 break;
 774
 775             case CHARACTER_WIDETAG:
 776             case UNBOUND_MARKER_WIDETAG:
 777                 NEWLINE_OR_RETURN;
 778                 printf("pointer to an immediate?");
 779                 break;
 780
 781             case FDEFN_WIDETAG:
 782                 print_slots(fdefn_slots, count, ptr);
 783                 break;
 784
 785             default:
 786                 NEWLINE_OR_RETURN;
 787                 printf("Unknown header object?");
 788                 break;
 789         }
 790     }
 791 }
 792
 793 static void print_obj(char *prefix, lispobj obj)
 794 {
 795 #ifdef LISP_FEATURE_X86_64
 796     static void (*verbose_fns[])(lispobj obj)
 797         = {print_fixnum, print_otherimm, print_fixnum, print_struct,
 798            print_fixnum, print_otherimm, print_fixnum, print_list,
 799            print_fixnum, print_otherimm, print_fixnum, print_otherptr,
 800            print_fixnum, print_otherimm, print_fixnum, print_otherptr};
 801     static void (*brief_fns[])(lispobj obj)
 802         = {brief_fixnum, brief_otherimm, brief_fixnum, brief_struct,
 803            brief_fixnum, brief_otherimm, brief_fixnum, brief_list,
 804            brief_fixnum, brief_otherimm, brief_fixnum, brief_otherptr,
 805            brief_fixnum, brief_otherimm, brief_fixnum, brief_otherptr};
 806 #else
 807     static void (*verbose_fns[])(lispobj obj)
 808         = {print_fixnum, print_struct, print_otherimm, print_list,
 809            print_fixnum, print_otherptr, print_otherimm, print_otherptr};
 810     static void (*brief_fns[])(lispobj obj)
 811         = {brief_fixnum, brief_struct, brief_otherimm, brief_list,
 812            brief_fixnum, brief_otherptr, brief_otherimm, brief_otherptr};
 813 #endif
 814     int type = lowtag_of(obj);
 815     struct var *var = lookup_by_obj(obj);
 816     char buffer[256];
 817     boolean verbose = cur_depth < brief_depth;
 818
 819     if (!continue_p(verbose))
 820         return;
 821
 822     if (var != NULL && var_clock(var) == cur_clock)
 823         dont_descend = 1;
 824
 825     if (var == NULL && is_lisp_pointer(obj))
 826         var = define_var(NULL, obj, 0);
 827
 828     if (var != NULL)
 829         var_setclock(var, cur_clock);
 830
 831     cur_depth++;
 832     if (verbose) {
 833         if (var != NULL) {
 834             sprintf(buffer, "$%s=", var_name(var));
 835             newline(buffer);
 836         }
 837         else
 838             newline(NULL);
 839         printf("%s0x%08lx: ", prefix, (unsigned long) obj);
 840         if (cur_depth < brief_depth) {
 841             fputs(lowtag_names[type], stdout);
 842             (*verbose_fns[type])(obj);
 843         }
 844         else
 845             (*brief_fns[type])(obj);
 846     }
 847     else {
 848         if (dont_descend)
 849             printf("$%s", var_name(var));
 850         else {
 851             if (var != NULL)
 852                 printf("$%s=", var_name(var));
 853             (*brief_fns[type])(obj);
 854         }
 855     }
 856     cur_depth--;
 857     dont_descend = 0;
 858 }
 859
 860 void reset_printer()
 861 {
 862     cur_clock++;
 863     cur_lines = 0;
 864     dont_descend = 0;
 865 }
 866
 867 void print(lispobj obj)
 868 {
 869     skip_newline = 1;
 870     cur_depth = 0;
 871     max_depth = 5;
 872     max_lines = 20;
 873
 874     print_obj("", obj);
 875
 876     putchar('\n');
 877 }
 878
 879 void brief_print(lispobj obj)
 880 {
 881     skip_newline = 1;
 882     cur_depth = 0;
 883     max_depth = 1;
 884     max_lines = 5000;
 885     cur_lines = 0;
 886
 887     print_obj("", obj);
 888     putchar('\n');
 889 }
 890
 891 #else
 892
 893 void
 894 brief_print(lispobj obj)
 895 {
 896     printf("lispobj 0x%lx\n", (unsigned long)obj);
 897 }
 898
 899 #endif /* defined(LISP_FEATURE_SB_LDB) */