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