?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Combine multiple BINDs.
[sbcl.git] / src / runtime / print.c
blob006536ba75cfd3b24c93c5d02d214d48fdf09129
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 #include <stdio.h>
15 #include <string.h>
16
17 #include "genesis/sbcl.h"
18 #include "print.h"
19 #include "runtime.h"
20 #include "code.h"
21 #include "gc.h"
22 #include "genesis/gc-tables.h"
23 #include "thread.h"
24 #include <errno.h>
25 #include <stdlib.h>
26 #include <inttypes.h>
27 #include <setjmp.h>
28
29 struct dyndebug_config dyndebug_config;
30
31 void
32 dyndebug_init()
33 {
34 #define DYNDEBUG_NFLAGS (sizeof(struct dyndebug_config) / sizeof(int))
35 #define dyndebug_init1(lowercase, uppercase) \
36 do { \
37 int *ptr = &dyndebug_config.dyndebug_##lowercase; \
38 ptrs[n] = ptr; \
39 names[n] = #lowercase; \
40 char *val = getenv("SBCL_DYNDEBUG__" uppercase); \
41 *ptr = val && strlen(val); \
42 n++; \
43 } while (0)
44 int n = 0;
45 char *names[DYNDEBUG_NFLAGS];
46 int *ptrs[DYNDEBUG_NFLAGS];
47
48 dyndebug_init1(gencgc_verbose, "GENCGC_VERBOSE");
49 dyndebug_init1(safepoints, "SAFEPOINTS");
50 dyndebug_init1(seh, "SEH");
51 dyndebug_init1(misc, "MISC");
52 dyndebug_init1(pagefaults, "PAGEFAULTS");
53 dyndebug_init1(io, "IO");
54 dyndebug_init1(runtime_link, "RUNTIME_LINK");
55
56 int n_output_flags = n;
57 dyndebug_init1(backtrace_when_lost, "BACKTRACE_WHEN_LOST");
58 dyndebug_init1(sleep_when_lost, "SLEEP_WHEN_LOST");
59
60 if (n != DYNDEBUG_NFLAGS)
61 fprintf(stderr, "Bug in dyndebug_init\n");
62
63 char *featurelist = getenv("SBCL_DYNDEBUG");
64 if (featurelist) {
65 int err = 0;
66 featurelist = strdup(featurelist);
67 char *ptr = featurelist;
68 for (;;) {
69 char *token = strtok(ptr, " ");
70 if (!token) break;
71 int i;
72 if (!strcmp(token, "all"))
73 for (i = 0; i < n_output_flags; i++)
74 *ptrs[i] = 1;
75 else {
76 for (i = 0; i < (int)DYNDEBUG_NFLAGS; i++)
77 if (!strcmp(token, names[i])) {
78 *ptrs[i] = 1;
79 break;
80 }
81 if (i == DYNDEBUG_NFLAGS) {
82 fprintf(stderr, "No such dyndebug flag: `%s'\n", token);
83 err = 1;
84 }
85 }
86 ptr = 0;
87 }
88 free(featurelist);
89 if (err) {
90 fprintf(stderr, "Valid flags are:\n");
91 fprintf(stderr, " all ;enables all of the following:\n");
92 int i;
93 for (i = 0; i < (int)DYNDEBUG_NFLAGS; i++) {
94 if (i == n_output_flags)
95 fprintf(stderr, "Additional options:\n");
96 fprintf(stderr, " %s\n", names[i]);
97 }
98 }
99 }
100 #if defined(LISP_FEATURE_GENERATIONAL)
101 if (dyndebug_config.dyndebug_gencgc_verbose) {
102 gencgc_verbose = 1;
103 }
104 #endif
105
106 #undef dyndebug_init1
107 #undef DYNDEBUG_NFLAGS
108 }
109
110 #include "vars.h"
111 #include "os.h"
112 #include "genesis/static-symbols.h"
113 #include "genesis/primitive-objects.h"
114 #include "genesis/static-symbols.h"
115 #include "genesis/tagnames.h"
116
117 static int max_lines = 20, cur_lines = 0;
118 static int max_depth = 5, brief_depth = 2, cur_depth = 0;
119 static int max_length = 5;
120 static bool dont_descend = 0, skip_newline = 0;
121 static int cur_clock = 0;
122
123 static void print_obj(char *prefix, lispobj obj);
124
125 #define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return;
126
127 static void indent(int in)
128 {
129 static char *spaces = " ";
130
131 while (in > 64) {
132 fputs(spaces, stdout);
133 in -= 64;
134 }
135 if (in != 0)
136 fputs(spaces + 64 - in, stdout);
137 }
138
139 static jmp_buf ldb_print_nlx;
140 static bool continue_p(bool newline)
141 {
142 char buffer[256];
143
144 if (cur_depth >= max_depth || dont_descend)
145 return 0;
146
147 if (newline) {
148 if (skip_newline)
149 skip_newline = 0;
150 else
151 putchar('\n');
152
153 if (cur_lines >= max_lines) {
154 printf("More? [y] ");
155 fflush(stdout);
156
157 if (fgets(buffer, sizeof(buffer), stdin)) {
158 if (buffer[0] == 'n' || buffer[0] == 'N')
159 longjmp(ldb_print_nlx, 1);
160 else
161 cur_lines = 0;
162 } else {
163 printf("\nUnable to read response, assuming y.\n");
164 cur_lines = 0;
165 }
166 }
167 }
168
169 return 1;
170 }
171
172 static void newline(char *label)
173 {
174 cur_lines++;
175 if (label != NULL)
176 fputs(label, stdout);
177 putchar('\t');
178 indent(cur_depth * 2);
179 }
180
181
182 static void print_unknown(lispobj obj)
183 {
184 printf("unknown object: %p", (void *)obj);
185 }
186
187 #ifdef PRIdPTR
188 # define OBJ_FMTd PRIdPTR
189 #else
190 # error "Your inttypes.h is lame"
191 #endif
192
193 static void brief_fixnum(lispobj obj)
194 {
195 /* KLUDGE: Rather than update the tables in print_obj(), we
196 declare all fixnum-or-unknown tags to be fixnums and sort it
197 out here with a guard clause. */
198 if (!fixnump(obj)) return print_unknown(obj);
199 printf("%"OBJ_FMTd, fixnum_value(obj));
200 }
201
202 static void print_fixnum(lispobj obj)
203 {
204 /* KLUDGE: Rather than update the tables in print_obj(), we
205 declare all fixnum-or-unknown tags to be fixnums and sort it
206 out here with a guard clause. */
207 if (!fixnump(obj)) return print_unknown(obj);
208 printf(": %"OBJ_FMTd, fixnum_value(obj));
209 }
210
211 static void brief_otherimm(lispobj obj)
212 {
213 int type, c;
214 char * charname = 0;
215
216 type = header_widetag(obj);
217 switch (type) {
218 case CHARACTER_WIDETAG:
219 c = obj>>8; // no mask. show whatever's there
220 printf("#\\");
221 switch (c) {
222 case '\0': charname = "Nul"; break;
223 case '\n': charname = "Newline"; break;
224 case '\b': charname = "Backspace"; break;
225 case '\177': charname = "Delete"; break;
226 default:
227 if (c < 32) printf("^%c", c+64);
228 else printf(c < 128 ? "%c" : "U+%X", c);
229 }
230 if (charname)
231 fputs(charname, stdout);
232 break;
233
234 case UNBOUND_MARKER_WIDETAG:
235 printf("<unbound marker>");
236 break;
237
238 default:
239 printf("%s", widetag_names[type >> 2]);
240 break;
241 }
242 }
243
244 static void print_otherimm(lispobj obj)
245 {
246 printf(", %s", widetag_names[header_widetag(obj) >> 2]);
247
248 switch (header_widetag(obj)) {
249 case CHARACTER_WIDETAG:
250 printf(": ");
251 brief_otherimm(obj);
252 break;
253
254 case SAP_WIDETAG:
255 case UNBOUND_MARKER_WIDETAG:
256 break;
257
258 default:
259 printf(": data=%"OBJ_FMTX, (obj>>8));
260 break;
261 }
262 }
263
264 static void brief_list(lispobj obj)
265 {
266 int space = 0;
267 int length = 0;
268
269 if (obj == NIL)
270 printf("NIL");
271 else {
272 putchar('(');
273 while (listp(obj)) {
274 if (space)
275 putchar(' ');
276 if (++length >= max_length) {
277 printf("...");
278 obj = NIL;
279 break;
280 }
281 print_obj("", CONS(obj)->car);
282 obj = CONS(obj)->cdr;
283 space = 1;
284 if (obj == NIL)
285 break;
286 }
287 if (obj != NIL) {
288 printf(" . ");
289 print_obj("", obj);
290 }
291 putchar(')');
292 }
293 }
294
295 void print_list_car_ptrs(lispobj obj, FILE* f)
296 {
297 char sep = '(';
298 int len = 0;
299 if (obj == NIL) { fprintf(f, "NIL"); return; }
300 do {
301 if (++len > 20) { fprintf(f, "...)"); return; }
302 fprintf(f, "%c%p", sep, (void*)CONS(obj)->car);
303 obj = CONS(obj)->cdr;
304 sep = ' ';
305 } while (listp(obj) && obj != NIL);
306 if (obj != NIL) fprintf(f, " . %p", (void*)obj);
307 putc(')', f);
308 }
309
310
311 static void print_list(lispobj obj)
312 {
313 if (obj == NIL) {
314 printf(" (NIL)");
315 } else {
316 print_obj("car: ", CONS(obj)->car);
317 print_obj("cdr: ", CONS(obj)->cdr);
318 }
319 }
320
321 // takes native pointer as input
322 char * simple_base_stringize(struct vector * string)
323 {
324 if (widetag_of(&string->header) == SIMPLE_BASE_STRING_WIDETAG)
325 return (char*)string->data;
326 int length = vector_len(string);
327 char * newstring = malloc(length+1);
328 uint32_t * data = (uint32_t*)string->data;
329 int i;
330 for(i=0;i<length;++i)
331 newstring[i] = data[i] < 128 ? data[i] : '?';
332 newstring[length] = 0;
333 return newstring;
334 }
335
336 static void brief_struct(lispobj obj)
337 {
338 struct instance *instance = INSTANCE(obj);
339 extern struct vector * instance_classoid_name(lispobj*);
340 struct vector * classoid_name;
341 classoid_name = instance_classoid_name((lispobj*)instance);
342 lispobj layout = instance_layout((lispobj*)instance);
343 if ( classoid_name ) {
344 char * namestring = simple_base_stringize(classoid_name);
345 printf("#<ptr to %"OBJ_FMTX" %s instance>", layout, namestring);
346 if ( namestring != (char*)classoid_name->data )
347 free(namestring);
348 } else {
349 printf("#<ptr to %"OBJ_FMTX" instance>", layout);
350 }
351 }
352
353 #include "genesis/defstruct-description.h"
354 static bool tagged_slot_p(struct layout *layout, int slot_index)
355 {
356 // Since we're doing this scan, we could return the name
357 // and exact raw type.
358 if (instancep(layout->_info)) {
359 struct defstruct_description* dd = (void*)(layout->_info-INSTANCE_POINTER_LOWTAG);
360 lispobj slots = dd->slots;
361 for ( ; slots != NIL ; slots = CONS(slots)->cdr ) {
362 struct defstruct_slot_description* dsd =
363 (void*)(CONS(slots)->car-INSTANCE_POINTER_LOWTAG);
364 if ((fixnum_value(dsd->bits) >> DSD_INDEX_SHIFT) == slot_index)
365 return (fixnum_value(dsd->bits) & DSD_RAW_TYPE_MASK) == 0;
366 }
367 }
368 /* Revision 2b783b49 said to prefer LAYOUT-INFO vs BITMAP because the bitmap
369 * can indicate a 0 bit ("raw") for any slot that _may_ be ignored by GC, such as
370 * slots constrained to FIXNUM. Unfortunately that misses that CONDITION instances
371 * have trailing variable-length tagged data. In practice an instance may have raw
372 * words only if it has a DD, which most CONDITION subtypes do not. Therefore this
373 * could almost always return 1. But layout-of-layout is an important use of trailing
374 * raw slots. Attempting to print random words as tagged could be disastrous.
375 * Therefore, test the bitmap if the above loop failed to find slot_index. */
376 return bitmap_logbitp(slot_index, get_layout_bitmap(layout));
377 }
378
379 static void print_struct(lispobj obj)
380 {
381 struct instance *instance = INSTANCE(obj);
382 short int i;
383 char buffer[16];
384 lispobj layout = instance_layout(native_pointer(obj));
385 print_obj("type: ", layout);
386 for (i=INSTANCE_DATA_START; i<instance_length(instance->header); i++) {
387 sprintf(buffer, "slot %d: ", i);
388 if (layout && tagged_slot_p(LAYOUT(layout), i)) {
389 print_obj(buffer, instance->slots[i]);
390 } else {
391 newline(NULL);
392 printf("\n\t %s0x%"OBJ_FMTX" [raw]", buffer, instance->slots[i]);
393 }
394 }
395 }
396
397 void show_lstring(struct vector * string, int quotes, FILE *s)
398 {
399 int ucs4_p = 0;
400 int i, len = vector_len(string);
401
402 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
403 if (widetag_of(&string->header) == SIMPLE_CHARACTER_STRING_WIDETAG) {
404 ucs4_p = 1;
405 if (quotes)
406 putc('u', s); /* an arbitrary notational convention */
407 }
408 #endif
409 if (quotes) putc('"', s);
410 for (i=0 ; i<len ; i++) {
411 // hopefully the compiler will optimize out the ucs4_p test
412 // when the runtime is built without Unicode support
413 int ch;
414 if (ucs4_p)
415 ch = i[(uint32_t*)string->data];
416 else
417 ch = i[(char*)string->data];
418 if (ch >= 32 && ch < 127) {
419 if (quotes && (ch == '"' || ch == '\\'))
420 putc('\\', s);
421 putc(ch, s);
422 } else {
423 fprintf(s, ch > 0xffff ? "\\U%08X" :
424 ch > 0xff ? "\\u%04X" : "\\x%02X", ch);
425 }
426 }
427 if (quotes) putc('"', s);
428 }
429
430 static void brief_fun_or_otherptr(lispobj obj)
431 {
432 lispobj *ptr, header;
433 int type;
434 struct symbol *symbol;
435
436 ptr = native_pointer(obj);
437 header = *ptr;
438 type = header_widetag(header);
439 switch (type) {
440 case SYMBOL_WIDETAG:
441 symbol = (struct symbol *)ptr;
442 lispobj package = symbol_package(symbol);
443 if (package == NIL)
444 printf("#:");
445 show_lstring(symbol_name(symbol), 0, stdout);
446 break;
447
448 case SIMPLE_BASE_STRING_WIDETAG:
449 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
450 case SIMPLE_CHARACTER_STRING_WIDETAG:
451 #endif
452 show_lstring((struct vector*)ptr, 1, stdout);
453 break;
454
455 default:
456 printf("#<ptr to ");
457 brief_otherimm(header);
458 if (type == FDEFN_WIDETAG) { // Try to print name, if a symbol
459 // FIXME: more address validity checks perhaps?
460 lispobj name = ((struct fdefn*)ptr)->name;
461 if (lowtag_of(name) == OTHER_POINTER_LOWTAG
462 && widetag_of(native_pointer(name)) == SYMBOL_WIDETAG) {
463 printf(" for ");
464 struct vector* str = symbol_name(SYMBOL(name));
465 safely_show_lstring(str, 0, stdout);
466 }
467 }
468 putchar('>');
469 }
470 }
471
472 static void print_slots(char **slots, int count, lispobj *ptr)
473 {
474 while (count-- > 0) {
475 if (*slots) {
476 // kludge for encoded slots
477 lispobj word = *ptr;
478 char* slot_name = *slots;
479 if (N_WORD_BYTES == 8 && !strcmp(slot_name, "boxed_size: ")) word = word & 0xFFFFFFFF;
480 #ifdef LISP_FEATURE_COMPACT_SYMBOL
481 else if (!strcmp(slot_name, "name: ")) word = decode_symbol_name(word);
482 #endif
483 print_obj(slot_name, word);
484 slots++;
485 } else {
486 print_obj("???: ", *ptr);
487 }
488 ptr++;
489 }
490 }
491
492 static void print_fun_or_otherptr(lispobj obj)
493 {
494 int index;
495 char buffer[16];
496
497 lispobj *ptr = native_pointer(obj);
498 if (ptr == NULL) {
499 printf(" (NULL Pointer)");
500 return;
501 }
502
503 int count = object_size(ptr)-1;
504 uword_t header = *ptr++;
505 int type = header_widetag(header);
506
507 print_obj("header: ", header);
508 if (!other_immediate_lowtag_p(header)) {
509 NEWLINE_OR_RETURN;
510 printf("(invalid header object)");
511 return;
512 }
513
514 switch (type) {
515 case BIGNUM_WIDETAG:
516 count &= 0x7fffff;
517 ptr += count;
518 NEWLINE_OR_RETURN;
519 printf("0x");
520 while (count-- > 0)
521 printf(
522 #if N_WORD_BITS == 32
523 "%08lx%s",
524 #else
525 "%016lx%s",
526 #endif
527 (unsigned long) *--ptr, (count?"_":""));
528 break;
529
530 case RATIO_WIDETAG:
531 print_slots(ratio_slots, count, ptr);
532 break;
533
534 case COMPLEX_RATIONAL_WIDETAG:
535 print_slots(complex_slots, count, ptr);
536 break;
537
538 case SYMBOL_WIDETAG:
539 // Only 1 byte of a symbol header conveys its size.
540 // The other bytes may be freely used by the backend.
541 print_slots(symbol_slots, count & 0xFF, ptr);
542 struct symbol* sym = (void*)(ptr - 1);
543 if (symbol_function(sym) != NIL) print_obj("fun: ", symbol_function(sym));
544 #ifdef LISP_FEATURE_SB_THREAD
545 int tlsindex = tls_index_of(sym);
546 struct thread*th = get_sb_vm_thread();
547 if (th != 0 && tlsindex != 0) {
548 lispobj v = *(lispobj*)(tlsindex + (char*)th);
549 print_obj("tlsval: ", v);
550 }
551 #endif
552 #ifdef LISP_FEATURE_COMPACT_SYMBOL
553 // print_obj doesn't understand raw words, so make it a fixnum
554 int pkgid = symbol_package_id(sym) << N_FIXNUM_TAG_BITS;
555 print_obj("pkgid: ", pkgid);
556 #endif
557 break;
558
559 #if N_WORD_BITS == 32
560 case SINGLE_FLOAT_WIDETAG:
561 NEWLINE_OR_RETURN;
562 printf("%g", ((struct single_float *)native_pointer(obj))->value);
563 break;
564 #endif
565 case DOUBLE_FLOAT_WIDETAG:
566 NEWLINE_OR_RETURN;
567 printf("%g", ((struct double_float *)native_pointer(obj))->value);
568 break;
569
570 #ifdef LONG_FLOAT_WIDETAG
571 case LONG_FLOAT_WIDETAG:
572 NEWLINE_OR_RETURN;
573 printf("%Lg", ((struct long_float *)native_pointer(obj))->value);
574 break;
575 #endif
576
577 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
578 case COMPLEX_SINGLE_FLOAT_WIDETAG:
579 NEWLINE_OR_RETURN;
580 #ifdef LISP_FEATURE_64_BIT
581 printf("%g", ((struct complex_single_float *)native_pointer(obj))->data.data[0]);
582 #else
583 printf("%g", ((struct complex_single_float *)native_pointer(obj))->real);
584 #endif
585 NEWLINE_OR_RETURN;
586 #ifdef LISP_FEATURE_64_BIT
587 printf("%g", ((struct complex_single_float *)native_pointer(obj))->data.data[1]);
588 #else
589 printf("%g", ((struct complex_single_float *)native_pointer(obj))->imag);
590 #endif
591 break;
592 #endif
593
594 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
595 case COMPLEX_DOUBLE_FLOAT_WIDETAG:
596 NEWLINE_OR_RETURN;
597 printf("%g", ((struct complex_double_float *)native_pointer(obj))->real);
598 NEWLINE_OR_RETURN;
599 printf("%g", ((struct complex_double_float *)native_pointer(obj))->imag);
600 break;
601 #endif
602
603 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
604 case COMPLEX_LONG_FLOAT_WIDETAG:
605 NEWLINE_OR_RETURN;
606 printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->real);
607 NEWLINE_OR_RETURN;
608 printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->imag);
609 break;
610 #endif
611
612 case SIMPLE_BASE_STRING_WIDETAG:
613 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
614 case SIMPLE_CHARACTER_STRING_WIDETAG:
615 #endif
616 NEWLINE_OR_RETURN;
617 show_lstring((struct vector*)native_pointer(obj), 1, stdout);
618 break;
619
620 case SIMPLE_VECTOR_WIDETAG:
621 NEWLINE_OR_RETURN;
622 {
623 long length = vector_len(VECTOR(obj));
624 printf("length = %ld", length);
625 ptr++;
626 index = 0;
627 while (length-- > 0) {
628 sprintf(buffer, "%d: ", index++);
629 print_obj(buffer, *ptr++);
630 }
631 }
632 break;
633
634 case SIMPLE_BIT_VECTOR_WIDETAG:
635 NEWLINE_OR_RETURN;
636 {
637 long length = vector_len(VECTOR(obj));
638 printf("length = %ld : ", length);
639 int bits_to_print = (length < N_WORD_BITS) ? length : N_WORD_BITS;
640 uword_t word = ptr[1];
641 int i;
642 for(i=0; i<bits_to_print; ++i) {
643 putchar((word & 1) ? '1' : '0');
644 if ((i%8)==7) putchar('_');
645 word >>= 1;
646 }
647 if(bits_to_print < length) printf("...");
648 printf("\n");
649 }
650 break;
651
652 case CODE_HEADER_WIDETAG:
653 // ptr was already bumped up
654 count = code_header_words((struct code*)(ptr-1));
655 for_each_simple_fun(fun_index, fun, (struct code*)(ptr-1), 0, {
656 sprintf(buffer, "f[%d]: ", fun_index);
657 print_obj(buffer, make_lispobj(fun,FUN_POINTER_LOWTAG));
658 });
659 print_slots(code_slots, count-1, ptr);
660 break;
661
662 case SIMPLE_FUN_WIDETAG:
663 print_obj("code: ", fun_code_tagged(ptr-1));
664 print_slots(simple_fun_slots,
665 sizeof simple_fun_slots/sizeof(char*)-1, ptr);
666 break;
667
668 #ifdef RETURN_PC_WIDETAG
669 case RETURN_PC_WIDETAG:
670 print_obj("code: ", obj - (count * 4));
671 break;
672 #endif
673
674 case CLOSURE_WIDETAG:
675 print_slots(closure_slots,
676 count & SHORT_HEADER_MAX_WORDS, ptr);
677 break;
678
679 case FUNCALLABLE_INSTANCE_WIDETAG:
680 print_slots(funcallable_instance_slots,
681 count & SHORT_HEADER_MAX_WORDS, ptr);
682 break;
683
684 case VALUE_CELL_WIDETAG:
685 print_slots(value_cell_slots, 1, ptr);
686 break;
687
688 case SAP_WIDETAG:
689 NEWLINE_OR_RETURN;
690 printf("%p", (void*)*ptr);
691 break;
692
693 case WEAK_POINTER_WIDETAG:
694 print_slots(weak_pointer_slots, 1, ptr);
695 break;
696
697 case CHARACTER_WIDETAG:
698 case UNBOUND_MARKER_WIDETAG:
699 NEWLINE_OR_RETURN;
700 printf("pointer to an immediate?");
701 break;
702
703 case FDEFN_WIDETAG:
704 print_slots(fdefn_slots, 2, ptr);
705 print_obj("entry: ", decode_fdefn_rawfun((struct fdefn*)(ptr-1)));
706 break;
707
708 // Make some vectors printable from C, for when all hell breaks lose
709 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG:
710 NEWLINE_OR_RETURN;
711 {
712 long length = vector_len(VECTOR(obj));
713 uint32_t * data = (uint32_t*)(ptr + 1);
714 long i;
715 printf("#(");
716 for (i=0; i<length; ++i) {
717 printf("%s%d", i>0?" ":"", data[i]);
718 if(i==255 && length>256) { printf(" ..."); break; }
719 }
720 printf(")");
721 }
722 break;
723 default:
724 NEWLINE_OR_RETURN;
725 if (specialized_vector_widetag_p(type))
726 printf("length = %"OBJ_FMTd, vector_len(VECTOR(obj)));
727 else
728 printf("Unknown header object?");
729 break;
730 }
731 }
732
733 static void print_obj(char *prefix, lispobj obj)
734 {
735 #include "genesis/print.inc"
736 int type = lowtag_of(obj);
737 struct var *var = lookup_by_obj(obj);
738 char buffer[256];
739 bool verbose = cur_depth < brief_depth;
740
741 if (!continue_p(verbose))
742 return;
743
744 if (var != NULL && var_clock(var) == cur_clock)
745 dont_descend = 1;
746
747 if (var == NULL && is_lisp_pointer(obj))
748 var = define_var(NULL, obj, 0);
749
750 if (var != NULL)
751 var_setclock(var, cur_clock);
752
753 void (**fns)(lispobj) = NULL;
754 cur_depth++;
755 if (verbose) {
756 if (var != NULL) {
757 sprintf(buffer, "$%s=", var_name(var));
758 newline(buffer);
759 }
760 else
761 newline(NULL);
762 printf("%s0x%08lx: ", prefix, (unsigned long) obj);
763 if (cur_depth < brief_depth) {
764 fputs(lowtag_names[type], stdout);
765 fns = print_fns;
766 }
767 else
768 fns = brief_fns;
769 }
770 else {
771 if (dont_descend)
772 printf("$%s", var_name(var));
773 else {
774 if (var != NULL)
775 printf("$%s=", var_name(var));
776 fns = brief_fns;
777 }
778 }
779 if (!fns)
780 ;
781 else if (is_lisp_pointer(obj) && !gc_managed_addr_p(obj))
782 printf("(bad-address)");
783 else
784 (*fns[type])(obj);
785 cur_depth--;
786 dont_descend = 0;
787 }
788
789 void reset_printer()
790 {
791 cur_clock++;
792 cur_lines = 0;
793 dont_descend = 0;
794 }
795
796 void print(lispobj obj)
797 {
798 skip_newline = 1;
799 cur_depth = 0;
800 max_depth = 5;
801 max_lines = 20;
802
803 if (!setjmp(ldb_print_nlx))
804 print_obj("", obj);
805
806 putchar('\n');
807 }
808
809 void brief_print(lispobj obj)
810 {
811 skip_newline = 1;
812 cur_depth = 0;
813 max_depth = 1;
814 max_lines = 5000;
815 cur_lines = 0;
816
817 print_obj("", obj);
818 putchar('\n');
819 }
820
821 // The following accessors, which take a valid native pointer as input
822 // and return a Lisp string, are designed to be foolproof during GC,
823 // hence all the forwarding checks.
824
825 struct vector * symbol_name(struct symbol* sym)
826 {
827 if (forwarding_pointer_p((lispobj*)sym))
828 sym = (void*)native_pointer(forwarding_pointer_value((lispobj*)sym));
829 lispobj name = sym->name;
830 if (lowtag_of(name) != OTHER_POINTER_LOWTAG) return NULL;
831 lispobj string = decode_symbol_name(name);
832 return VECTOR(follow_fp(string)); // can't have a nameless symbol
833 }
834 struct vector * classoid_name(lispobj * classoid)
835 {
836 if (forwarding_pointer_p(classoid))
837 classoid = native_pointer(forwarding_pointer_value(classoid));
838 // Classoids are named by symbols even though a CLASS name is arbitrary (theoretically)
839 lispobj sym = ((struct classoid*)classoid)->name;
840 return lowtag_of(sym) != OTHER_POINTER_LOWTAG ? NULL : symbol_name(SYMBOL(sym));
841 }
842 struct vector * layout_classoid_name(lispobj * layout)
843 {
844 if (forwarding_pointer_p(layout))
845 layout = native_pointer(forwarding_pointer_value(layout));
846 lispobj classoid = ((struct layout*)layout)->classoid;
847 return instancep(classoid) ? classoid_name(native_pointer(classoid)) : NULL;
848 }
849 struct vector * instance_classoid_name(lispobj * instance)
850 {
851 if (forwarding_pointer_p(instance))
852 instance = native_pointer(forwarding_pointer_value(instance));
853 lispobj layout = instance_layout(instance);
854 return instancep(layout) ? layout_classoid_name(native_pointer(layout)) : NULL;
855 }
856 void safely_show_lstring(struct vector * string, int quotes, FILE *s)
857 {
858 extern void show_lstring(struct vector*, int, FILE*);
859 if (forwarding_pointer_p((lispobj*)string))
860 string = (struct vector*)forwarding_pointer_value((lispobj*)string);
861 if (
862 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
863 header_widetag(string->header) == SIMPLE_CHARACTER_STRING_WIDETAG ||
864 #endif
865 header_widetag(string->header) == SIMPLE_BASE_STRING_WIDETAG)
866 show_lstring(string, quotes, s);
867 else {
868 fprintf(s, "#<[widetag=%02X]>", header_widetag(string->header));
869 }
870 }
Common Lisp compiler and runtime