X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fruntime%2Fgc-common.c;h=c99afb7122c95029d43d151f7fb08a001481b2b4;hb=ab9c6bbaaa409e815a1c9696885c9621b429aed6;hp=d01a4fc369e9b233554ecc941cb4c089273995d6;hpb=d9d75ffc2f436767c81a4091ec4ff7006c1ec676;p=sbcl.git diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index d01a4fc..c99afb7 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -382,7 +382,7 @@ scav_code_header(lispobj *where, lispobj object) scavenge(&function_ptr->name, 1); scavenge(&function_ptr->arglist, 1); scavenge(&function_ptr->type, 1); - scavenge(&function_ptr->xrefs, 1); + scavenge(&function_ptr->info, 1); } return n_words; @@ -2433,9 +2433,8 @@ maybe_gc(os_context_t *context) * outer context. */ #ifndef LISP_FEATURE_WIN32 - check_gc_signals_unblocked_in_sigset_or_lose - (os_context_sigmask_addr(context)); - unblock_gc_signals(); + check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context)); + unblock_gc_signals(0, 0); #endif FSHOW((stderr, "/maybe_gc: calling SUB_GC\n")); /* FIXME: Nothing must go wrong during GC else we end up running @@ -2454,17 +2453,244 @@ maybe_gc(os_context_t *context) * here. */ ((SymbolValue(INTERRUPTS_ENABLED,thread) != NIL) || (SymbolValue(ALLOW_WITH_INTERRUPTS,thread) != NIL))) { +#ifndef LISP_FEATURE_WIN32 sigset_t *context_sigmask = os_context_sigmask_addr(context); - if (!deferrables_blocked_in_sigset_p(context_sigmask)) { - FSHOW((stderr, "/maybe_gc: calling POST_GC\n")); + if (!deferrables_blocked_p(context_sigmask)) { thread_sigmask(SIG_SETMASK, context_sigmask, 0); - check_gc_signals_unblocked_or_lose(); + check_gc_signals_unblocked_or_lose(0); +#endif + FSHOW((stderr, "/maybe_gc: calling POST_GC\n")); funcall0(StaticSymbolFunction(POST_GC)); +#ifndef LISP_FEATURE_WIN32 } else { FSHOW((stderr, "/maybe_gc: punting on POST_GC due to blockage\n")); } +#endif } undo_fake_foreign_function_call(context); FSHOW((stderr, "/maybe_gc: returning\n")); return (gc_happened != NIL); } + +#define BYTES_ZERO_BEFORE_END (1<<12) + +/* There used to be a similar function called SCRUB-CONTROL-STACK in + * Lisp and another called zero_stack() in cheneygc.c, but since it's + * shorter to express in, and more often called from C, I keep only + * the C one after fixing it. -- MG 2009-03-25 */ + +/* Zero the unused portion of the control stack so that old objects + * are not kept alive because of uninitialized stack variables. + * + * "To summarize the problem, since not all allocated stack frame + * slots are guaranteed to be written by the time you call an another + * function or GC, there may be garbage pointers retained in your dead + * stack locations. The stack scrubbing only affects the part of the + * stack from the SP to the end of the allocated stack." - ram, on + * cmucl-imp, Tue, 25 Sep 2001 + * + * So, as an (admittedly lame) workaround, from time to time we call + * scrub-control-stack to zero out all the unused portion. This is + * supposed to happen when the stack is mostly empty, so that we have + * a chance of clearing more of it: callers are currently (2002.07.18) + * REPL, SUB-GC and sig_stop_for_gc_handler. */ + +/* Take care not to tread on the guard page and the hard guard page as + * it would be unkind to sig_stop_for_gc_handler. Touching the return + * guard page is not dangerous. For this to work the guard page must + * be zeroed when protected. */ + +/* FIXME: I think there is no guarantee that once + * BYTES_ZERO_BEFORE_END bytes are zero the rest are also zero. This + * may be what the "lame" adjective in the above comment is for. In + * this case, exact gc may lose badly. */ +void +scrub_control_stack(void) +{ + struct thread *th = arch_os_get_current_thread(); + os_vm_address_t guard_page_address = CONTROL_STACK_GUARD_PAGE(th); + os_vm_address_t hard_guard_page_address = CONTROL_STACK_HARD_GUARD_PAGE(th); + lispobj *sp; +#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK + sp = (lispobj *)&sp - 1; +#else + sp = current_control_stack_pointer; +#endif + scrub: + if ((((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) && + ((os_vm_address_t)sp >= hard_guard_page_address)) || + (((os_vm_address_t)sp < (guard_page_address + os_vm_page_size)) && + ((os_vm_address_t)sp >= guard_page_address) && + (th->control_stack_guard_page_protected != NIL))) + return; +#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD + do { + *sp = 0; + } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1)); + if ((os_vm_address_t)sp < (hard_guard_page_address + os_vm_page_size)) + return; + do { + if (*sp) + goto scrub; + } while (((unsigned long)sp--) & (BYTES_ZERO_BEFORE_END - 1)); +#else + do { + *sp = 0; + } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1)); + if ((os_vm_address_t)sp >= hard_guard_page_address) + return; + do { + if (*sp) + goto scrub; + } while (((unsigned long)++sp) & (BYTES_ZERO_BEFORE_END - 1)); +#endif +} + +#if !defined(LISP_FEATURE_X86) && !defined(LISP_FEATURE_X86_64) + +/* scavenging interrupt contexts */ + +static int boxed_registers[] = BOXED_REGISTERS; + +static void +scavenge_interrupt_context(os_context_t *context) +{ + int i; + +#ifdef reg_LIP + unsigned long lip; + unsigned long lip_offset; + int lip_register_pair; +#endif + unsigned long pc_code_offset; + +#ifdef ARCH_HAS_LINK_REGISTER + unsigned long lr_code_offset; +#endif +#ifdef ARCH_HAS_NPC_REGISTER + unsigned long npc_code_offset; +#endif +#ifdef DEBUG_SCAVENGE_VERBOSE + fprintf(stderr, "Scavenging interrupt context at 0x%x\n",context); +#endif + +#ifdef reg_LIP + /* Find the LIP's register pair and calculate its offset */ + /* before we scavenge the context. */ + + /* + * I (RLT) think this is trying to find the boxed register that is + * closest to the LIP address, without going past it. Usually, it's + * reg_CODE or reg_LRA. But sometimes, nothing can be found. + */ + lip = *os_context_register_addr(context, reg_LIP); + /* 0x7FFFFFFF on 32-bit platforms; + 0x7FFFFFFFFFFFFFFF on 64-bit platforms */ + lip_offset = (((unsigned long)1) << (N_WORD_BITS - 1)) - 1; + lip_register_pair = -1; + for (i = 0; i < (int)(sizeof(boxed_registers) / sizeof(int)); i++) { + unsigned long reg; + unsigned long offset; + int index; + + index = boxed_registers[i]; + reg = *os_context_register_addr(context, index); + /* would be using PTR if not for integer length issues */ + if ((reg & ~((1L<uc_mcontext.gregs[2]. But gregs[2] is REG_nPC. Is + * that what we really want? My guess is that that is not what we + * want, so if lip_register_pair is -1, we don't touch reg_LIP at + * all. But maybe it doesn't really matter if LIP is trashed? + */ + if (lip_register_pair >= 0) { + *os_context_register_addr(context, reg_LIP) = + *os_context_register_addr(context, lip_register_pair) + + lip_offset; + } +#endif /* reg_LIP */ + + /* Fix the PC if it was in from space */ + if (from_space_p(*os_context_pc_addr(context))) + *os_context_pc_addr(context) = + *os_context_register_addr(context, reg_CODE) + pc_code_offset; + +#ifdef ARCH_HAS_LINK_REGISTER + /* Fix the LR ditto; important if we're being called from + * an assembly routine that expects to return using blr, otherwise + * harmless */ + if (from_space_p(*os_context_lr_addr(context))) + *os_context_lr_addr(context) = + *os_context_register_addr(context, reg_CODE) + lr_code_offset; +#endif + +#ifdef ARCH_HAS_NPC_REGISTER + if (from_space_p(*os_context_npc_addr(context))) + *os_context_npc_addr(context) = + *os_context_register_addr(context, reg_CODE) + npc_code_offset; +#endif /* ARCH_HAS_NPC_REGISTER */ +} + +void scavenge_interrupt_contexts(struct thread *th) +{ + int i, index; + os_context_t *context; + + index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th)); + +#ifdef DEBUG_SCAVENGE_VERBOSE + fprintf(stderr, "%d interrupt contexts to scan\n",index); +#endif + + for (i = 0; i < index; i++) { + context = th->interrupt_contexts[i]; + scavenge_interrupt_context(context); + } +} +#endif /* x86oid targets */