From: Douglas K. <sn...@us...> - 2014-11-23 06:50:29
|
The branch "master" has been updated in SBCL: via 32210d57279546a94e78e26ad7aef3f88bb89b2d (commit) from 4ec2cd58af023512d60249bbaca6514edc93b6b9 (commit) - Log ----------------------------------------------------------------- commit 32210d57279546a94e78e26ad7aef3f88bb89b2d Author: Douglas Katzman <do...@go...> Date: Sun Nov 23 01:47:15 2014 -0500 Some improvements to the low-level debugger. - fix printing of UCS4 strings - make "p *A-SYMBOL*" work if *A-SYMBOL* has a UCS4 name - generate 'classoid.h' from Genesis, and print instances with their classoid's name --- src/compiler/generic/genesis.lisp | 5 ++- src/runtime/gc-common.c | 43 +++++++++++++++ src/runtime/print.c | 106 +++++++++++++++++++++++-------------- src/runtime/search.c | 27 +++++++++- 4 files changed, 138 insertions(+), 43 deletions(-) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index df6e813..b7496d1 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -3083,7 +3083,9 @@ core and return a descriptor to it." (format t "#ifndef LANGUAGE_ASSEMBLY~2%") (format t "struct ~A {~%" (cstring (dd-name dd))) (format t " lispobj header;~%") - (format t " lispobj layout;~%") + ;; "self layout" slots are named '_layout' instead of 'layout' so that + ;; classoid's expressly declared layout isn't renamed as a special-case. + (format t " lispobj _layout;~%") #!-interleaved-raw-slots (progn ;; Note: if the structure has no raw slots, but has an even number of @@ -3561,6 +3563,7 @@ initially undefined function references:~2%") (string-downcase (string (sb!vm:primitive-object-name obj))))))) (dolist (class '(hash-table + classoid layout sb!c::compiled-debug-info sb!c::compiled-debug-fun diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 9d72ca6..1529892 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -3164,3 +3164,46 @@ scavenge_interrupt_contexts(struct thread *th) } } #endif /* x86oid targets */ + +// The following accessors, which take a valid native pointer as input +// and return a Lisp string, are designed to be foolproof during GC, +// hence all the forwarding checks. + +#if defined(LISP_FEATURE_SB_LDB) +#include "genesis/classoid.h" +struct vector * symbol_name(lispobj * sym) +{ + if (forwarding_pointer_p(sym)) + sym = native_pointer((lispobj)forwarding_pointer_value(sym)); + if (lowtag_of(((struct symbol*)sym)->name) != OTHER_POINTER_LOWTAG) + return NULL; + lispobj * name = native_pointer(((struct symbol*)sym)->name); + if (forwarding_pointer_p(name)) + name = native_pointer((lispobj)forwarding_pointer_value(name)); + return (struct vector*)name; +} +struct vector * classoid_name(lispobj * classoid) +{ + if (forwarding_pointer_p(classoid)) + classoid = native_pointer((lispobj)forwarding_pointer_value(classoid)); + lispobj sym = ((struct classoid*)classoid)->name; + return lowtag_of(sym) != OTHER_POINTER_LOWTAG ? NULL + : symbol_name(native_pointer(sym)); +} +struct vector * layout_classoid_name(lispobj * layout) +{ + if (forwarding_pointer_p(layout)) + layout = native_pointer((lispobj)forwarding_pointer_value(layout)); + lispobj classoid = ((struct layout*)layout)->classoid; + return lowtag_of(classoid) != INSTANCE_POINTER_LOWTAG ? NULL + : classoid_name(native_pointer(classoid)); +} +struct vector * instance_classoid_name(lispobj * instance) +{ + if (forwarding_pointer_p(instance)) + instance = native_pointer((lispobj)forwarding_pointer_value(instance)); + lispobj layout = ((struct instance*)instance)->slots[0]; + return lowtag_of(layout) != INSTANCE_POINTER_LOWTAG ? NULL + : layout_classoid_name(native_pointer(layout)); +} +#endif diff --git a/src/runtime/print.c b/src/runtime/print.c index fc281e1..1518cd0 100644 --- a/src/runtime/print.c +++ b/src/runtime/print.c @@ -437,14 +437,40 @@ static void print_list(lispobj obj) } } +// takes native pointer as input +char * simple_base_stringize(struct vector * string) +{ + if (widetag_of(string->header) == SIMPLE_BASE_STRING_WIDETAG) + return (char*)string->data; + int length = string->length; + char * newstring = malloc(length+1); + uint32_t * data = (uint32_t*)string->data; + int i; + for(i=0;i<length;++i) + newstring[i] = data[i] < 128 ? data[i] : '?'; + newstring[length] = 0; + return newstring; +} + static void brief_struct(lispobj obj) { struct instance *instance = (struct instance *)native_pointer(obj); if (!is_valid_lisp_addr((os_vm_address_t)instance)) { printf("(invalid address)"); } else { - printf("#<ptr to 0x%08lx instance>", - (unsigned long) instance->slots[0]); + extern struct vector * instance_classoid_name(lispobj*); + struct vector * classoid_name; + classoid_name = instance_classoid_name((lispobj*)instance); + if ( classoid_name ) { + char * namestring = simple_base_stringize(classoid_name); + printf("#<ptr to 0x%08lx %s instance>", + (unsigned long) instance->slots[0], namestring); + if ( namestring != (char*)classoid_name->data ) + free(namestring); + } else { + printf("#<ptr to 0x%08lx instance>", + (unsigned long) instance->slots[0]); + } } } @@ -464,6 +490,38 @@ static void print_struct(lispobj obj) } } +static void show_string(struct vector * string) +{ + int ucs4_p = 0; + int i, len = fixnum_value(string->length); + +#ifdef SIMPLE_CHARACTER_STRING_WIDETAG + if (widetag_of(string->header) == SIMPLE_CHARACTER_STRING_WIDETAG) { + ucs4_p = 1; + putchar('u'); /* an arbitrary notational convention */ + } +#endif + putchar('"'); + for (i=0 ; i<len ; i++) { + // hopefully the compiler will optimize out the ucs4_p test + // when the runtime is built without Unicode support + int ch; + if (ucs4_p) + ch = i[(uint32_t*)string->data]; + else + ch = i[(char*)string->data]; + if (ch >= 32 && ch < 127) { + if (ch == '"' || ch == '\\') + putchar('\\'); + putchar(ch); + } else { + printf(ch > 0xffff ? "\\U%08X" : ch > 0xff ? "\\u%04X" : "\\x%02X", + ch); + } + } + putchar('"'); +} + static void brief_otherptr(lispobj obj) { lispobj *ptr, header; @@ -493,39 +551,11 @@ static void brief_otherptr(lispobj obj) break; case SIMPLE_BASE_STRING_WIDETAG: - vector = (struct vector *)ptr; - putchar('"'); - for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) { - if (*charptr == '"') - putchar('\\'); - putchar(*charptr); - } - putchar('"'); - break; - -#ifdef LISP_FEATURE_SB_UNICODE +#ifdef SIMPLE_CHARACTER_STRING_WIDETAG case SIMPLE_CHARACTER_STRING_WIDETAG: - vector = (struct vector *)ptr; - fputs("u\"", stdout); - { - int i, ch, len = fixnum_value(vector->length); - uint32_t *chars = (uint32_t*)vector->data; - for (i=0 ; i<len ; i++) { - ch = chars[i]; - if (ch >= 32 && ch < 127) { - if (ch == '"' || ch == '\\') - putchar('\\'); - putchar(ch); - } else { - // ambiguous, e.g. #\xaaa is either #\GUJARATI_LETTER_PA - // or #\FEMININE_ORDINAL_INDICATOR + #\a. oh well. - printf("\\x%x", ch); - } - } - } - putchar('"'); - break; #endif + show_string((struct vector*)ptr); + break; default: printf("#<ptr to "); @@ -580,7 +610,7 @@ static void print_otherptr(lispobj obj) u32 length; #endif int count, type, index; - char *cptr, buffer[16]; + char buffer[16]; ptr = (lispobj*) native_pointer(obj); if (ptr == NULL) { @@ -678,14 +708,10 @@ static void print_otherptr(lispobj obj) case SIMPLE_BASE_STRING_WIDETAG: #ifdef SIMPLE_CHARACTER_STRING_WIDETAG - case SIMPLE_CHARACTER_STRING_WIDETAG: /* FIXME */ + case SIMPLE_CHARACTER_STRING_WIDETAG: #endif NEWLINE_OR_RETURN; - cptr = (char *)(ptr+1); - putchar('"'); - while (length-- > 0) - putchar(*cptr++); - putchar('"'); + show_string((struct vector*)native_pointer(obj)); break; case SIMPLE_VECTOR_WIDETAG: diff --git a/src/runtime/search.c b/src/runtime/search.c index 12e1c61..0f6d846 100644 --- a/src/runtime/search.c +++ b/src/runtime/search.c @@ -36,10 +36,26 @@ boolean search_for_type(int type, lispobj **start, int *count) return 0; } +static int strcmp_ucs4_ascii(uint32_t* a, char* b) +{ + int i = 0; + + // Lisp terminates UCS4 strings with NULL bytes - probably to no avail + // since null-terminated UCS4 isn't a common convention for any foreign ABI - + // but length has been pre-checked, so hitting an ASCII null is a win. + while (a[i] == b[i]) + if (b[i] == 0) + return 0; + else + ++i; + return a[i] - b[i]; // same return convention as strcmp() +} + boolean search_for_symbol(char *name, lispobj **start, int *count) { struct symbol *symbol; struct vector *symbol_name; + int namelen = strlen(name); while (search_for_type(SYMBOL_HEADER_WIDETAG, start, count)) { symbol = (struct symbol *)native_pointer((lispobj)*start); @@ -48,8 +64,15 @@ boolean search_for_symbol(char *name, lispobj **start, int *count) if (is_valid_lisp_addr((os_vm_address_t)symbol_name) && /* FIXME: Broken with more than one type of string (i.e. even broken given (VECTOR NIL) */ - widetag_of(symbol_name->header) == SIMPLE_BASE_STRING_WIDETAG && - strcmp((char *)symbol_name->data, name) == 0) + ((widetag_of(symbol_name->header) == SIMPLE_BASE_STRING_WIDETAG + && fixnum_value(symbol_name->length) == namelen + && !strcmp((char *)symbol_name->data, name)) +#ifdef LISP_FEATURE_SB_UNICODE + || (widetag_of(symbol_name->header) == SIMPLE_CHARACTER_STRING_WIDETAG + && fixnum_value(symbol_name->length) == namelen + && !strcmp_ucs4_ascii((uint32_t*)symbol_name->data, name)) +#endif + )) return 1; } (*start) += 2; ----------------------------------------------------------------------- hooks/post-receive -- SBCL |