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 is deeply broken, depending on guessing
17 * already out-of-date values instead of getting them from sbcl.h.
26 #include "gc-internal.h"
28 #include "thread.h" /* genesis/primitive-objects.h needs this */
32 /* FSHOW and odxprint provide debugging output for low-level information
33 * (signal handling, exceptions, safepoints) which is hard to debug by
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".
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.
44 struct dyndebug_config dyndebug_config
= {
45 QSHOW
== 2, QSHOW_SIGNALS
== 2
51 #define DYNDEBUG_NFLAGS (sizeof(struct dyndebug_config) / sizeof(int))
52 #define dyndebug_init1(lowercase, uppercase) \
54 int *ptr = &dyndebug_config.dyndebug_##lowercase; \
56 names[n] = #lowercase; \
57 char *val = getenv("SBCL_DYNDEBUG__" uppercase); \
58 *ptr = val && strlen(val); \
62 char *names
[DYNDEBUG_NFLAGS
];
63 int *ptrs
[DYNDEBUG_NFLAGS
];
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 dyndebug_init1(runtime_link
, "RUNTIME_LINK");
75 int n_output_flags
= n
;
76 dyndebug_init1(backtrace_when_lost
, "BACKTRACE_WHEN_LOST");
77 dyndebug_init1(sleep_when_lost
, "SLEEP_WHEN_LOST");
79 if (n
!= DYNDEBUG_NFLAGS
)
80 fprintf(stderr
, "Bug in dyndebug_init\n");
82 #if defined(LISP_FEATURE_GENCGC)
83 gencgc_verbose
= dyndebug_config
.dyndebug_gencgc_verbose
;
86 char *featurelist
= getenv("SBCL_DYNDEBUG");
89 featurelist
= strdup(featurelist
);
90 char *ptr
= featurelist
;
92 char *token
= strtok(ptr
, " ");
95 if (!strcmp(token
, "all"))
96 for (i
= 0; i
< n_output_flags
; i
++)
99 for (i
= 0; i
< (int)DYNDEBUG_NFLAGS
; i
++)
100 if (!strcmp(token
, names
[i
])) {
104 if (i
== DYNDEBUG_NFLAGS
) {
105 fprintf(stderr
, "No such dyndebug flag: `%s'\n", token
);
113 fprintf(stderr
, "Valid flags are:\n");
114 fprintf(stderr
, " all ;enables all of the following:\n");
116 for (i
= 0; i
< (int)DYNDEBUG_NFLAGS
; i
++) {
117 if (i
== n_output_flags
)
118 fprintf(stderr
, "Additional options:\n");
119 fprintf(stderr
, " %s\n", names
[i
]);
124 #undef dyndebug_init1
125 #undef DYNDEBUG_NFLAGS
128 /* Temporarily, odxprint merely performs the equivalent of a traditional
129 * FSHOW call, i.e. it merely formats to stderr. Ultimately, it should
130 * be restored to its full win32 branch functionality, where output to a
131 * file or to the debugger can be selected at runtime. */
133 void vodxprint_fun(const char *, va_list);
136 odxprint_fun(const char *fmt
, ...)
140 vodxprint_fun(fmt
, args
);
145 vodxprint_fun(const char *fmt
, va_list args
)
147 #ifdef LISP_FEATURE_WIN32
148 DWORD lastError
= GetLastError();
150 int original_errno
= errno
;
157 #ifdef LISP_FEATURE_SB_THREAD
158 struct thread
*arch_os_get_current_thread(void);
159 struct thread
*self
= arch_os_get_current_thread();
160 void *pth
= self
? (void *) self
->os_thread
: 0;
161 snprintf(buf
, sizeof(buf
), "[%p/%p] ", self
, pth
);
165 vsnprintf(buf
+ n
, sizeof(buf
) - n
- 1, fmt
, args
);
166 /* buf is now zero-terminated (even in case of overflow).
167 * Our caller took care of the newline (if any) through `fmt'. */
169 /* A sufficiently POSIXy implementation of stdio will provide
170 * per-FILE locking, as defined in the spec for flockfile. At least
171 * glibc complies with this. Hence we do not need to perform
172 * locking ourselves here. (Should it turn out, of course, that
173 * other libraries opt for speed rather than safety, we need to
174 * revisit this decision.) */
177 #ifdef LISP_FEATURE_WIN32
178 /* stdio's stderr is line-bufferred, i.e. \n ought to flush it.
179 * Unfortunately, MinGW does not behave the way I would expect it
180 * to. Let's be safe: */
186 #ifdef LISP_FEATURE_WIN32
187 SetLastError(lastError
);
189 errno
= original_errno
;
192 /* Translate the rather awkward syntax
193 * FSHOW((stderr, "xyz"))
194 * into the new and cleaner
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.) */
200 fshow_fun(void __attribute__((__unused__
)) *ignored
,
206 vodxprint_fun(fmt
, args
);
210 /* This file can be skipped if we're not supporting LDB. */
211 #if defined(LISP_FEATURE_SB_LDB)
216 #ifdef LISP_FEATURE_GENCGC
217 #include "gencgc-alloc-region.h" /* genesis/thread.h needs this */
219 #if defined(LISP_FEATURE_WIN32)
220 # include "win32-thread-private-events.h" /* genesis/thread.h needs this */
222 #include "genesis/static-symbols.h"
223 #include "genesis/primitive-objects.h"
224 #include "genesis/static-symbols.h"
225 #include "genesis/tagnames.h"
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;
233 static void print_obj(char *prefix
, lispobj obj
);
235 #define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return;
237 static void indent(int in
)
239 static char *spaces
= " ";
242 fputs(spaces
, stdout
);
246 fputs(spaces
+ 64 - in
, stdout
);
249 static boolean
continue_p(boolean newline
)
253 if (cur_depth
>= max_depth
|| dont_descend
)
262 if (cur_lines
>= max_lines
) {
263 printf("More? [y] ");
266 if (fgets(buffer
, sizeof(buffer
), stdin
)) {
267 if (buffer
[0] == 'n' || buffer
[0] == 'N')
272 printf("\nUnable to read response, assuming y.\n");
281 static void newline(char *label
)
285 fputs(label
, stdout
);
287 indent(cur_depth
* 2);
291 static void print_unknown(lispobj obj
)
293 printf("unknown object: %p", (void *)obj
);
296 static void brief_fixnum(lispobj obj
)
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
);
303 #ifndef LISP_FEATURE_ALPHA
304 printf("%ld", ((long)obj
)>>N_FIXNUM_TAG_BITS
);
306 printf("%d", ((s32
)obj
)>>N_FIXNUM_TAG_BITS
);
310 static void print_fixnum(lispobj obj
)
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
);
317 #ifndef LISP_FEATURE_ALPHA
318 printf(": %ld", ((long)obj
)>>N_FIXNUM_TAG_BITS
);
320 printf(": %d", ((s32
)obj
)>>N_FIXNUM_TAG_BITS
);
324 static void brief_otherimm(lispobj obj
)
329 type
= widetag_of(obj
);
331 case CHARACTER_WIDETAG
:
332 c
= obj
>>8; // no mask. show whatever's there
335 case '\0': charname
= "Nul"; break;
336 case '\n': charname
= "Newline"; break;
337 case '\b': charname
= "Backspace"; break;
338 case '\177': charname
= "Delete"; break;
340 if (c
< 32) printf("^%c", c
+64);
341 else printf(c
< 128 ? "%c" : "U+%X", c
);
344 fputs(charname
, stdout
);
347 case UNBOUND_MARKER_WIDETAG
:
348 printf("<unbound marker>");
352 printf("%s", widetag_names
[type
>> 2]);
357 static void print_otherimm(lispobj obj
)
359 printf(", %s", widetag_names
[widetag_of(obj
) >> 2]);
361 switch (widetag_of(obj
)) {
362 case CHARACTER_WIDETAG
:
368 case UNBOUND_MARKER_WIDETAG
:
372 printf(": data=%"OBJ_FMTX
, (obj
>>8));
377 static void brief_list(lispobj obj
)
386 while (lowtag_of(obj
) == LIST_POINTER_LOWTAG
) {
389 if (++length
>= max_length
) {
394 print_obj("", CONS(obj
)->car
);
395 obj
= CONS(obj
)->cdr
;
408 static void print_list(lispobj obj
)
413 print_obj("car: ", CONS(obj
)->car
);
414 print_obj("cdr: ", CONS(obj
)->cdr
);
418 // takes native pointer as input
419 char * simple_base_stringize(struct vector
* string
)
421 if (widetag_of(string
->header
) == SIMPLE_BASE_STRING_WIDETAG
)
422 return (char*)string
->data
;
423 int length
= string
->length
;
424 char * newstring
= malloc(length
+1);
425 uint32_t * data
= (uint32_t*)string
->data
;
427 for(i
=0;i
<length
;++i
)
428 newstring
[i
] = data
[i
] < 128 ? data
[i
] : '?';
429 newstring
[length
] = 0;
433 static void brief_struct(lispobj obj
)
435 struct instance
*instance
= (struct instance
*)native_pointer(obj
);
436 extern struct vector
* instance_classoid_name(lispobj
*);
437 struct vector
* classoid_name
;
438 classoid_name
= instance_classoid_name((lispobj
*)instance
);
439 if ( classoid_name
) {
440 char * namestring
= simple_base_stringize(classoid_name
);
441 printf("#<ptr to %p %s instance>",
442 (void*)instance_layout((lispobj
*)instance
), namestring
);
443 if ( namestring
!= (char*)classoid_name
->data
)
446 printf("#<ptr to %p instance>",
447 (void*)instance_layout((lispobj
*)instance
));
451 #include "genesis/layout.h"
452 static boolean
tagged_slot_p(struct layout
* layout
,
455 lispobj bitmap
= layout
->bitmap
;
456 sword_t fixnum
= (sword_t
)bitmap
>> N_FIXNUM_TAG_BITS
; // optimistically
457 return fixnump(bitmap
)
458 ? bitmap
== make_fixnum(-1) ||
459 (slot_index
< N_WORD_BITS
&& ((fixnum
>> slot_index
) & 1) != 0)
460 : positive_bignum_logbitp(slot_index
,
461 (struct bignum
*)native_pointer(bitmap
));
464 static void print_struct(lispobj obj
)
466 struct instance
*instance
= (struct instance
*)native_pointer(obj
);
469 lispobj layout_obj
= instance_layout(native_pointer(obj
));
470 print_obj("type: ", layout_obj
);
471 struct layout
* layout
= (struct layout
*)native_pointer(layout_obj
);
472 for (i
=INSTANCE_DATA_START
; i
<instance_length(instance
->header
); i
++) {
473 sprintf(buffer
, "slot %d: ", i
);
474 if (layout
!= NULL
&& tagged_slot_p(layout
, i
)) {
475 print_obj(buffer
, instance
->slots
[i
]);
478 printf("\n\t %s0x%"OBJ_FMTX
" [raw]", buffer
, instance
->slots
[i
]);
483 void show_lstring(struct vector
* string
, int quotes
, FILE *s
)
486 int i
, len
= fixnum_value(string
->length
);
488 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
489 if (widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
) {
492 putc('u', s
); /* an arbitrary notational convention */
495 if (quotes
) putc('"', s
);
496 for (i
=0 ; i
<len
; i
++) {
497 // hopefully the compiler will optimize out the ucs4_p test
498 // when the runtime is built without Unicode support
501 ch
= i
[(uint32_t*)string
->data
];
503 ch
= i
[(char*)string
->data
];
504 if (ch
>= 32 && ch
< 127) {
505 if (quotes
&& (ch
== '"' || ch
== '\\'))
509 fprintf(s
, ch
> 0xffff ? "\\U%08X" :
510 ch
> 0xff ? "\\u%04X" : "\\x%02X", ch
);
513 if (quotes
) putc('"', s
);
516 static void brief_otherptr(lispobj obj
)
518 extern void safely_show_lstring(struct vector
*, int, FILE*);
519 lispobj
*ptr
, header
;
521 struct symbol
*symbol
;
523 ptr
= native_pointer(obj
);
525 type
= widetag_of(header
);
528 symbol
= (struct symbol
*)ptr
;
529 if (symbol
->package
== NIL
)
531 show_lstring(VECTOR(symbol
->name
), 0, stdout
);
534 case SIMPLE_BASE_STRING_WIDETAG
:
535 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
536 case SIMPLE_CHARACTER_STRING_WIDETAG
:
538 show_lstring((struct vector
*)ptr
, 1, stdout
);
543 brief_otherimm(header
);
544 if (type
== FDEFN_WIDETAG
) { // Try to print name, if a symbol
545 // FIXME: more address validity checks perhaps?
546 lispobj name
= ((struct fdefn
*)ptr
)->name
;
547 if (lowtag_of(name
) == OTHER_POINTER_LOWTAG
548 && widetag_of(*native_pointer(name
)) == SYMBOL_WIDETAG
) {
550 struct vector
* str
= symbol_name(native_pointer(name
));
551 safely_show_lstring(str
, 0, stdout
);
558 static void print_slots(char **slots
, int count
, lispobj
*ptr
)
560 while (count
-- > 0) {
562 print_obj(*slots
++, *ptr
++);
564 print_obj("???: ", *ptr
++);
569 static lispobj
symbol_function(lispobj
* symbol
)
571 lispobj info
= ((struct symbol
*)symbol
)->info
;
572 if (lowtag_of(info
) == LIST_POINTER_LOWTAG
)
573 info
= CONS(info
)->cdr
;
574 if (lowtag_of(info
) == OTHER_POINTER_LOWTAG
) {
575 struct vector
* v
= VECTOR(info
);
576 int len
= fixnum_value(v
->length
);
578 lispobj elt
= v
->data
[0]; // Just like INFO-VECTOR-FDEFN
579 if (fixnump(elt
) && (fixnum_value(elt
) & 07777) >= 07701) {
580 lispobj fdefn
= v
->data
[len
-1];
581 if (lowtag_of(fdefn
) == OTHER_POINTER_LOWTAG
)
582 return FDEFN(fdefn
)->fun
;
589 static void print_otherptr(lispobj obj
)
591 #ifndef LISP_FEATURE_ALPHA
593 unsigned long header
;
594 unsigned long length
;
600 int count
, type
, index
;
603 ptr
= native_pointer(obj
);
605 printf(" (NULL Pointer)");
610 length
= fixnum_value(*ptr
);
611 count
= HeaderValue(header
);
612 type
= widetag_of(header
);
614 print_obj("header: ", header
);
615 if (!other_immediate_lowtag_p(header
)) {
617 printf("(invalid header object)");
621 if (unprintable_array_types
[type
/8] & (1<<(type
% 8)))
630 #if N_WORD_BITS == 32
635 (unsigned long) *--ptr
, (count
?"_":""));
639 print_slots(ratio_slots
, count
, ptr
);
642 case COMPLEX_WIDETAG
:
643 print_slots(complex_slots
, count
, ptr
);
647 // Only 1 byte of a symbol header conveys its size.
648 // The other bytes may be freely used by the backend.
649 print_slots(symbol_slots
, count
& 0xFF, ptr
);
650 if (symbol_function(ptr
-1) != NIL
)
651 print_obj("fun: ", symbol_function(ptr
-1));
654 #if N_WORD_BITS == 32
655 case SINGLE_FLOAT_WIDETAG
:
657 printf("%g", ((struct single_float
*)native_pointer(obj
))->value
);
660 case DOUBLE_FLOAT_WIDETAG
:
662 printf("%g", ((struct double_float
*)native_pointer(obj
))->value
);
665 #ifdef LONG_FLOAT_WIDETAG
666 case LONG_FLOAT_WIDETAG
:
668 printf("%Lg", ((struct long_float
*)native_pointer(obj
))->value
);
672 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
673 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
675 #ifdef LISP_FEATURE_64_BIT
676 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->data
.data
[0]);
678 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->real
);
681 #ifdef LISP_FEATURE_64_BIT
682 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->data
.data
[1]);
684 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->imag
);
689 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
690 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
692 printf("%g", ((struct complex_double_float
*)native_pointer(obj
))->real
);
694 printf("%g", ((struct complex_double_float
*)native_pointer(obj
))->imag
);
698 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
699 case COMPLEX_LONG_FLOAT_WIDETAG
:
701 printf("%Lg", ((struct complex_long_float
*)native_pointer(obj
))->real
);
703 printf("%Lg", ((struct complex_long_float
*)native_pointer(obj
))->imag
);
707 case SIMPLE_BASE_STRING_WIDETAG
:
708 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
709 case SIMPLE_CHARACTER_STRING_WIDETAG
:
712 show_lstring((struct vector
*)native_pointer(obj
), 1, stdout
);
715 case SIMPLE_VECTOR_WIDETAG
:
717 printf("length = %ld", length
);
720 while (length
-- > 0) {
721 sprintf(buffer
, "%d: ", index
++);
722 print_obj(buffer
, *ptr
++);
726 // FIXME: This case looks unreachable. print_struct() does it
727 case INSTANCE_WIDETAG
:
729 count
&= SHORT_HEADER_MAX_WORDS
;
730 printf("length = %ld", (long) count
);
732 while (count
-- > 0) {
733 sprintf(buffer
, "%d: ", index
++);
734 print_obj(buffer
, *ptr
++);
738 case CODE_HEADER_WIDETAG
:
739 count
&= SHORT_HEADER_MAX_WORDS
;
740 // ptr was already bumped up
741 for_each_simple_fun(fun_index
, fun
, (struct code
*)(ptr
-1), 0, {
742 sprintf(buffer
, "f[%d]: ", fun_index
);
743 print_obj(buffer
, make_lispobj(fun
,FUN_POINTER_LOWTAG
));
745 print_slots(code_slots
, count
-1, ptr
);
748 case SIMPLE_FUN_WIDETAG
:
750 make_lispobj(native_pointer((lispobj
)(ptr
-1))
751 -(HeaderValue(header
)&0xFFFF),
752 OTHER_POINTER_LOWTAG
));
753 print_slots(simple_fun_slots
,
754 sizeof simple_fun_slots
/sizeof(char*)-1, ptr
);
757 #ifdef RETURN_PC_WIDETAG
758 case RETURN_PC_WIDETAG
:
759 print_obj("code: ", obj
- (count
* 4));
763 case CLOSURE_WIDETAG
:
764 print_slots(closure_slots
,
765 count
& SHORT_HEADER_MAX_WORDS
, ptr
);
768 case FUNCALLABLE_INSTANCE_WIDETAG
:
769 print_slots(funcallable_instance_slots
,
770 count
& SHORT_HEADER_MAX_WORDS
, ptr
);
773 case VALUE_CELL_WIDETAG
:
774 print_slots(value_cell_slots
, 1, ptr
);
779 #ifndef LISP_FEATURE_ALPHA
780 printf("0x%08lx", (unsigned long) *ptr
);
782 printf("0x%016lx", *(lispobj
*)(ptr
+1));
786 case WEAK_POINTER_WIDETAG
:
787 print_slots(weak_pointer_slots
, 1, ptr
);
790 case CHARACTER_WIDETAG
:
791 case UNBOUND_MARKER_WIDETAG
:
793 printf("pointer to an immediate?");
797 #ifdef LISP_FEATURE_IMMOBILE_CODE
798 print_slots(fdefn_slots
, 2, ptr
);
799 print_obj("entry: ", fdefn_raw_referent((struct fdefn
*)(ptr
-1)));
801 print_slots(fdefn_slots
, count
& SHORT_HEADER_MAX_WORDS
, ptr
);
807 printf("Unknown header object?");
812 static void print_obj(char *prefix
, lispobj obj
)
814 #ifdef LISP_FEATURE_64_BIT
815 static void (*verbose_fns
[])(lispobj obj
)
816 = {print_fixnum
, print_otherimm
, print_fixnum
, print_struct
,
817 print_fixnum
, print_otherimm
, print_fixnum
, print_list
,
818 print_fixnum
, print_otherimm
, print_fixnum
, print_otherptr
,
819 print_fixnum
, print_otherimm
, print_fixnum
, print_otherptr
};
820 static void (*brief_fns
[])(lispobj obj
)
821 = {brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_struct
,
822 brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_list
,
823 brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_otherptr
,
824 brief_fixnum
, brief_otherimm
, brief_fixnum
, brief_otherptr
};
826 static void (*verbose_fns
[])(lispobj obj
)
827 = {print_fixnum
, print_struct
, print_otherimm
, print_list
,
828 print_fixnum
, print_otherptr
, print_otherimm
, print_otherptr
};
829 static void (*brief_fns
[])(lispobj obj
)
830 = {brief_fixnum
, brief_struct
, brief_otherimm
, brief_list
,
831 brief_fixnum
, brief_otherptr
, brief_otherimm
, brief_otherptr
};
833 int type
= lowtag_of(obj
);
834 struct var
*var
= lookup_by_obj(obj
);
836 boolean verbose
= cur_depth
< brief_depth
;
838 if (!continue_p(verbose
))
841 if (var
!= NULL
&& var_clock(var
) == cur_clock
)
844 if (var
== NULL
&& is_lisp_pointer(obj
))
845 var
= define_var(NULL
, obj
, 0);
848 var_setclock(var
, cur_clock
);
850 void (**fns
)(lispobj
) = NULL
;
854 sprintf(buffer
, "$%s=", var_name(var
));
859 printf("%s0x%08lx: ", prefix
, (unsigned long) obj
);
860 if (cur_depth
< brief_depth
) {
861 fputs(lowtag_names
[type
], stdout
);
869 printf("$%s", var_name(var
));
872 printf("$%s=", var_name(var
));
878 else if (is_lisp_pointer(obj
)
879 && !is_valid_lisp_addr((os_vm_address_t
)obj
))
880 printf("(bad-address)");
894 void print(lispobj obj
)
906 void brief_print(lispobj obj
)
918 // The following accessors, which take a valid native pointer as input
919 // and return a Lisp string, are designed to be foolproof during GC,
920 // hence all the forwarding checks.
922 #include "forwarding-ptr.h"
923 #include "genesis/classoid.h"
924 struct vector
* symbol_name(lispobj
* sym
)
926 if (forwarding_pointer_p(sym
))
927 sym
= native_pointer(forwarding_pointer_value(sym
));
928 if (lowtag_of(((struct symbol
*)sym
)->name
) != OTHER_POINTER_LOWTAG
)
930 lispobj
* name
= native_pointer(((struct symbol
*)sym
)->name
);
931 if (forwarding_pointer_p(name
))
932 name
= native_pointer(forwarding_pointer_value(name
));
933 return (struct vector
*)name
;
935 struct vector
* classoid_name(lispobj
* classoid
)
937 if (forwarding_pointer_p(classoid
))
938 classoid
= native_pointer(forwarding_pointer_value(classoid
));
939 lispobj sym
= ((struct classoid
*)classoid
)->name
;
940 return lowtag_of(sym
) != OTHER_POINTER_LOWTAG
? NULL
941 : symbol_name(native_pointer(sym
));
943 struct vector
* layout_classoid_name(lispobj
* layout
)
945 if (forwarding_pointer_p(layout
))
946 layout
= native_pointer(forwarding_pointer_value(layout
));
947 lispobj classoid
= ((struct layout
*)layout
)->classoid
;
948 return lowtag_of(classoid
) != INSTANCE_POINTER_LOWTAG
? NULL
949 : classoid_name(native_pointer(classoid
));
951 struct vector
* instance_classoid_name(lispobj
* instance
)
953 if (forwarding_pointer_p(instance
))
954 instance
= native_pointer(forwarding_pointer_value(instance
));
955 lispobj layout
= instance_layout(instance
);
956 return lowtag_of(layout
) != INSTANCE_POINTER_LOWTAG
? NULL
957 : layout_classoid_name(native_pointer(layout
));
959 void safely_show_lstring(struct vector
* string
, int quotes
, FILE *s
)
961 extern void show_lstring(struct vector
*, int, FILE*);
962 if (forwarding_pointer_p((lispobj
*)string
))
963 string
= (struct vector
*)forwarding_pointer_value((lispobj
*)string
);
965 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
966 widetag_of(string
->header
) == SIMPLE_CHARACTER_STRING_WIDETAG
||
968 widetag_of(string
->header
) == SIMPLE_BASE_STRING_WIDETAG
)
969 show_lstring(string
, quotes
, s
);
971 fprintf(s
, "#<[widetag=%02X]>", widetag_of(string
->header
));
978 brief_print(lispobj obj
)
980 printf("lispobj 0x%lx\n", (unsigned long)obj
);
983 #endif /* defined(LISP_FEATURE_SB_LDB) */