:sb-propagate-float-type
:sb-propagate-fun-type
- ;; Setting this makes more debugging information available.
- ;; If you aren't hacking or troubleshooting SBCL itself, you
- ;; probably don't want this set.
+ ;; Make more debugging information available (for debugging SBCL
+ ;; itself). If you aren't hacking or troubleshooting SBCL itself,
+ ;; you probably don't want this set.
;;
;; At least two varieties of debugging information are enabled by this
;; option:
;; readtable configured so that the system sources can be read.
; :sb-show
+ ;; Build SBCL with the old CMU CL low level debugger, "ldb". If
+ ;; are aren't messing with CMU CL at a very low level (e.g.
+ ;; trying to diagnose GC problems) you shouldn't need this.
+ ; :sb-ldb
+
;; This isn't really a target Lisp feature at all, but controls
;; whether the build process produces an after-xc.core file. This
;; can be useful for shortening the edit/compile/debug cycle if
{
int len = strlen(str);
lispobj result = alloc_vector(type_SimpleString, len+1, 8);
- struct vector *vec = (struct vector *)PTR(result);
+ struct vector *vec = (struct vector *)native_pointer(result);
vec->length = make_fixnum(len);
strcpy((char *)vec->data, str);
after_breakpoint=1;
os_flush_icache((os_vm_address_t)next_pc, sizeof(unsigned long));
- ldb_monitor();
+ monitor_or_something();
sigreturn(context);
}
static void
sigill_handler(int signal, siginfo_t *siginfo, os_context_t *context) {
fake_foreign_function_call(context);
- ldb_monitor();
+ monitor_or_something();
}
static void
lispobj *headerp, header;
int type, len;
- headerp = (lispobj *) PTR(object);
+ headerp = (lispobj *) native_pointer(object);
header = *headerp;
type = TypeOf(header);
reg_OCFP));
info->lra = (lispobj)(*os_context_register_addr(context, reg_LRA));
info->code = code_pointer(info->lra);
- pc = (unsigned long)PTR(info->lra);
+ pc = (unsigned long)native_pointer(info->lra);
}
else {
info->frame =
else {
info->code = code_pointer(info->lra);
if (info->code != NULL)
- info->pc = (unsigned long)PTR(info->lra) -
+ info->pc = (unsigned long)native_pointer(info->lra) -
(unsigned long)info->code -
#ifndef alpha
(HEADER_LENGTH(info->code->header) * sizeof(lispobj));
struct function *header;
lispobj name;
- header = (struct function *) PTR(function);
+ header = (struct function *) native_pointer(function);
name = header->name;
if (LowtagOf(name) == type_OtherPointer) {
lispobj *object;
- object = (lispobj *) PTR(name);
+ object = (lispobj *) native_pointer(name);
if (TypeOf(*object) == type_SymbolHeader) {
struct symbol *symbol;
symbol = (struct symbol *) object;
- object = (lispobj *) PTR(symbol->name);
+ object = (lispobj *) native_pointer(symbol->name);
}
if (TypeOf(*object) == type_SimpleString) {
struct vector *string;
{
struct code *code;
- code = (struct code *)PTR(code_obj);
+ code = (struct code *)native_pointer(code_obj);
return (void *)((char *)code + HeaderValue(code->header)*sizeof(lispobj)
+ pc_offset);
}
return 0;
else {
unsigned long code_start;
- struct code *codeptr = (struct code *)PTR(code);
+ struct code *codeptr = (struct code *)native_pointer(code);
#ifdef parisc
unsigned long pc = *os_context_pc_addr(context) & ~3;
#else
fake_foreign_function_call(context);
code = find_code(context);
- codeptr = (struct code *)PTR(code);
+ codeptr = (struct code *)native_pointer(code);
funcall3(SymbolFunction(HANDLE_BREAKPOINT),
compute_offset(context, code),
fake_foreign_function_call(context);
code = find_code(context);
- codeptr = (struct code *)PTR(code);
+ codeptr = (struct code *)native_pointer(code);
/* Don't disallow recursive breakpoint traps. Otherwise, we can't
* use debugger breakpoints anywhere in here. */
/* this can be called for untagged pointers as well as for
descriptors, so this assertion's not applicable
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
*/
- ptr = (lispobj *) PTR(object);
+ ptr = (lispobj *) native_pointer(object);
return ((from_space <= ptr) &&
(ptr < from_space_free_pointer));
{
lispobj *ptr;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- ptr = (lispobj *) PTR(object);
+ ptr = (lispobj *) native_pointer(object);
return ((new_space <= ptr) &&
(ptr < new_space_free_pointer));
lispobj *new;
lispobj *source, *dest;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
gc_assert(from_space_p(object));
gc_assert((nwords & 0x01) == 0);
new_space_free_pointer += nwords;
dest = new;
- source = (lispobj *) PTR(object);
+ source = (lispobj *) native_pointer(object);
#ifdef DEBUG_COPY_VERBOSE
fprintf(stderr,"Copying %d words from %p to %p\n", nwords,source,new);
(unsigned long) start, (unsigned long) object, type);
#endif
- if (Pointerp(object)) {
+ if (is_lisp_pointer(object)) {
/* It be a pointer. */
if (from_space_p(object)) {
/* It currently points to old space. Check for a */
/* forwarding pointer. */
lispobj first_word;
- first_word = *((lispobj *)PTR(object));
- if (Pointerp(first_word) && new_space_p(first_word)) {
+ first_word = *((lispobj *)native_pointer(object));
+ if (is_lisp_pointer(first_word) &&
+ new_space_p(first_word)) {
/* Yep, there be a forwarding pointer. */
*start = first_word;
words_scavenged = 1;
lispobj header;
object = *start;
- forwardp = Pointerp(object) && new_space_p(object);
+ forwardp = is_lisp_pointer(object) && new_space_p(object);
if (forwardp) {
int tag;
nwords = 1;
break;
case type_OtherPointer:
- pointer = (lispobj *) PTR(object);
+ pointer = (lispobj *) native_pointer(object);
header = *pointer;
type = TypeOf(header);
nwords = (sizetab[type])(pointer);
lispobj first;
int type;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* object is a pointer into from space. Not a FP */
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
first = *first_pointer;
/* must transport object -- object may point */
first = *first_pointer = copy;
- gc_assert(Pointerp(first));
+ gc_assert(is_lisp_pointer(first));
gc_assert(!from_space_p(first));
*where = first;
/* if object has already been transported, just return pointer */
first = code->header;
- if (Pointerp(first) && new_space_p(first)) {
+ if (is_lisp_pointer(first) && new_space_p(first)) {
#ifdef DEBUG_CODE_GC
printf("Was already transported\n");
#endif
- return (struct code *) PTR(first);
+ return (struct code *) native_pointer(first);
}
gc_assert(TypeOf(first) == type_CodeHeader);
nwords = CEILING(nwords, 2);
l_new_code = copy_object(l_code, nwords);
- new_code = (struct code *) PTR(l_new_code);
+ new_code = (struct code *) native_pointer(l_new_code);
displacement = l_new_code - l_code;
struct function *fheaderp, *nfheaderp;
lispobj nfheaderl;
- fheaderp = (struct function *) PTR(fheaderl);
+ fheaderp = (struct function *) native_pointer(fheaderl);
gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
/* calcuate the new function pointer and the new */
/* function header */
nfheaderl = fheaderl + displacement;
- nfheaderp = (struct function *) PTR(nfheaderl);
+ nfheaderp = (struct function *) native_pointer(nfheaderl);
/* set forwarding pointer */
#ifdef DEBUG_CODE_GC
/* code data block */
fheaderl = code->entry_points;
while (fheaderl != NIL) {
- fheaderp = (struct function *) PTR(fheaderl);
+ fheaderp = (struct function *) native_pointer(fheaderl);
gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
#if defined(DEBUG_CODE_GC)
printf("Scavenging boxed section of entry point located at 0x%08x.\n",
- (unsigned long) PTR(fheaderl));
+ (unsigned long) native_pointer(fheaderl));
#endif
scavenge(&fheaderp->name, 1);
scavenge(&fheaderp->arglist, 1);
{
struct code *ncode;
- ncode = trans_code((struct code *) PTR(object));
+ ncode = trans_code((struct code *) native_pointer(object));
return (lispobj) LOW_WORD(ncode) | type_OtherPointer;
}
unsigned long offset;
struct code *code, *ncode;
lispobj ret;
- return_pc = (struct function *) PTR(object);
+ return_pc = (struct function *) native_pointer(object);
offset = HeaderValue(return_pc->header) * 4 ;
/* Transport the whole code object */
#endif
ncode = trans_code(code);
if(object==0x304748d7) {
- /* ldb_monitor(); */
+ /* monitor_or_something(); */
}
ret= ((lispobj) LOW_WORD(ncode) + offset) | type_OtherPointer;
#ifdef DEBUG_CODE_GC
unsigned long offset;
struct code *code, *ncode;
- fheader = (struct function *) PTR(object);
+ fheader = (struct function *) native_pointer(object);
offset = HeaderValue(fheader->header) * 4;
/* Transport the whole code object */
lispobj *first_pointer;
/* object is a pointer into from space. Not a FP */
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
*where = *first_pointer = trans_boxed(object);
return 1;
{
lispobj first, *first_pointer;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* object is a pointer into from space. Not a FP. */
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
first = *first_pointer = trans_list(object);
- gc_assert(Pointerp(first));
+ gc_assert(is_lisp_pointer(first));
gc_assert(!from_space_p(first));
*where = first;
lispobj new_list_pointer;
struct cons *cons, *new_cons;
- cons = (struct cons *) PTR(object);
+ cons = (struct cons *) native_pointer(object);
/* ### Don't use copy_object here. */
new_list_pointer = copy_object(object, 2);
- new_cons = (struct cons *) PTR(new_list_pointer);
+ new_cons = (struct cons *) native_pointer(new_list_pointer);
/* Set forwarding pointer. */
cons->car = new_list_pointer;
if (LowtagOf(cdr) != type_ListPointer ||
!from_space_p(cdr) ||
- (Pointerp(first = *(lispobj *)PTR(cdr)) &&
- new_space_p(first)))
+ (is_lisp_pointer(first = *(lispobj *)native_pointer(cdr))
+ && new_space_p(first)))
break;
- cdr_cons = (struct cons *) PTR(cdr);
+ cdr_cons = (struct cons *) native_pointer(cdr);
/* ### Don't use copy_object here */
new_cdr = copy_object(cdr, 2);
- new_cdr_cons = (struct cons *) PTR(new_cdr);
+ new_cdr_cons = (struct cons *) native_pointer(new_cdr);
/* Set forwarding pointer */
cdr_cons->car = new_cdr;
{
lispobj first, *first_pointer;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* Object is a pointer into from space - not a FP */
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
first = *first_pointer = (transother[TypeOf(*first_pointer)])(object);
- gc_assert(Pointerp(first));
+ gc_assert(is_lisp_pointer(first));
gc_assert(!from_space_p(first));
*where = first;
lispobj header;
unsigned long length;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- header = *((lispobj *) PTR(object));
+ header = *((lispobj *) native_pointer(object));
length = HeaderValue(header) + 1;
length = CEILING(length, 2);
unsigned long length;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- header = *((lispobj *) PTR(object));
+ header = *((lispobj *) native_pointer(object));
length = HeaderValue(header) + 1;
length = CEILING(length, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* NOTE: Strings contain one more byte of data than the length */
/* slot indicates. */
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length) + 1;
nwords = CEILING(NWORDS(length, 4) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 32) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 16) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 8) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 4) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 2) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 2 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
#ifdef sparc
nwords = CEILING(length * 4 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 2 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 4 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
#ifdef sparc
nwords = CEILING(length * 8 + 2, 2);
lispobj copy;
struct weak_pointer *wp;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
#if defined(DEBUG_WEAK)
printf("Transporting weak pointer from 0x%08x\n", object);
/* been transported so they can be fixed up in a post-GC pass. */
copy = copy_object(object, WEAK_POINTER_NWORDS);
- wp = (struct weak_pointer *) PTR(copy);
+ wp = (struct weak_pointer *) native_pointer(copy);
/* Push the weak pointer onto the list of weak pointers. */
printf("Value: 0x%08x\n", (unsigned int) value);
#endif
- if (!(Pointerp(value) && from_space_p(value)))
+ if (!(is_lisp_pointer(value) && from_space_p(value)))
continue;
/* Now, we need to check if the object has been */
/* still good and needs to be updated. Otherwise, the */
/* weak pointer needs to be nil'ed out. */
- first_pointer = (lispobj *) PTR(value);
+ first_pointer = (lispobj *) native_pointer(value);
first = *first_pointer;
#if defined(DEBUG_WEAK)
printf("First: 0x%08x\n", (unsigned long) first);
#endif
- if (Pointerp(first) && new_space_p(first))
+ if (is_lisp_pointer(first) && new_space_p(first))
wp->value = first;
else {
wp->value = NIL;
/* the minimum size (in bytes) for a large object*/
unsigned large_object_size = 4 * 4096;
-
-/* Should we filter stack/register pointers? This substantially reduces the
- * number of invalid pointers accepted.
- *
- * FIXME: This is basically constant=1. It will probably degrade
- * interrupt safety during object initialization. But I don't think we
- * should do without it -- the possibility of the GC being too
- * conservative and hence running out of memory is also. Perhaps the
- * interrupt safety issue could be fixed by making the initialization
- * code do WITHOUT-GCING or WITHOUT-INTERRUPTS until the appropriate
- * type bits have been set. (That might be necessary anyway, in order
- * to keep interrupt code's allocation operations from stepping on the
- * interrupted code's allocations.) Or perhaps it could be fixed by
- * making sure that uninitialized memory is zero, reserving the
- * all-zero case for uninitialized memory, and making the
- * is-it-possibly-a-valid-pointer code check for all-zero and return
- * true in that case. Then after either fix, we could get rid of this
- * variable and simply hardwire the system always to do pointer
- * filtering. */
-boolean enable_pointer_filter = 1;
\f
/*
* debugging
lispobj *new;
lispobj *source, *dest;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
gc_assert(from_space_p(object));
gc_assert((nwords & 0x01) == 0);
new = gc_quick_alloc(nwords*4);
dest = new;
- source = (lispobj *) PTR(object);
+ source = (lispobj *) native_pointer(object);
/* Copy the object. */
while (nwords > 0) {
lispobj *source, *dest;
int first_page;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
gc_assert(from_space_p(object));
gc_assert((nwords & 0x01) == 0);
new = gc_quick_alloc_large(nwords*4);
dest = new;
- source = (lispobj *) PTR(object);
+ source = (lispobj *) native_pointer(object);
/* Copy the object. */
while (nwords > 0) {
lispobj *new;
lispobj *source, *dest;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
gc_assert(from_space_p(object));
gc_assert((nwords & 0x01) == 0);
new = gc_quick_alloc_unboxed(nwords*4);
dest = new;
- source = (lispobj *) PTR(object);
+ source = (lispobj *) native_pointer(object);
/* Copy the object. */
while (nwords > 0) {
lispobj *source, *dest;
int first_page;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
gc_assert(from_space_p(object));
gc_assert((nwords & 0x01) == 0);
new = gc_quick_alloc_large_unboxed(nwords*4);
dest = new;
- source = (lispobj *) PTR(object);
+ source = (lispobj *) native_pointer(object);
/* Copy the object. */
while (nwords > 0) {
gc_assert(object != 0x01); /* not a forwarding pointer */
- if (Pointerp(object)) {
+ if (is_lisp_pointer(object)) {
if (from_space_p(object)) {
/* It currently points to old space. Check for a
* forwarding pointer. */
- lispobj *ptr = (lispobj *)PTR(object);
+ lispobj *ptr = (lispobj *)native_pointer(object);
lispobj first_word = *ptr;
if (first_word == 0x01) {
/* Yes, there's a forwarding pointer. */
lispobj *first_pointer;
lispobj copy;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* Object is a pointer into from space - no a FP. */
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
/* must transport object -- object may point to either a function
* header, a closure function header, or to a closure header. */
first_pointer[1] = copy;
}
- gc_assert(Pointerp(copy));
+ gc_assert(is_lisp_pointer(copy));
gc_assert(!from_space_p(copy));
*where = copy;
unsigned d2 = *((unsigned char *)p - 2);
unsigned d3 = *((unsigned char *)p - 3);
unsigned d4 = *((unsigned char *)p - 4);
+#if QSHOW
unsigned d5 = *((unsigned char *)p - 5);
unsigned d6 = *((unsigned char *)p - 6);
+#endif
/* Check for code references. */
/* Check for a 32 bit word that looks like an absolute
/* It will be 0 or the unbound-marker if there are no fixups, and
* will be an other pointer if it is valid. */
- if ((fixups == 0) || (fixups == type_UnboundMarker) || !Pointerp(fixups)) {
+ if ((fixups == 0) || (fixups == type_UnboundMarker) ||
+ !is_lisp_pointer(fixups)) {
/* Check for possible errors. */
if (check_code_fixups)
sniff_code_object(new_code, displacement);
return;
}
- fixups_vector = (struct vector *)PTR(fixups);
+ fixups_vector = (struct vector *)native_pointer(fixups);
/* Could be pointing to a forwarding pointer. */
- if (Pointerp(fixups) && (find_page_index((void*)fixups_vector) != -1)
- && (fixups_vector->header == 0x01)) {
+ if (is_lisp_pointer(fixups) &&
+ (find_page_index((void*)fixups_vector) != -1) &&
+ (fixups_vector->header == 0x01)) {
/* If so, then follow it. */
/*SHOW("following pointer to a forwarding pointer");*/
- fixups_vector = (struct vector *)PTR((lispobj)fixups_vector->length);
+ fixups_vector = (struct vector *)native_pointer((lispobj)fixups_vector->length);
}
/*SHOW("got fixups");*/
nwords = CEILING(nwords, 2);
l_new_code = copy_large_object(l_code, nwords);
- new_code = (struct code *) PTR(l_new_code);
+ new_code = (struct code *) native_pointer(l_new_code);
/* may not have been moved.. */
if (new_code == code)
struct function *fheaderp, *nfheaderp;
lispobj nfheaderl;
- fheaderp = (struct function *) PTR(fheaderl);
+ fheaderp = (struct function *) native_pointer(fheaderl);
gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
/* Calculate the new function pointer and the new */
/* function header. */
nfheaderl = fheaderl + displacement;
- nfheaderp = (struct function *) PTR(nfheaderl);
+ nfheaderp = (struct function *) native_pointer(nfheaderl);
/* Set forwarding pointer. */
((lispobj *)fheaderp)[0] = 0x01;
entry_point != NIL;
entry_point = function_ptr->next) {
- gc_assert(Pointerp(entry_point));
+ gc_assert(is_lisp_pointer(entry_point));
- function_ptr = (struct function *) PTR(entry_point);
+ function_ptr = (struct function *) native_pointer(entry_point);
gc_assert(TypeOf(function_ptr->header) == type_FunctionHeader);
scavenge(&function_ptr->name, 1);
{
struct code *ncode;
- ncode = trans_code((struct code *) PTR(object));
+ ncode = trans_code((struct code *) native_pointer(object));
return (lispobj) ncode | type_OtherPointer;
}
SHOW("/trans_return_pc_header: Will this work?");
- return_pc = (struct function *) PTR(object);
+ return_pc = (struct function *) native_pointer(object);
offset = HeaderValue(return_pc->header) * 4;
/* Transport the whole code object. */
unsigned long offset;
struct code *code, *ncode;
- fheader = (struct function *) PTR(object);
+ fheader = (struct function *) native_pointer(object);
offset = HeaderValue(fheader->header) * 4;
/* Transport the whole code object. */
gc_assert(copy != object);
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
/* Set forwarding pointer. */
first_pointer[0] = 0x01;
{
lispobj first, *first_pointer;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* Object is a pointer into from space - not FP. */
first = trans_list(object);
gc_assert(first != object);
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
/* Set forwarding pointer */
first_pointer[0] = 0x01;
first_pointer[1] = first;
- gc_assert(Pointerp(first));
+ gc_assert(is_lisp_pointer(first));
gc_assert(!from_space_p(first));
*where = first;
return 1;
gc_assert(from_space_p(object));
- cons = (struct cons *) PTR(object);
+ cons = (struct cons *) native_pointer(object);
/* Copy 'object'. */
new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
struct cons *cdr_cons, *new_cdr_cons;
if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
- || (*((lispobj *)PTR(cdr)) == 0x01))
+ || (*((lispobj *)native_pointer(cdr)) == 0x01))
break;
- cdr_cons = (struct cons *) PTR(cdr);
+ cdr_cons = (struct cons *) native_pointer(cdr);
/* Copy 'cdr'. */
new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));
{
lispobj first, *first_pointer;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* Object is a pointer into from space - not FP. */
- first_pointer = (lispobj *) PTR(object);
+ first_pointer = (lispobj *) native_pointer(object);
first = (transother[TypeOf(*first_pointer)])(object);
*where = first;
}
- gc_assert(Pointerp(first));
+ gc_assert(is_lisp_pointer(first));
gc_assert(!from_space_p(first));
return 1;
lispobj header;
unsigned long length;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- header = *((lispobj *) PTR(object));
+ header = *((lispobj *) native_pointer(object));
length = HeaderValue(header) + 1;
length = CEILING(length, 2);
lispobj header;
unsigned long length;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- header = *((lispobj *) PTR(object));
+ header = *((lispobj *) native_pointer(object));
length = HeaderValue(header) + 1;
length = CEILING(length, 2);
unsigned long length;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- header = *((lispobj *) PTR(object));
+ header = *((lispobj *) native_pointer(object));
length = HeaderValue(header) + 1;
length = CEILING(length, 2);
unsigned long length;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- header = *((lispobj *) PTR(object));
+ header = *((lispobj *) native_pointer(object));
length = HeaderValue(header) + 1;
length = CEILING(length, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
/* NOTE: A string contains one more byte of data (a terminating
* '\0' to help when interfacing with C functions) than indicated
* by the length slot. */
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length) + 1;
nwords = CEILING(NWORDS(length, 4) + 2, 2);
/* Scavenge element 0, which may be a hash-table structure. */
scavenge(where+2, 1);
- if (!Pointerp(where[2])) {
+ if (!is_lisp_pointer(where[2])) {
lose("no pointer at %x in hash table", where[2]);
}
- hash_table = (lispobj *)PTR(where[2]);
+ hash_table = (lispobj *)native_pointer(where[2]);
/*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
if (TypeOf(hash_table[0]) != type_InstanceHeader) {
lose("hash table not instance (%x at %x)", hash_table[0], hash_table);
/* Scavenge element 1, which should be some internal symbol that
* the hash table code reserves for marking empty slots. */
scavenge(where+3, 1);
- if (!Pointerp(where[3])) {
+ if (!is_lisp_pointer(where[3])) {
lose("not empty-hash-table-slot symbol pointer: %x", where[3]);
}
empty_symbol = where[3];
/* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
- if (TypeOf(*(lispobj *)PTR(empty_symbol)) != type_SymbolHeader) {
+ if (TypeOf(*(lispobj *)native_pointer(empty_symbol)) != type_SymbolHeader) {
lose("not a symbol where empty-hash-table-slot symbol expected: %x",
- *(lispobj *)PTR(empty_symbol));
+ *(lispobj *)native_pointer(empty_symbol));
}
/* Scavenge hash table, which will fix the positions of the other
scavenge(hash_table, 16);
/* Cross-check the kv_vector. */
- if (where != (lispobj *)PTR(hash_table[9])) {
+ if (where != (lispobj *)native_pointer(hash_table[9])) {
lose("hash_table table!=this table %x", hash_table[9]);
}
{
lispobj index_vector_obj = hash_table[13];
- if (Pointerp(index_vector_obj) &&
- (TypeOf(*(lispobj *)PTR(index_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
- index_vector = ((unsigned int *)PTR(index_vector_obj)) + 2;
+ if (is_lisp_pointer(index_vector_obj) &&
+ (TypeOf(*(lispobj *)native_pointer(index_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
+ index_vector = ((unsigned int *)native_pointer(index_vector_obj)) + 2;
/*FSHOW((stderr, "/index_vector = %x\n",index_vector));*/
- length = fixnum_value(((unsigned int *)PTR(index_vector_obj))[1]);
+ length = fixnum_value(((unsigned int *)native_pointer(index_vector_obj))[1]);
/*FSHOW((stderr, "/length = %d\n", length));*/
} else {
lose("invalid index_vector %x", index_vector_obj);
{
lispobj next_vector_obj = hash_table[14];
- if (Pointerp(next_vector_obj) &&
- (TypeOf(*(lispobj *)PTR(next_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
- next_vector = ((unsigned int *)PTR(next_vector_obj)) + 2;
+ if (is_lisp_pointer(next_vector_obj) &&
+ (TypeOf(*(lispobj *)native_pointer(next_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
+ next_vector = ((unsigned int *)native_pointer(next_vector_obj)) + 2;
/*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/
- next_vector_length = fixnum_value(((unsigned int *)PTR(next_vector_obj))[1]);
+ next_vector_length = fixnum_value(((unsigned int *)native_pointer(next_vector_obj))[1]);
/*FSHOW((stderr, "/next_vector_length = %d\n", next_vector_length));*/
} else {
lose("invalid next_vector %x", next_vector_obj);
* probably other stuff too. Ugh.. */
lispobj hash_vector_obj = hash_table[15];
- if (Pointerp(hash_vector_obj) &&
- (TypeOf(*(lispobj *)PTR(hash_vector_obj))
+ if (is_lisp_pointer(hash_vector_obj) &&
+ (TypeOf(*(lispobj *)native_pointer(hash_vector_obj))
== type_SimpleArrayUnsignedByte32)) {
- hash_vector = ((unsigned int *)PTR(hash_vector_obj)) + 2;
+ hash_vector = ((unsigned int *)native_pointer(hash_vector_obj)) + 2;
/*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/
- gc_assert(fixnum_value(((unsigned int *)PTR(hash_vector_obj))[1])
+ gc_assert(fixnum_value(((unsigned int *)native_pointer(hash_vector_obj))[1])
== next_vector_length);
} else {
hash_vector = NULL;
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 32) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 16) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 8) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 4) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(NWORDS(length, 2) + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 2 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 3 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 2 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 4 + 2, 2);
struct vector *vector;
int length, nwords;
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
- vector = (struct vector *) PTR(object);
+ vector = (struct vector *) native_pointer(object);
length = fixnum_value(vector->length);
nwords = CEILING(length * 6 + 2, 2);
lispobj copy;
/* struct weak_pointer *wp; */
- gc_assert(Pointerp(object));
+ gc_assert(is_lisp_pointer(object));
#if defined(DEBUG_WEAK)
FSHOW((stderr, "Transporting weak pointer from 0x%08x\n", object));
/* been transported so they can be fixed up in a post-GC pass. */
copy = copy_object(object, WEAK_POINTER_NWORDS);
- /* wp = (struct weak_pointer *) PTR(copy);*/
+ /* wp = (struct weak_pointer *) native_pointer(copy);*/
/* Push the weak pointer onto the list of weak pointers. */
lispobj value = wp->value;
lispobj *first_pointer;
- first_pointer = (lispobj *)PTR(value);
+ first_pointer = (lispobj *)native_pointer(value);
/*
FSHOW((stderr, "/weak pointer at 0x%08x\n", (unsigned long) wp));
FSHOW((stderr, "/value: 0x%08x\n", (unsigned long) value));
*/
- if (Pointerp(value) && from_space_p(value)) {
+ if (is_lisp_pointer(value) && from_space_p(value)) {
/* Now, we need to check whether the object has been forwarded. If
* it has been, the weak pointer is still good and needs to be
* updated. Otherwise, the weak pointer needs to be nil'ed
lispobj thing = *start;
/* If thing is an immediate then this is a cons. */
- if (Pointerp(thing)
+ if (is_lisp_pointer(thing)
|| ((thing & 3) == 0) /* fixnum */
|| (TypeOf(thing) == type_BaseChar)
|| (TypeOf(thing) == type_UnboundMarker))
/* If it's not a return address then it needs to be a valid Lisp
* pointer. */
- if (!Pointerp((lispobj)pointer)) {
+ if (!is_lisp_pointer((lispobj)pointer)) {
return 0;
}
/* Check that the object pointed to is consistent with the pointer
- * low tag. */
+ * low tag.
+ *
+ * FIXME: It's not safe to rely on the result from this check
+ * before an object is initialized. Thus, if we were interrupted
+ * just as an object had been allocated but not initialized, the
+ * GC relying on this result could bogusly reclaim the memory.
+ * However, we can't really afford to do without this check. So
+ * we should make it safe somehow.
+ * (1) Perhaps just review the code to make sure
+ * that WITHOUT-GCING or WITHOUT-INTERRUPTS or some such
+ * thing is wrapped around critical sections where allocated
+ * memory type bits haven't been set.
+ * (2) Perhaps find some other hack to protect against this, e.g.
+ * recording the result of the last call to allocate-lisp-memory,
+ * and returning true from this function when *pointer is
+ * a reference to that result. */
switch (LowtagOf((lispobj)pointer)) {
case type_FunctionPointer:
/* Start_addr should be the enclosing code object, or a closure
return 0;
}
/* Is it plausible cons? */
- if ((Pointerp(start_addr[0])
+ if ((is_lisp_pointer(start_addr[0])
|| ((start_addr[0] & 3) == 0) /* fixnum */
|| (TypeOf(start_addr[0]) == type_BaseChar)
|| (TypeOf(start_addr[0]) == type_UnboundMarker))
- && (Pointerp(start_addr[1])
+ && (is_lisp_pointer(start_addr[1])
|| ((start_addr[1] & 3) == 0) /* fixnum */
|| (TypeOf(start_addr[1]) == type_BaseChar)
|| (TypeOf(start_addr[1]) == type_UnboundMarker)))
return 0;
}
/* Is it plausible? Not a cons. XXX should check the headers. */
- if (Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
if (gencgc_verbose)
FSHOW((stderr,
"/Wo2: %x %x %x\n",
* expensive but important, since it vastly reduces the
* probability that random garbage will be bogusly interpreter as
* a pointer which prevents a page from moving. */
- if (enable_pointer_filter && !possibly_valid_dynamic_space_pointer(addr))
+ if (!possibly_valid_dynamic_space_pointer(addr))
return;
/* Work backwards to find a page with a first_object_offset of 0.
size_t count = 1;
lispobj thing = *(lispobj*)start;
- if (Pointerp(thing)) {
+ if (is_lisp_pointer(thing)) {
int page_index = find_page_index((void*)thing);
int to_readonly_space =
(READ_ONLY_SPACE_START <= thing &&
&& (page_table[page_index].bytes_used == 0))
lose ("Ptr %x @ %x sees free page.", thing, start);
/* Check that it doesn't point to a forwarding pointer! */
- if (*((lispobj *)PTR(thing)) == 0x01) {
+ if (*((lispobj *)native_pointer(thing)) == 0x01) {
lose("Ptr %x @ %x sees forwarding ptr.", thing, start);
}
/* Check that its not in the RO space as it would then be a
* the code data block. */
fheaderl = code->entry_points;
while (fheaderl != NIL) {
- fheaderp = (struct function *) PTR(fheaderl);
+ fheaderp = (struct function *) native_pointer(fheaderl);
gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
verify_space(&fheaderp->name, 1);
verify_space(&fheaderp->arglist, 1);
}
}
+#if QSHOW
if (gencgc_verbose > 1) {
int num_dont_move_pages = count_dont_move_pages();
- FSHOW((stderr,
- "/non-movable pages due to conservative pointers = %d (%d bytes)\n",
- num_dont_move_pages,
- /* FIXME: 4096 should be symbolic constant here and
- * prob'ly elsewhere too. */
- num_dont_move_pages * 4096));
+ fprintf(stderr,
+ "/non-movable pages due to conservative pointers = %d (%d bytes)\n",
+ num_dont_move_pages,
+ /* FIXME: 4096 should be symbolic constant here and
+ * prob'ly elsewhere too. */
+ num_dont_move_pages * 4096);
}
+#endif
/* Scavenge all the rest of the roots. */
the stack before doing anything else here */
char untouched[32];
fprintf(stderr, "%s\n",
- (char *)(((struct vector *)PTR(string))->data),untouched);
+ (char *)(((struct vector *)native_pointer(string))->data),untouched);
return NIL;
}
while ( ! (CONTROL_STACK_START <= *current_control_frame_pointer &&
*current_control_frame_pointer <= control_stack_top))
((char*)current_control_frame_pointer) -= sizeof(lispobj);
- ldb_monitor();
+ monitor_or_something();
} else if (!interrupt_maybe_gc(signal, info, context)) {
interrupt_handle_now(signal, info, context);
}
#include "runtime.h"
#include "sbcl.h"
-#include "globals.h"
-#include "vars.h"
-#include "parse.h"
-#include "os.h"
-#include "interrupt.h"
-#include "lispregs.h"
-#include "monitor.h"
+
+/* Almost all of this file can be skipped if we're not supporting LDB. */
+#if defined(LISP_FEATURE_SB_LDB)
+
#include "print.h"
#include "arch.h"
#include "interr.h"
return;
}
if (more_p(ptr)) {
- addr = (lispobj *)PTR((long)parse_addr(ptr));
+ addr = (lispobj *)native_pointer((long)parse_addr(ptr));
if (more_p(ptr)) {
count = parse_number(ptr);
}
{
longjmp(curbuf, 1);
}
+
+#endif /* defined(LISP_FEATURE_SB_LDB) */
+
+/* what we do when things go badly wrong at a low level */
+void
+monitor_or_something()
+{
+#if defined(LISP_FEATURE_SB_LDB)
+ ldb_monitor();
+#else
+ fprintf(stderr, "There's no LDB in this build; exiting.\n");
+ exit(1);
+#endif
+}
* files for more information.
*/
-extern void ldb_monitor(void);
extern void throw_to_monitor(void);
+extern void monitor_or_something(void);
+/* parsing for LDB monitor */
+
/*
* This software is part of the SBCL system. See the README file for
* more information.
#include "runtime.h"
#include "sbcl.h"
+
+#if defined(LISP_FEATURE_SB_LDB)
+
#include "globals.h"
#include "vars.h"
#include "parse.h"
return result;
}
+
+#endif /* defined(LISP_FEATURE_SB_LDB) */
-/* code for low-level debugging output */
+/* code for low-level debugging/diagnostic output */
/*
* This software is part of the SBCL system. See the README file for
/*
* FIXME:
- * 1. Ordinary users won't get much out of this code, so it shouldn't
- * be compiled into the ordinary build of the system. Probably it
- * should be made conditional on the SB-SHOW target feature.
- * 2. Some of the code in here (subtype_Names[] and the various
- * foo_slots[], at least) is deeply broken, depending on fixed
- * (and already out-of-date) values in sbcl.h.
+ * Some of the code in here (subtype_Names[] and the various
+ * foo_slots[], at least) is deeply broken, depending on fixed
+ * (and already out-of-date) values in sbcl.h.
*/
#include <stdio.h>
#include "print.h"
#include "runtime.h"
+
+/* This file can be skipped if we're not supporting LDB. */
+#if defined(LISP_FEATURE_SB_LDB)
+
#include "sbcl.h"
#include "monitor.h"
#include "vars.h"
else {
putchar('(');
while (LowtagOf(obj) == type_ListPointer) {
- struct cons *cons = (struct cons *)PTR(obj);
+ struct cons *cons = (struct cons *)native_pointer(obj);
if (space)
putchar(' ');
} else if (obj == NIL) {
printf(" (NIL)");
} else {
- struct cons *cons = (struct cons *)PTR(obj);
+ struct cons *cons = (struct cons *)native_pointer(obj);
print_obj("car: ", cons->car);
print_obj("cdr: ", cons->cdr);
static void brief_struct(lispobj obj)
{
printf("#<ptr to 0x%08lx instance>",
- (unsigned long) ((struct instance *)PTR(obj))->slots[0]);
+ (unsigned long) ((struct instance *)native_pointer(obj))->slots[0]);
}
static void print_struct(lispobj obj)
{
- struct instance *instance = (struct instance *)PTR(obj);
+ struct instance *instance = (struct instance *)native_pointer(obj);
int i;
char buffer[16];
- print_obj("type: ", ((struct instance *)PTR(obj))->slots[0]);
+ print_obj("type: ", ((struct instance *)native_pointer(obj))->slots[0]);
for (i = 1; i < HeaderValue(instance->header); i++) {
sprintf(buffer, "slot %d: ", i);
print_obj(buffer, instance->slots[i]);
struct vector *vector;
char *charptr;
- ptr = (lispobj *) PTR(obj);
+ ptr = (lispobj *) native_pointer(obj);
if (!is_valid_lisp_addr((os_vm_address_t)obj)) {
printf("(invalid address)");
switch (type) {
case type_SymbolHeader:
symbol = (struct symbol *)ptr;
- vector = (struct vector *)PTR(symbol->name);
+ vector = (struct vector *)native_pointer(symbol->name);
for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
if (*charptr == '"')
putchar('\\');
int count, type, index;
char *cptr, buffer[16];
- ptr = (lispobj*) PTR(obj);
+ ptr = (lispobj*) native_pointer(obj);
if (ptr == NULL) {
printf(" (NULL Pointer)");
return;
case type_SingleFloat:
NEWLINE_OR_RETURN;
- printf("%g", ((struct single_float *)PTR(obj))->value);
+ printf("%g", ((struct single_float *)native_pointer(obj))->value);
break;
case type_DoubleFloat:
NEWLINE_OR_RETURN;
- printf("%g", ((struct double_float *)PTR(obj))->value);
+ printf("%g", ((struct double_float *)native_pointer(obj))->value);
break;
#ifdef type_LongFloat
case type_LongFloat:
NEWLINE_OR_RETURN;
- printf("%Lg", ((struct long_float *)PTR(obj))->value);
+ printf("%Lg", ((struct long_float *)native_pointer(obj))->value);
break;
#endif
#ifdef type_ComplexSingleFloat
case type_ComplexSingleFloat:
NEWLINE_OR_RETURN;
- printf("%g", ((struct complex_single_float *)PTR(obj))->real);
+ printf("%g", ((struct complex_single_float *)native_pointer(obj))->real);
NEWLINE_OR_RETURN;
- printf("%g", ((struct complex_single_float *)PTR(obj))->imag);
+ printf("%g", ((struct complex_single_float *)native_pointer(obj))->imag);
break;
#endif
#ifdef type_ComplexDoubleFloat
case type_ComplexDoubleFloat:
NEWLINE_OR_RETURN;
- printf("%g", ((struct complex_double_float *)PTR(obj))->real);
+ printf("%g", ((struct complex_double_float *)native_pointer(obj))->real);
NEWLINE_OR_RETURN;
- printf("%g", ((struct complex_double_float *)PTR(obj))->imag);
+ printf("%g", ((struct complex_double_float *)native_pointer(obj))->imag);
break;
#endif
#ifdef type_ComplexLongFloat
case type_ComplexLongFloat:
NEWLINE_OR_RETURN;
- printf("%Lg", ((struct complex_long_float *)PTR(obj))->real);
+ printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->real);
NEWLINE_OR_RETURN;
- printf("%Lg", ((struct complex_long_float *)PTR(obj))->imag);
+ printf("%Lg", ((struct complex_long_float *)native_pointer(obj))->imag);
break;
#endif
char buffer[256];
boolean verbose = cur_depth < brief_depth;
-
if (!continue_p(verbose))
return;
print_obj("", obj);
putchar('\n');
}
+
+#else
+
+void
+brief_print(lispobj obj)
+{
+ printf("lispobj 0x%lx\n", (unsigned long)obj);
+}
+
+#endif /* defined(LISP_FEATURE_SB_LDB) */
static unsigned pointer_filter_verbose = 0;
+/* FIXME: This is substantially the same code as in gencgc.c. (There
+ * are some differences, at least (1) the gencgc.c code needs to worry
+ * about return addresses on the stack pinning code objects, (2) the
+ * gencgc.c code needs to worry about the GC maybe happening in an
+ * interrupt service routine when the main thread of control was
+ * interrupted just as it had allocated memory and before it
+ * initialized it, while PURIFY needn't worry about that, and (3) the
+ * gencgc.c code has mutated more under maintenance since the fork
+ * from CMU CL than the code here has.) The two versions should be
+ * made to explicitly share common code, instead of just two different
+ * cut-and-pasted versions. */
static int
valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
{
/* If it's not a return address then it needs to be a valid Lisp
* pointer. */
- if (!Pointerp((lispobj)pointer))
+ if (!is_lisp_pointer((lispobj)pointer))
return 0;
/* Check that the object pointed to is consistent with the pointer
return 0;
}
/* Is it plausible cons? */
- if((Pointerp(start_addr[0])
+ if((is_lisp_pointer(start_addr[0])
|| ((start_addr[0] & 3) == 0) /* fixnum */
|| (TypeOf(start_addr[0]) == type_BaseChar)
|| (TypeOf(start_addr[0]) == type_UnboundMarker))
- && (Pointerp(start_addr[1])
+ && (is_lisp_pointer(start_addr[1])
|| ((start_addr[1] & 3) == 0) /* fixnum */
|| (TypeOf(start_addr[1]) == type_BaseChar)
|| (TypeOf(start_addr[1]) == type_UnboundMarker))) {
return 0;
}
/* Is it plausible? Not a cons. X should check the headers. */
- if(Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ if(is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
if (pointer_filter_verbose) {
fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned int) pointer,
(unsigned int) start_addr, *start_addr);
nwords = 1 + HeaderValue(header);
/* Allocate it */
- old = (lispobj *)PTR(thing);
+ old = (lispobj *)native_pointer(thing);
if (constant) {
new = read_only_free;
read_only_free += CEILING(nwords, 2);
static lispobj
ptrans_instance(lispobj thing, lispobj header, boolean constant)
{
- lispobj layout = ((struct instance *)PTR(thing))->slots[0];
- lispobj pure = ((struct instance *)PTR(layout))->slots[15];
+ lispobj layout = ((struct instance *)native_pointer(thing))->slots[0];
+ lispobj pure = ((struct instance *)native_pointer(layout))->slots[15];
switch (pure) {
case T:
nwords = 1 + HeaderValue(header);
/* Allocate it */
- old = (lispobj *)PTR(thing);
+ old = (lispobj *)native_pointer(thing);
new = static_free;
static_free += CEILING(nwords, 2);
nwords = 1 + HeaderValue(header);
/* Allocate it */
- old = (lispobj *)PTR(thing);
+ old = (lispobj *)native_pointer(thing);
new = static_free;
static_free += CEILING(nwords, 2);
nwords = 1 + HeaderValue(header);
/* Allocate it */
- old = (lispobj *)PTR(thing);
+ old = (lispobj *)native_pointer(thing);
new = read_only_free;
read_only_free += CEILING(nwords, 2);
int nwords;
lispobj result, *new;
- vector = (struct vector *)PTR(thing);
+ vector = (struct vector *)native_pointer(thing);
nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5);
if (boxed && !constant) {
/* It will be 0 or the unbound-marker if there are no fixups, and
* will be an other-pointer to a vector if it is valid. */
- if ((fixups==0) || (fixups==type_UnboundMarker) || !Pointerp(fixups)) {
+ if ((fixups==0) ||
+ (fixups==type_UnboundMarker) ||
+ !is_lisp_pointer(fixups)) {
#ifdef GENCGC
/* Check for a possible errors. */
sniff_code_object(new_code,displacement);
return;
}
- fixups_vector = (struct vector *)PTR(fixups);
+ fixups_vector = (struct vector *)native_pointer(fixups);
/* Could be pointing to a forwarding pointer. */
- if (Pointerp(fixups) && (dynamic_pointer_p(fixups))
+ if (is_lisp_pointer(fixups) && (dynamic_pointer_p(fixups))
&& forwarding_pointer_p(*(lispobj *)fixups_vector)) {
/* If so then follow it. */
- fixups_vector = (struct vector *)PTR(*(lispobj *)fixups_vector);
+ fixups_vector = (struct vector *)native_pointer(*(lispobj *)fixups_vector);
}
if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
int nwords;
lispobj func, result;
- code = (struct code *)PTR(thing);
+ code = (struct code *)native_pointer(thing);
nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
new = (struct code *)read_only_free;
/* Put in forwarding pointers for all the functions. */
for (func = code->entry_points;
func != NIL;
- func = ((struct function *)PTR(func))->next) {
+ func = ((struct function *)native_pointer(func))->next) {
gc_assert(LowtagOf(func) == type_FunctionPointer);
- *(lispobj *)PTR(func) = result + (func - thing);
+ *(lispobj *)native_pointer(func) = result + (func - thing);
}
/* Arrange to scavenge the debug info later. */
pscav(&new->entry_points, 1, 1);
for (func = new->entry_points;
func != NIL;
- func = ((struct function *)PTR(func))->next) {
+ func = ((struct function *)native_pointer(func))->next) {
gc_assert(LowtagOf(func) == type_FunctionPointer);
gc_assert(!dynamic_pointer_p(func));
#ifdef __i386__
/* Temporarly convert the self pointer to a real function
pointer. */
- ((struct function *)PTR(func))->self -= RAW_ADDR_OFFSET;
+ ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET;
#endif
- pscav(&((struct function *)PTR(func))->self, 2, 1);
+ pscav(&((struct function *)native_pointer(func))->self, 2, 1);
#ifdef __i386__
- ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET;
+ ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET;
#endif
- pscav_later(&((struct function *)PTR(func))->name, 3);
+ pscav_later(&((struct function *)native_pointer(func))->name, 3);
}
return result;
* scavenged, because if it had been scavenged, forwarding pointers
* would have been left behind for all the entry points. */
- function = (struct function *)PTR(thing);
- code = (PTR(thing)-(HeaderValue(function->header)*sizeof(lispobj))) |
+ function = (struct function *)native_pointer(thing);
+ code =
+ (native_pointer(thing) -
+ (HeaderValue(function->header)*sizeof(lispobj))) |
type_OtherPointer;
/* This will cause the function's header to be replaced with a
else {
/* It's some kind of closure-like thing. */
nwords = 1 + HeaderValue(header);
- old = (lispobj *)PTR(thing);
+ old = (lispobj *)native_pointer(thing);
/* Allocate the new one. */
if (TypeOf(header) == type_FuncallableInstanceHeader) {
code = thing - HeaderValue(header)*sizeof(lispobj);
/* Make sure it's been transported. */
- new = *(lispobj *)PTR(code);
+ new = *(lispobj *)native_pointer(code);
if (!forwarding_pointer_p(new))
new = ptrans_code(code);
do {
/* Allocate a new cons cell. */
- old = (struct cons *)PTR(thing);
+ old = (struct cons *)native_pointer(thing);
if (constant) {
new = (struct cons *)read_only_free;
read_only_free += WORDS_PER_CONS;
length++;
} while (LowtagOf(thing) == type_ListPointer &&
dynamic_pointer_p(thing) &&
- !(forwarding_pointer_p(*(lispobj *)PTR(thing))));
+ !(forwarding_pointer_p(*(lispobj *)native_pointer(thing))));
/* Scavenge the list we just copied. */
pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
pscav(&code->entry_points, 1, 1);
for (func = code->entry_points;
func != NIL;
- func = ((struct function *)PTR(func))->next) {
+ func = ((struct function *)native_pointer(func))->next) {
gc_assert(LowtagOf(func) == type_FunctionPointer);
gc_assert(!dynamic_pointer_p(func));
#ifdef __i386__
/* Temporarly convert the self pointer to a real function
* pointer. */
- ((struct function *)PTR(func))->self -= RAW_ADDR_OFFSET;
+ ((struct function *)native_pointer(func))->self -= RAW_ADDR_OFFSET;
#endif
- pscav(&((struct function *)PTR(func))->self, 2, 1);
+ pscav(&((struct function *)native_pointer(func))->self, 2, 1);
#ifdef __i386__
- ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET;
+ ((struct function *)native_pointer(func))->self += RAW_ADDR_OFFSET;
#endif
- pscav_later(&((struct function *)PTR(func))->name, 3);
+ pscav_later(&((struct function *)native_pointer(func))->name, 3);
}
return CEILING(nwords,2);
while (nwords > 0) {
thing = *addr;
- if (Pointerp(thing)) {
+ if (is_lisp_pointer(thing)) {
/* It's a pointer. Is it something we might have to move? */
if (dynamic_pointer_p(thing)) {
/* Maybe. Have we already moved it? */
- thingp = (lispobj *)PTR(thing);
+ thingp = (lispobj *)native_pointer(thing);
header = *thingp;
- if (Pointerp(header) && forwarding_pointer_p(header))
+ if (is_lisp_pointer(header) && forwarding_pointer_p(header))
/* Yep, so just copy the forwarding pointer. */
thing = header;
else {
#endif
\f
/* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */
-
static void
sigint_handler(int signal, siginfo_t *info, void *void_context)
{
- printf("\nSIGINT hit at 0x%08lX\n",
- (unsigned long) *os_context_pc_addr(void_context));
- ldb_monitor();
+ lose("\nSIGINT hit at 0x%08lX\n",
+ (unsigned long) *os_context_pc_addr(void_context));
}
/* (This is not static, because we want to be able to call it from
define_var("nil", NIL, 1);
define_var("t", T, 1);
- set_lossage_handler(ldb_monitor);
+ set_lossage_handler(monitor_or_something);
#if 0
os_init();
#define type_Bits 8
#define type_Mask ((1<<type_Bits)-1)
-/* FIXME: There seems to be no reason that TypeOf, HeaderValue,
- * Pointerp, PTR, CONS, SYMBOL, and FDEFN can't be defined
- * as (possibly inline) functions instead of macros. */
+/* FIXME: There seems to be no reason that TypeOf, HeaderValue, CONS,
+ * SYMBOL, and FDEFN can't be defined as (possibly inline) functions
+ * instead of macros. */
#define TypeOf(obj) ((obj)&type_Mask)
#define HeaderValue(obj) ((unsigned long) ((obj)>>type_Bits))
-#define Pointerp(obj) ((obj) & 0x01)
-#define PTR(obj) ((unsigned long)((obj)&~lowtag_Mask))
-
#define CONS(obj) ((struct cons *)((obj)-type_ListPointer))
#define SYMBOL(obj) ((struct symbol *)((obj)-type_OtherPointer))
#define FDEFN(obj) ((struct fdefn *)((obj)-type_OtherPointer))
typedef u32 lispobj;
+/* Is the Lisp object obj something with pointer nature (as opposed to
+ * e.g. a fixnum or character or unbound marker)? */
+static inline int
+is_lisp_pointer(lispobj obj)
+{
+ return obj & 1;
+}
+
+/* Convert from a lispobj with type bits to a native (ordinary
+ * C/assembly) pointer to the beginning of the object. */
+static inline lispobj
+native_pointer(lispobj obj)
+{
+ return obj & ~lowtag_Mask;
+}
+
/* FIXME: There seems to be no reason that make_fixnum and fixnum_value
* can't be implemented as (possibly inline) functions. */
#define make_fixnum(n) ((lispobj)((n)<<2))
* in GCC later than version 2.7 or so. If you are using some
* compiler that doesn't understand this, you could could just
* change it to "typedef void never_returns" and nothing would
- * break, you might just get a few more bytes of compiled code or
+ * break, though you might get a few more bytes of compiled code or
* a few more compiler warnings. -- WHN 2000-10-21 */
typedef volatile void never_returns;
struct vector *symbol_name;
while (search_for_type(type_SymbolHeader, start, count)) {
- symbol = (struct symbol *)PTR((lispobj)*start);
+ symbol = (struct symbol *)native_pointer((lispobj)*start);
if (LowtagOf(symbol->name) == type_OtherPointer) {
- symbol_name = (struct vector *)PTR(symbol->name);
+ symbol_name = (struct vector *)native_pointer(symbol->name);
if (is_valid_lisp_addr((os_vm_address_t)symbol_name) &&
TypeOf(symbol_name->header) == type_SimpleString &&
strcmp((char *)symbol_name->data, name) == 0)
sigill_handler(int signal, siginfo_t *siginfo, void *void_context) {
os_context_t *context = (os_context_t*)void_context;
fake_foreign_function_call(context);
- ldb_monitor();
+ monitor_or_something();
}
void
;;; four numeric fields, is used for versions which aren't released
;;; but correspond only to CVS tags or snapshots.
-"0.6.12.47"
+"0.6.12.48"
projects / sbcl.git / commitdiff