1 /* code for low-level debugging/diagnostic output */
4 * This software is part of the SBCL system. See the README file for
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.
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.
27 #include "gc-internal.h"
29 #include "thread.h" /* genesis/primitive-objects.h needs this */
33 /* FSHOW and odxprint provide debugging output for low-level information
34 * (signal handling, exceptions, safepoints) which is hard to debug by
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".
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.
45 struct dyndebug_config dyndebug_config
= {
46 QSHOW
== 2, QSHOW_SIGNALS
== 2
52 #define DYNDEBUG_NFLAGS (sizeof(struct dyndebug_config) / sizeof(int))
53 #define dyndebug_init1(lowercase, uppercase) \
55 int *ptr = &dyndebug_config.dyndebug_##lowercase; \
57 names[n] = #lowercase; \
58 char *val = getenv("SBCL_DYNDEBUG__" uppercase); \
59 *ptr = val && strlen(val); \
63 char *names
[DYNDEBUG_NFLAGS
];
64 int *ptrs
[DYNDEBUG_NFLAGS
];
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");
76 int n_output_flags
= n
;
77 dyndebug_init1(backtrace_when_lost
, "BACKTRACE_WHEN_LOST");
78 dyndebug_init1(sleep_when_lost
, "SLEEP_WHEN_LOST");
80 if (n
!= DYNDEBUG_NFLAGS
)
81 fprintf(stderr
, "Bug in dyndebug_init\n");
83 #if defined(LISP_FEATURE_GENCGC)
84 gencgc_verbose
= dyndebug_config
.dyndebug_gencgc_verbose
;
87 char *featurelist
= getenv("SBCL_DYNDEBUG");
90 featurelist
= strdup(featurelist
);
91 char *ptr
= featurelist
;
93 char *token
= strtok(ptr
, " ");
96 if (!strcmp(token
, "all"))
97 for (i
= 0; i
< n_output_flags
; i
++)
100 for (i
= 0; i
< (int)DYNDEBUG_NFLAGS
; i
++)
101 if (!strcmp(token
, names
[i
])) {
105 if (i
== DYNDEBUG_NFLAGS
) {
106 fprintf(stderr
, "No such dyndebug flag: `%s'\n", token
);
114 fprintf(stderr
, "Valid flags are:\n");
115 fprintf(stderr
, " all ;enables all of the following:\n");
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
]);
125 #undef dyndebug_init1
126 #undef DYNDEBUG_NFLAGS
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. */
134 void vodxprint_fun(const char *, va_list);
137 odxprint_fun(const char *fmt
, ...)
141 vodxprint_fun(fmt
, args
);
146 vodxprint_fun(const char *fmt
, va_list args
)
148 #ifdef LISP_FEATURE_WIN32
149 DWORD lastError
= GetLastError();
151 int original_errno
= errno
;
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
);
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'. */
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.) */
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: */
187 #ifdef LISP_FEATURE_WIN32
188 SetLastError(lastError
);
190 errno
= original_errno
;
193 /* Translate the rather awkward syntax
194 * FSHOW((stderr, "xyz"))
195 * into the new and cleaner
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.) */
201 fshow_fun(void __attribute__((__unused__
)) *ignored
,
207 vodxprint_fun(fmt
, args
);
211 /* This file can be skipped if we're not supporting LDB. */
212 #if defined(LISP_FEATURE_SB_LDB)
217 #ifdef LISP_FEATURE_GENCGC
218 #include "gencgc-alloc-region.h" /* genesis/thread.h needs this */
220 #if defined(LISP_FEATURE_WIN32)
221 # include "win32-thread-private-events.h" /* genesis/thread.h needs this */
223 #include "genesis/static-symbols.h"
224 #include "genesis/primitive-objects.h"
225 #include "genesis/static-symbols.h"
226 #include "genesis/tagnames.h"
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;
234 static void print_obj(char *prefix
, lispobj obj
);
236 #define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return;
238 static void indent(int in
)
240 static char *spaces
= " ";
243 fputs(spaces
, stdout
);
247 fputs(spaces
+ 64 - in
, stdout
);
250 static boolean
continue_p(boolean newline
)
254 if (cur_depth
>= max_depth
|| dont_descend
)
263 if (cur_lines
>= max_lines
) {
264 printf("More? [y] ");
267 if (fgets(buffer
, sizeof(buffer
), stdin
)) {
268 if (buffer
[0] == 'n' || buffer
[0] == 'N')
273 printf("\nUnable to read response, assuming y.\n");
282 static void newline(char *label
)
286 fputs(label
, stdout
);
288 indent(cur_depth
* 2);
292 static void print_unknown(lispobj obj
)
294 printf("unknown object: %p", (void *)obj
);
297 static void brief_fixnum(lispobj obj
)
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
);
304 #ifndef LISP_FEATURE_ALPHA
305 printf("%ld", ((long)obj
)>>N_FIXNUM_TAG_BITS
);
307 printf("%d", ((s32
)obj
)>>N_FIXNUM_TAG_BITS
);
311 static void print_fixnum(lispobj obj
)
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
);
318 #ifndef LISP_FEATURE_ALPHA
319 printf(": %ld", ((long)obj
)>>N_FIXNUM_TAG_BITS
);
321 printf(": %d", ((s32
)obj
)>>N_FIXNUM_TAG_BITS
);
325 static void brief_otherimm(lispobj obj
)
330 type
= widetag_of(obj
);
332 case CHARACTER_WIDETAG
:
333 c
= obj
>>8; // no mask. show whatever's there
336 case '\0': charname
= "Nul"; break;
337 case '\n': charname
= "Newline"; break;
338 case '\b': charname
= "Backspace"; break;
339 case '\177': charname
= "Delete"; break;
341 if (c
< 32) printf("^%c", c
+64);
342 else printf(c
< 128 ? "%c" : "U+%X", c
);
345 fputs(charname
, stdout
);
348 case UNBOUND_MARKER_WIDETAG
:
349 printf("<unbound marker>");
353 printf("%s", widetag_names
[type
>> 2]);
358 static void print_otherimm(lispobj obj
)
360 printf(", %s", widetag_names
[widetag_of(obj
) >> 2]);
362 switch (widetag_of(obj
)) {
363 case CHARACTER_WIDETAG
:
369 case UNBOUND_MARKER_WIDETAG
:
373 printf(": data=%"OBJ_FMTX
, (obj
>>8));
378 static void brief_list(lispobj obj
)
383 if (!is_valid_lisp_addr((os_vm_address_t
)native_pointer(obj
)))
384 printf("(invalid Lisp-level address)");
389 while (lowtag_of(obj
) == LIST_POINTER_LOWTAG
) {
390 struct cons
*cons
= (struct cons
*)native_pointer(obj
);
394 if (++length
>= max_length
) {
399 print_obj("", cons
->car
);
413 static void print_list(lispobj obj
)
415 if (!is_valid_lisp_addr((os_vm_address_t
)native_pointer(obj
))) {
416 printf("(invalid address)");
417 } else if (obj
== NIL
) {
420 struct cons
*cons
= (struct cons
*)native_pointer(obj
);
422 print_obj("car: ", cons
->car
);
423 print_obj("cdr: ", cons
->cdr
);
427 // takes native pointer as input
428 char * simple_base_stringize(struct vector
* string
)
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
;
436 for(i
=0;i
<length
;++i
)
437 newstring
[i
] = data
[i
] < 128 ? data
[i
] : '?';
438 newstring
[length
] = 0;
442 static void brief_struct(lispobj obj
)
444 struct instance
*instance
= (struct instance
*)native_pointer(obj
);
445 if (!is_valid_lisp_addr((os_vm_address_t
)instance
)) {
446 printf("(invalid address)");
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
)
458 printf("#<ptr to %p instance>",
459 (void*)instance_layout((lispobj
*)instance
));
464 #include "genesis/layout.h"
465 static boolean
tagged_slot_p(struct layout
* layout
,
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
));
477 static void print_struct(lispobj obj
)
479 struct instance
*instance
= (struct instance
*)native_pointer(obj
);
482 if (!is_valid_lisp_addr((os_vm_address_t
)instance
)) {
483 printf("(invalid address)");
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
]);
494 printf("\n\t %s0x%"OBJ_FMTX
" [raw]", buffer
, instance
->slots
[i
]);
500 void show_lstring(struct vector
* string
, int quotes
, FILE *s
)
503 int i
, len
= fixnum_value(string
->length
);
505 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
506 if (widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
) {
509 putc('u', s
); /* an arbitrary notational convention */
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
518 ch
= i
[(uint32_t*)string
->data
];
520 ch
= i
[(char*)string
->data
];
521 if (ch
>= 32 && ch
< 127) {
522 if (quotes
&& (ch
== '"' || ch
== '\\'))
526 fprintf(s
, ch
> 0xffff ? "\\U%08X" :
527 ch
> 0xff ? "\\u%04X" : "\\x%02X", ch
);
530 if (quotes
) putc('"', s
);
533 static void brief_otherptr(lispobj obj
)
535 extern void safely_show_lstring(struct vector
*, int, FILE*);
536 lispobj
*ptr
, header
;
538 struct symbol
*symbol
;
540 ptr
= native_pointer(obj
);
542 if (!is_valid_lisp_addr((os_vm_address_t
)obj
)) {
543 printf("(invalid address)");
548 type
= widetag_of(header
);
550 case SYMBOL_HEADER_WIDETAG
:
551 symbol
= (struct symbol
*)ptr
;
552 if (symbol
->package
== NIL
)
554 show_lstring((struct vector
*)native_pointer(symbol
->name
),
558 case SIMPLE_BASE_STRING_WIDETAG
:
559 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
560 case SIMPLE_CHARACTER_STRING_WIDETAG
:
562 show_lstring((struct vector
*)ptr
, 1, stdout
);
567 brief_otherimm(header
);
568 if (type
== FDEFN_WIDETAG
) { // Try to print name, if a symbol
569 // FIXME: more address validity checks perhaps?
570 lispobj name
= ((struct fdefn
*)ptr
)->name
;
571 if (lowtag_of(name
) == OTHER_POINTER_LOWTAG
572 && widetag_of(*native_pointer(name
)) == SYMBOL_HEADER_WIDETAG
) {
574 struct vector
* str
= symbol_name(native_pointer(name
));
575 safely_show_lstring(str
, 0, stdout
);
582 static void print_slots(char **slots
, int count
, lispobj
*ptr
)
584 while (count
-- > 0) {
586 print_obj(*slots
++, *ptr
++);
588 print_obj("???: ", *ptr
++);
593 /* FIXME: Yikes! This needs to depend on the values in sbcl.h (or
594 * perhaps be generated automatically by GENESIS as part of
596 static char *symbol_slots
[] = {"value: ", "hash: ",
597 "info: ", "name: ", "package: ",
598 #if defined (LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_X86_64)
602 static char *ratio_slots
[] = {"numer: ", "denom: ", NULL
};
603 static char *complex_slots
[] = {"real: ", "imag: ", NULL
};
604 static char *code_slots
[] = {"bytes: ", "debug: ",
605 #ifndef LISP_FEATURE_64_BIT
609 static char *simple_fun_slots
[] = {
610 "self: ", "name: ", "arglist: ", "type: ", "info: ", NULL
};
611 static char *closure_slots
[] = {"fn: ", NULL
};
612 static char *funcallable_instance_slots
[] = {"raw_fn: ", "fn: ",
613 #ifndef LISP_FEATURE_COMPACT_INSTANCE_HEADER
617 static char *weak_pointer_slots
[] = {"value: ", NULL
};
618 static char *fdefn_slots
[] = {"name: ", "function: ", "raw_addr: ", NULL
};
619 static char *value_cell_slots
[] = {"value: ", NULL
};
621 static lispobj
symbol_function(lispobj
* symbol
)
623 lispobj info
= ((struct symbol
*)symbol
)->info
;
624 if (lowtag_of(info
) == LIST_POINTER_LOWTAG
)
625 info
= CONS(info
)->cdr
;
626 if (lowtag_of(info
) == OTHER_POINTER_LOWTAG
) {
627 struct vector
* v
= (struct vector
*)native_pointer(info
);
628 int len
= fixnum_value(v
->length
);
630 lispobj elt
= v
->data
[0]; // Just like INFO-VECTOR-FDEFN
631 if (fixnump(elt
) && (fixnum_value(elt
) & 07777) >= 07701) {
632 lispobj fdefn
= v
->data
[len
-1];
633 if (lowtag_of(fdefn
) == OTHER_POINTER_LOWTAG
)
634 return FDEFN(fdefn
)->fun
;
641 static void print_otherptr(lispobj obj
)
643 if (!is_valid_lisp_addr((os_vm_address_t
)obj
)) {
644 printf("(invalid address)");
646 #ifndef LISP_FEATURE_ALPHA
648 unsigned long header
;
649 unsigned long length
;
655 int count
, type
, index
;
658 ptr
= native_pointer(obj
);
660 printf(" (NULL Pointer)");
665 length
= fixnum_value(*ptr
);
666 count
= HeaderValue(header
);
667 type
= widetag_of(header
);
669 print_obj("header: ", header
);
670 if (!other_immediate_lowtag_p(header
)) {
672 printf("(invalid header object)");
676 if (unprintable_array_types
[type
/8] & (1<<(type
% 8)))
685 #if N_WORD_BITS == 32
690 (unsigned long) *--ptr
, (count
?"_":""));
694 print_slots(ratio_slots
, count
, ptr
);
697 case COMPLEX_WIDETAG
:
698 print_slots(complex_slots
, count
, ptr
);
701 case SYMBOL_HEADER_WIDETAG
:
702 // Only 1 byte of a symbol header conveys its size.
703 // The other bytes may be freely used by the backend.
704 print_slots(symbol_slots
, count
& 0xFF, ptr
);
705 if (symbol_function(ptr
-1) != NIL
)
706 print_obj("fun: ", symbol_function(ptr
-1));
709 #if N_WORD_BITS == 32
710 case SINGLE_FLOAT_WIDETAG
:
712 printf("%g", ((struct single_float
*)native_pointer(obj
))->value
);
715 case DOUBLE_FLOAT_WIDETAG
:
717 printf("%g", ((struct double_float
*)native_pointer(obj
))->value
);
720 #ifdef LONG_FLOAT_WIDETAG
721 case LONG_FLOAT_WIDETAG
:
723 printf("%Lg", ((struct long_float
*)native_pointer(obj
))->value
);
727 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
728 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
730 #ifdef LISP_FEATURE_64_BIT
731 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->data
.data
[0]);
733 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->real
);
736 #ifdef LISP_FEATURE_64_BIT
737 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->data
.data
[1]);
739 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->imag
);
744 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
745 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
747 printf("%g", ((struct complex_double_float
*)native_pointer(obj
))->real
);
749 printf("%g", ((struct complex_double_float
*)native_pointer(obj
))->imag
);
753 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
754 case COMPLEX_LONG_FLOAT_WIDETAG
:
756 printf("%Lg", ((struct complex_long_float
*)native_pointer(obj
))->real
);
758 printf("%Lg", ((struct complex_long_float
*)native_pointer(obj
))->imag
);
762 case SIMPLE_BASE_STRING_WIDETAG
:
763 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
764 case SIMPLE_CHARACTER_STRING_WIDETAG
:
767 show_lstring((struct vector
*)native_pointer(obj
), 1, stdout
);
770 case SIMPLE_VECTOR_WIDETAG
:
772 printf("length = %ld", length
);
775 while (length
-- > 0) {
776 sprintf(buffer
, "%d: ", index
++);
777 print_obj(buffer
, *ptr
++);
781 // FIXME: This case looks unreachable. print_struct() does it
782 case INSTANCE_HEADER_WIDETAG
:
784 count
&= SHORT_HEADER_MAX_WORDS
;
785 printf("length = %ld", (long) count
);
787 while (count
-- > 0) {
788 sprintf(buffer
, "%d: ", index
++);
789 print_obj(buffer
, *ptr
++);
793 case CODE_HEADER_WIDETAG
:
794 count
&= SHORT_HEADER_MAX_WORDS
;
795 // ptr was already bumped up
796 for_each_simple_fun(fun_index
, fun
, (struct code
*)(ptr
-1), 0, {
797 sprintf(buffer
, "f[%d]: ", fun_index
);
798 print_obj(buffer
, make_lispobj(fun
,FUN_POINTER_LOWTAG
));
800 print_slots(code_slots
, count
-1, ptr
);
803 case SIMPLE_FUN_HEADER_WIDETAG
:
805 make_lispobj(native_pointer((lispobj
)(ptr
-1))
806 -(HeaderValue(header
)&0xFFFF),
807 OTHER_POINTER_LOWTAG
));
808 print_slots(simple_fun_slots
,
809 sizeof simple_fun_slots
/sizeof(char*)-1, ptr
);
812 #if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64)
813 case RETURN_PC_HEADER_WIDETAG
:
814 print_obj("code: ", obj
- (count
* 4));
818 case CLOSURE_HEADER_WIDETAG
:
819 print_slots(closure_slots
,
820 count
& SHORT_HEADER_MAX_WORDS
, ptr
);
823 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
824 print_slots(funcallable_instance_slots
,
825 count
& SHORT_HEADER_MAX_WORDS
, ptr
);
828 case VALUE_CELL_HEADER_WIDETAG
:
829 print_slots(value_cell_slots
, 1, ptr
);
834 #ifndef LISP_FEATURE_ALPHA
835 printf("0x%08lx", (unsigned long) *ptr
);
837 printf("0x%016lx", *(lispobj
*)(ptr
+1));
841 case WEAK_POINTER_WIDETAG
:
842 print_slots(weak_pointer_slots
, 1, ptr
);
845 case CHARACTER_WIDETAG
:
846 case UNBOUND_MARKER_WIDETAG
:
848 printf("pointer to an immediate?");
852 #ifdef LISP_FEATURE_IMMOBILE_CODE
853 print_slots(fdefn_slots
, 2, ptr
);
854 print_obj("entry: ", fdefn_raw_referent((struct fdefn
*)(ptr
-1)));
856 print_slots(fdefn_slots
, count
& SHORT_HEADER_MAX_WORDS
, ptr
);
862 printf("Unknown header object?");
868 static void print_obj(char *prefix
, lispobj obj
)
870 #ifdef LISP_FEATURE_64_BIT
871 static void (*verbose_fns
[])(lispobj obj
)
872 = {print_fixnum
, print_otherimm
, print_fixnum
, print_struct
,
873 print_fixnum
, print_otherimm
, print_fixnum
, print_list
,
874 print_fixnum
, print_otherimm
, print_fixnum
, print_otherptr
,
875 print_fixnum
, print_otherimm
, print_fixnum
, print_otherptr
};
876 static void (*brief_fns
[])(lispobj obj
)
877 = {brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_struct
,
878 brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_list
,
879 brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_otherptr
,
880 brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_otherptr
};
882 static void (*verbose_fns
[])(lispobj obj
)
883 = {print_fixnum
, print_struct
, print_otherimm
, print_list
,
884 print_fixnum
, print_otherptr
, print_otherimm
, print_otherptr
};
885 static void (*brief_fns
[])(lispobj obj
)
886 = {brief_fixnum
, brief_struct
, brief_otherimm
, brief_list
,
887 brief_fixnum
, brief_otherptr
, brief_otherimm
, brief_otherptr
};
889 int type
= lowtag_of(obj
);
890 struct var
*var
= lookup_by_obj(obj
);
892 boolean verbose
= cur_depth
< brief_depth
;
894 if (!continue_p(verbose
))
897 if (var
!= NULL
&& var_clock(var
) == cur_clock
)
900 if (var
== NULL
&& is_lisp_pointer(obj
))
901 var
= define_var(NULL
, obj
, 0);
904 var_setclock(var
, cur_clock
);
909 sprintf(buffer
, "$%s=", var_name(var
));
914 printf("%s0x%08lx: ", prefix
, (unsigned long) obj
);
915 if (cur_depth
< brief_depth
) {
916 fputs(lowtag_names
[type
], stdout
);
917 (*verbose_fns
[type
])(obj
);
920 (*brief_fns
[type
])(obj
);
924 printf("$%s", var_name(var
));
927 printf("$%s=", var_name(var
));
928 (*brief_fns
[type
])(obj
);
942 void print(lispobj obj
)
954 void brief_print(lispobj obj
)
966 // The following accessors, which take a valid native pointer as input
967 // and return a Lisp string, are designed to be foolproof during GC,
968 // hence all the forwarding checks.
970 #include "forwarding-ptr.h"
971 #include "genesis/classoid.h"
972 struct vector
* symbol_name(lispobj
* sym
)
974 if (forwarding_pointer_p(sym
))
975 sym
= native_pointer(forwarding_pointer_value(sym
));
976 if (lowtag_of(((struct symbol
*)sym
)->name
) != OTHER_POINTER_LOWTAG
)
978 lispobj
* name
= native_pointer(((struct symbol
*)sym
)->name
);
979 if (forwarding_pointer_p(name
))
980 name
= native_pointer(forwarding_pointer_value(name
));
981 return (struct vector
*)name
;
983 struct vector
* classoid_name(lispobj
* classoid
)
985 if (forwarding_pointer_p(classoid
))
986 classoid
= native_pointer(forwarding_pointer_value(classoid
));
987 lispobj sym
= ((struct classoid
*)classoid
)->name
;
988 return lowtag_of(sym
) != OTHER_POINTER_LOWTAG
? NULL
989 : symbol_name(native_pointer(sym
));
991 struct vector
* layout_classoid_name(lispobj
* layout
)
993 if (forwarding_pointer_p(layout
))
994 layout
= native_pointer(forwarding_pointer_value(layout
));
995 lispobj classoid
= ((struct layout
*)layout
)->classoid
;
996 return lowtag_of(classoid
) != INSTANCE_POINTER_LOWTAG
? NULL
997 : classoid_name(native_pointer(classoid
));
999 struct vector
* instance_classoid_name(lispobj
* instance
)
1001 if (forwarding_pointer_p(instance
))
1002 instance
= native_pointer(forwarding_pointer_value(instance
));
1003 lispobj layout
= instance_layout(instance
);
1004 return lowtag_of(layout
) != INSTANCE_POINTER_LOWTAG
? NULL
1005 : layout_classoid_name(native_pointer(layout
));
1007 void safely_show_lstring(struct vector
* string
, int quotes
, FILE *s
)
1009 extern void show_lstring(struct vector
*, int, FILE*);
1010 if (forwarding_pointer_p((lispobj
*)string
))
1011 string
= (struct vector
*)forwarding_pointer_value((lispobj
*)string
);
1013 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
1014 widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
||
1016 widetag_of(string
->header
) == SIMPLE_BASE_STRING_WIDETAG
)
1017 show_lstring(string
, quotes
, s
);
1019 fprintf(s
, "#<[widetag=%02X]>", widetag_of(string
->header
));
1026 brief_print(lispobj obj
)
1028 printf("lispobj 0x%lx\n", (unsigned long)obj
);
1031 #endif /* defined(LISP_FEATURE_SB_LDB) */