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