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.
28 /* This file can be skipped if we're not supporting LDB. */
29 #if defined(LISP_FEATURE_SB_LDB)
34 #include "gencgc-alloc-region.h" /* genesis/thread.h needs this */
35 #include "genesis/static-symbols.h"
36 #include "genesis/primitive-objects.h"
37 #include "genesis/static-symbols.h"
38 #include "genesis/tagnames.h"
40 static int max_lines
= 20, cur_lines
= 0;
41 static int max_depth
= 5, brief_depth
= 2, cur_depth
= 0;
42 static int max_length
= 5;
43 static boolean dont_descend
= 0, skip_newline
= 0;
44 static int cur_clock
= 0;
46 static void print_obj(char *prefix
, lispobj obj
);
48 #define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return;
50 static void indent(int in
)
52 static char *spaces
= " ";
55 fputs(spaces
, stdout
);
59 fputs(spaces
+ 64 - in
, stdout
);
62 static boolean
continue_p(boolean newline
)
66 if (cur_depth
>= max_depth
|| dont_descend
)
75 if (cur_lines
>= max_lines
) {
79 if (fgets(buffer
, sizeof(buffer
), stdin
)) {
80 if (buffer
[0] == 'n' || buffer
[0] == 'N')
85 printf("\nUnable to read response, assuming y.\n");
94 static void newline(char *label
)
100 indent(cur_depth
* 2);
104 static void brief_fixnum(lispobj obj
)
106 #ifndef LISP_FEATURE_ALPHA
107 printf("%ld", ((long)obj
)>>2);
109 printf("%d", ((s32
)obj
)>>2);
113 static void print_fixnum(lispobj obj
)
115 #ifndef LISP_FEATURE_ALPHA
116 printf(": %ld", ((long)obj
)>>2);
118 printf(": %d", ((s32
)obj
)>>2);
122 static void brief_otherimm(lispobj obj
)
127 type
= widetag_of(obj
);
129 case CHARACTER_WIDETAG
:
136 printf("#\\Newline");
139 printf("#\\Backspace");
145 strcpy(buffer
, "#\\");
147 strcat(buffer
, "m-");
151 strcat(buffer
, "c-");
154 printf("%s%c", buffer
, c
);
159 case UNBOUND_MARKER_WIDETAG
:
160 printf("<unbound marker>");
164 printf("%s", widetag_names
[type
>> 2]);
169 static void print_otherimm(lispobj obj
)
171 printf(", %s", widetag_names
[widetag_of(obj
) >> 2]);
173 switch (widetag_of(obj
)) {
174 case CHARACTER_WIDETAG
:
180 case UNBOUND_MARKER_WIDETAG
:
184 printf(": data=%ld", (long) (obj
>>8)&0xffffff);
189 static void brief_list(lispobj obj
)
194 if (!is_valid_lisp_addr((os_vm_address_t
)native_pointer(obj
)))
195 printf("(invalid Lisp-level address)");
200 while (lowtag_of(obj
) == LIST_POINTER_LOWTAG
) {
201 struct cons
*cons
= (struct cons
*)native_pointer(obj
);
205 if (++length
>= max_length
) {
210 print_obj("", cons
->car
);
224 #ifdef LISP_FEATURE_X86_64
225 static void print_unknown(lispobj obj
)
227 printf("unknown object: %p", (void *)obj
);
231 static void print_list(lispobj obj
)
233 if (!is_valid_lisp_addr((os_vm_address_t
)native_pointer(obj
))) {
234 printf("(invalid address)");
235 } else if (obj
== NIL
) {
238 struct cons
*cons
= (struct cons
*)native_pointer(obj
);
240 print_obj("car: ", cons
->car
);
241 print_obj("cdr: ", cons
->cdr
);
245 static void brief_struct(lispobj obj
)
247 struct instance
*instance
= (struct instance
*)native_pointer(obj
);
248 if (!is_valid_lisp_addr((os_vm_address_t
)instance
)) {
249 printf("(invalid address)");
251 printf("#<ptr to 0x%08lx instance>",
252 (unsigned long) instance
->slots
[0]);
256 static void print_struct(lispobj obj
)
258 struct instance
*instance
= (struct instance
*)native_pointer(obj
);
261 if (!is_valid_lisp_addr((os_vm_address_t
)instance
)) {
262 printf("(invalid address)");
264 print_obj("type: ", ((struct instance
*)native_pointer(obj
))->slots
[0]);
265 for (i
= 1; i
< HeaderValue(instance
->header
); i
++) {
266 sprintf(buffer
, "slot %d: ", i
);
267 print_obj(buffer
, instance
->slots
[i
]);
272 static void brief_otherptr(lispobj obj
)
274 lispobj
*ptr
, header
;
276 struct symbol
*symbol
;
277 struct vector
*vector
;
280 ptr
= (lispobj
*) native_pointer(obj
);
282 if (!is_valid_lisp_addr((os_vm_address_t
)obj
)) {
283 printf("(invalid address)");
288 type
= widetag_of(header
);
290 case SYMBOL_HEADER_WIDETAG
:
291 symbol
= (struct symbol
*)ptr
;
292 vector
= (struct vector
*)native_pointer(symbol
->name
);
293 for (charptr
= (char *)vector
->data
; *charptr
!= '\0'; charptr
++) {
300 case SIMPLE_BASE_STRING_WIDETAG
:
301 vector
= (struct vector
*)ptr
;
303 for (charptr
= (char *)vector
->data
; *charptr
!= '\0'; charptr
++) {
313 brief_otherimm(header
);
318 static void print_slots(char **slots
, int count
, lispobj
*ptr
)
320 while (count
-- > 0) {
322 print_obj(*slots
++, *ptr
++);
324 print_obj("???: ", *ptr
++);
329 /* FIXME: Yikes! This needs to depend on the values in sbcl.h (or
330 * perhaps be generated automatically by GENESIS as part of
332 static char *symbol_slots
[] = {"value: ", "hash: ",
333 "plist: ", "name: ", "package: ",
334 #ifdef LISP_FEATURE_SB_THREAD
338 static char *ratio_slots
[] = {"numer: ", "denom: ", NULL
};
339 static char *complex_slots
[] = {"real: ", "imag: ", NULL
};
340 static char *code_slots
[] = {"words: ", "entry: ", "debug: ", NULL
};
341 static char *fn_slots
[] = {
342 "self: ", "next: ", "name: ", "arglist: ", "type: ", NULL
};
343 static char *closure_slots
[] = {"fn: ", NULL
};
344 static char *funcallable_instance_slots
[] = {"fn: ", "lexenv: ", "layout: ", NULL
};
345 static char *weak_pointer_slots
[] = {"value: ", NULL
};
346 static char *fdefn_slots
[] = {"name: ", "function: ", "raw_addr: ", NULL
};
347 static char *value_cell_slots
[] = {"value: ", NULL
};
349 static void print_otherptr(lispobj obj
)
351 if (!is_valid_lisp_addr((os_vm_address_t
)obj
)) {
352 printf("(invalid address)");
354 #ifndef LISP_FEATURE_ALPHA
356 unsigned long header
;
357 unsigned long length
;
363 int count
, type
, index
;
364 char *cptr
, buffer
[16];
366 ptr
= (lispobj
*) native_pointer(obj
);
368 printf(" (NULL Pointer)");
373 length
= fixnum_value(*ptr
);
374 count
= HeaderValue(header
);
375 type
= widetag_of(header
);
377 print_obj("header: ", header
);
378 if (!other_immediate_lowtag_p(header
)) {
380 printf("(invalid header object)");
390 printf("%08lx", (unsigned long) *--ptr
);
394 print_slots(ratio_slots
, count
, ptr
);
397 case COMPLEX_WIDETAG
:
398 print_slots(complex_slots
, count
, ptr
);
401 case SYMBOL_HEADER_WIDETAG
:
402 print_slots(symbol_slots
, count
, ptr
);
405 #if N_WORD_BITS == 32
406 case SINGLE_FLOAT_WIDETAG
:
408 printf("%g", ((struct single_float
*)native_pointer(obj
))->value
);
411 case DOUBLE_FLOAT_WIDETAG
:
413 printf("%g", ((struct double_float
*)native_pointer(obj
))->value
);
416 #ifdef LONG_FLOAT_WIDETAG
417 case LONG_FLOAT_WIDETAG
:
419 printf("%Lg", ((struct long_float
*)native_pointer(obj
))->value
);
423 #ifdef COMPLEX_SINGLE_FLOAT_WIDETAG
424 case COMPLEX_SINGLE_FLOAT_WIDETAG
:
426 #ifdef LISP_FEATURE_X86_64
427 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->data
.data
[0]);
429 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->real
);
432 #ifdef LISP_FEATURE_X86_64
433 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->data
.data
[1]);
435 printf("%g", ((struct complex_single_float
*)native_pointer(obj
))->imag
);
440 #ifdef COMPLEX_DOUBLE_FLOAT_WIDETAG
441 case COMPLEX_DOUBLE_FLOAT_WIDETAG
:
443 printf("%g", ((struct complex_double_float
*)native_pointer(obj
))->real
);
445 printf("%g", ((struct complex_double_float
*)native_pointer(obj
))->imag
);
449 #ifdef COMPLEX_LONG_FLOAT_WIDETAG
450 case COMPLEX_LONG_FLOAT_WIDETAG
:
452 printf("%Lg", ((struct complex_long_float
*)native_pointer(obj
))->real
);
454 printf("%Lg", ((struct complex_long_float
*)native_pointer(obj
))->imag
);
458 case SIMPLE_BASE_STRING_WIDETAG
:
459 #ifdef SIMPLE_CHARACTER_STRING_WIDETAG
460 case SIMPLE_CHARACTER_STRING_WIDETAG
: /* FIXME */
463 cptr
= (char *)(ptr
+1);
470 case SIMPLE_VECTOR_WIDETAG
:
472 printf("length = %ld", length
);
475 while (length
-- > 0) {
476 sprintf(buffer
, "%d: ", index
++);
477 print_obj(buffer
, *ptr
++);
481 case INSTANCE_HEADER_WIDETAG
:
483 printf("length = %ld", (long) count
);
485 while (count
-- > 0) {
486 sprintf(buffer
, "%d: ", index
++);
487 print_obj(buffer
, *ptr
++);
491 case SIMPLE_ARRAY_WIDETAG
:
492 case SIMPLE_BIT_VECTOR_WIDETAG
:
493 case SIMPLE_ARRAY_UNSIGNED_BYTE_2_WIDETAG
:
494 case SIMPLE_ARRAY_UNSIGNED_BYTE_4_WIDETAG
:
495 case SIMPLE_ARRAY_UNSIGNED_BYTE_7_WIDETAG
:
496 case SIMPLE_ARRAY_UNSIGNED_BYTE_8_WIDETAG
:
497 case SIMPLE_ARRAY_UNSIGNED_BYTE_15_WIDETAG
:
498 case SIMPLE_ARRAY_UNSIGNED_BYTE_16_WIDETAG
:
499 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
500 case SIMPLE_ARRAY_UNSIGNED_BYTE_29_WIDETAG
:
502 case SIMPLE_ARRAY_UNSIGNED_BYTE_31_WIDETAG
:
503 case SIMPLE_ARRAY_UNSIGNED_BYTE_32_WIDETAG
:
504 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
505 case SIMPLE_ARRAY_UNSIGNED_BYTE_60_WIDETAG
:
507 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
508 case SIMPLE_ARRAY_UNSIGNED_BYTE_63_WIDETAG
:
510 #ifdef SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
511 case SIMPLE_ARRAY_UNSIGNED_BYTE_64_WIDETAG
:
513 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
514 case SIMPLE_ARRAY_SIGNED_BYTE_8_WIDETAG
:
516 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
517 case SIMPLE_ARRAY_SIGNED_BYTE_16_WIDETAG
:
519 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
520 case SIMPLE_ARRAY_SIGNED_BYTE_30_WIDETAG
:
522 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
523 case SIMPLE_ARRAY_SIGNED_BYTE_32_WIDETAG
:
525 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
526 case SIMPLE_ARRAY_SIGNED_BYTE_61_WIDETAG
:
528 #ifdef SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
529 case SIMPLE_ARRAY_SIGNED_BYTE_64_WIDETAG
:
531 case SIMPLE_ARRAY_SINGLE_FLOAT_WIDETAG
:
532 case SIMPLE_ARRAY_DOUBLE_FLOAT_WIDETAG
:
533 #ifdef SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
534 case SIMPLE_ARRAY_LONG_FLOAT_WIDETAG
:
536 #ifdef SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
537 case SIMPLE_ARRAY_COMPLEX_SINGLE_FLOAT_WIDETAG
:
539 #ifdef SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
540 case SIMPLE_ARRAY_COMPLEX_DOUBLE_FLOAT_WIDETAG
:
542 #ifdef SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
543 case SIMPLE_ARRAY_COMPLEX_LONG_FLOAT_WIDETAG
:
545 case COMPLEX_BASE_STRING_WIDETAG
:
546 #ifdef COMPLEX_CHARACTER_STRING_WIDETAG
547 case COMPLEX_CHARACTER_STRING_WIDETAG
:
549 case COMPLEX_VECTOR_NIL_WIDETAG
:
550 case COMPLEX_BIT_VECTOR_WIDETAG
:
551 case COMPLEX_VECTOR_WIDETAG
:
552 case COMPLEX_ARRAY_WIDETAG
:
555 case CODE_HEADER_WIDETAG
:
556 print_slots(code_slots
, count
-1, ptr
);
559 case SIMPLE_FUN_HEADER_WIDETAG
:
560 print_slots(fn_slots
, 5, ptr
);
563 case RETURN_PC_HEADER_WIDETAG
:
564 print_obj("code: ", obj
- (count
* 4));
567 case CLOSURE_HEADER_WIDETAG
:
568 print_slots(closure_slots
, count
, ptr
);
571 case FUNCALLABLE_INSTANCE_HEADER_WIDETAG
:
572 print_slots(funcallable_instance_slots
, count
, ptr
);
575 case VALUE_CELL_HEADER_WIDETAG
:
576 print_slots(value_cell_slots
, 1, ptr
);
581 #ifndef LISP_FEATURE_ALPHA
582 printf("0x%08lx", (unsigned long) *ptr
);
584 printf("0x%016lx", *(lispobj
*)(ptr
+1));
588 case WEAK_POINTER_WIDETAG
:
589 print_slots(weak_pointer_slots
, 1, ptr
);
592 case CHARACTER_WIDETAG
:
593 case UNBOUND_MARKER_WIDETAG
:
595 printf("pointer to an immediate?");
599 print_slots(fdefn_slots
, count
, ptr
);
604 printf("Unknown header object?");
610 static void print_obj(char *prefix
, lispobj obj
)
612 #ifdef LISP_FEATURE_X86_64
613 static void (*verbose_fns
[])(lispobj obj
)
614 = {print_fixnum
, print_struct
, print_otherimm
, print_unknown
,
615 print_unknown
, print_unknown
, print_otherimm
, print_list
,
616 print_fixnum
, print_otherptr
, print_otherimm
, print_unknown
,
617 print_unknown
, print_unknown
, print_otherimm
, print_otherptr
};
618 static void (*brief_fns
[])(lispobj obj
)
619 = {brief_fixnum
, brief_struct
, brief_otherimm
, print_unknown
,
620 print_unknown
, print_unknown
, brief_otherimm
, brief_list
,
621 brief_fixnum
, brief_otherptr
, brief_otherimm
, print_unknown
,
622 print_unknown
, print_unknown
,brief_otherimm
, brief_otherptr
};
624 static void (*verbose_fns
[])(lispobj obj
)
625 = {print_fixnum
, print_struct
, print_otherimm
, print_list
,
626 print_fixnum
, print_otherptr
, print_otherimm
, print_otherptr
};
627 static void (*brief_fns
[])(lispobj obj
)
628 = {brief_fixnum
, brief_struct
, brief_otherimm
, brief_list
,
629 brief_fixnum
, brief_otherptr
, brief_otherimm
, brief_otherptr
};
631 int type
= lowtag_of(obj
);
632 struct var
*var
= lookup_by_obj(obj
);
634 boolean verbose
= cur_depth
< brief_depth
;
636 if (!continue_p(verbose
))
639 if (var
!= NULL
&& var_clock(var
) == cur_clock
)
642 if (var
== NULL
&& is_lisp_pointer(obj
))
643 var
= define_var(NULL
, obj
, 0);
646 var_setclock(var
, cur_clock
);
651 sprintf(buffer
, "$%s=", var_name(var
));
656 printf("%s0x%08lx: ", prefix
, (unsigned long) obj
);
657 if (cur_depth
< brief_depth
) {
658 fputs(lowtag_names
[type
], stdout
);
659 (*verbose_fns
[type
])(obj
);
662 (*brief_fns
[type
])(obj
);
666 printf("$%s", var_name(var
));
669 printf("$%s=", var_name(var
));
670 (*brief_fns
[type
])(obj
);
684 void print(lispobj obj
)
696 void brief_print(lispobj obj
)
710 brief_print(lispobj obj
)
712 printf("lispobj 0x%lx\n", (unsigned long)obj
);
715 #endif /* defined(LISP_FEATURE_SB_LDB) */