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