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