? gccsegv.c ? prefetch-gcmark Index: __scm.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/__scm.h,v retrieving revision 1.85 diff -p -u -r1.85 __scm.h --- __scm.h 30 Jun 2002 22:40:01 -0000 1.85 +++ __scm.h 6 Aug 2002 16:05:23 -0000 @@ -194,6 +194,8 @@ #define SCM_DEBUG_CELL_ACCESSES SCM_DEBUG #endif + + /* If SCM_DEBUG_INTERRUPTS is set to 1, with every deferring and allowing of * interrupts a consistency check will be performed. */ Index: gc-card.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/gc-card.c,v retrieving revision 1.2 diff -p -u -r1.2 gc-card.c --- gc-card.c 5 Aug 2002 17:46:34 -0000 1.2 +++ gc-card.c 6 Aug 2002 16:05:23 -0000 @@ -86,12 +86,13 @@ scm_i_sweep_card (scm_t_cell * p, SCM * int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span); int free_count = 0; + ++ scm_gc_running_p; + /* I tried something fancy with shifting by one bit every word from the bitvec in turn, but it wasn't any faster, but quite bit hairier. */ - for (p += offset; p < end; p += span, offset += span) { SCM scmptr = PTR2SCM(p); @@ -268,11 +269,13 @@ scm_i_sweep_card (scm_t_cell * p, SCM * } - SCM_SET_CELL_TYPE (p, scm_tc_free_cell); + SCM_GC_SET_CELL_TYPE (p, scm_tc_free_cell); SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list)); *free_list = PTR2SCM (p); free_count ++; } + + --scm_gc_running_p; return free_count; } #undef FUNC_NAME @@ -292,7 +295,7 @@ scm_init_card_freelist (scm_t_cell * ca */ for (; p > card; p -= span) { - SCM_SET_CELL_TYPE (p, scm_tc_free_cell); + SCM_GC_SET_CELL_TYPE (p, scm_tc_free_cell); SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list)); *free_list = PTR2SCM (p); } @@ -301,7 +304,7 @@ scm_init_card_freelist (scm_t_cell * ca } -#if 0 +#if 1 /* These functions are meant to be called from GDB as a debug aid. @@ -317,6 +320,16 @@ typedef struct scm_t_list_cell_struct { scm_t_bits car; struct scm_t_list_cell_struct * cdr; } scm_t_list_cell; + + +typedef struct scm_t_double_cell +{ + scm_t_bits word_0; + scm_t_bits word_1; + scm_t_bits word_2; + scm_t_bits word_3; +} scm_t_double_cell; + int scm_gc_marked_p (SCM obj) Index: gc-mark.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/gc-mark.c,v retrieving revision 1.2 diff -p -u -r1.2 gc-mark.c --- gc-mark.c 5 Aug 2002 17:46:34 -0000 1.2 +++ gc-mark.c 6 Aug 2002 16:05:23 -0000 @@ -83,8 +83,12 @@ extern unsigned long * __libc_ia64_regis #include #endif +#define NEWMARK - +#ifdef NEWMARK +void enter_mark_loop (void); +void reset_todo_list (void); +#endif #ifdef __ia64__ # define SCM_MARK_BACKING_STORE() do { \ @@ -101,6 +105,7 @@ extern unsigned long * __libc_ia64_regis # define SCM_MARK_BACKING_STORE() #endif +long long cells_marked; /* Entry point for this file. */ @@ -108,10 +113,13 @@ void scm_mark_all (void) { long j; - scm_i_clear_mark_space (); - +#ifdef NEWMARK + reset_todo_list(); +#endif + cells_marked = 0LL; + #ifndef USE_THREADS /* Mark objects on the C stack. */ @@ -157,21 +165,43 @@ scm_mark_all (void) } } } + /* FIXME: we should have a means to register C functions to be run * in different phases of GC */ scm_mark_subr_table (); + #ifndef USE_THREADS scm_gc_mark (scm_root->handle); #endif + + +#ifdef NEWMARK + enter_mark_loop (); +#endif + + + +#if 0 + fprintf (stderr, "Cells marked %lld, %s\n", cells_marked, +#ifdef NEWMARK +"NEWMARK" +#else + "" +#endif + ); +#endif + } /* {Mark/Sweep} */ +long long cells_marked; +#ifndef NEWMARK /* Mark an object precisely, then recurse. */ @@ -185,6 +215,7 @@ scm_gc_mark (SCM ptr) return; SCM_SET_GC_MARK (ptr); + cells_marked ++; scm_gc_mark_dependencies (ptr); } @@ -478,11 +509,13 @@ gc_mark_loop: return; SCM_SET_GC_MARK (ptr); + cells_marked ++; goto scm_mark_dependencies_again; } #undef FUNC_NAME +#endif /* Mark a region conservatively */ @@ -569,5 +602,387 @@ scm_gc_init_mark(void) scm_set_smob_mark (scm_tc16_allocated, allocated_mark); #endif } + + +#ifdef NEWMARK + +/* + We use the following loop: + + while todo != empty: + next_todo := empty + for t in todo: + if t is unmarked: + mark (t) + append pointers(t) to next_todo + todo := next_todo + + + the crux of this loop is *not* to recurse directly on the object T + you are marking: the pointers in T are must be loaded into the L1 + cache, which takes some time. Instead we continue with the next + object to be marked. + + The representation of the todo list is in a single array, + + + [xxxxxxx XXXXXXXXX] + ^last done ^next todo + ^todolist ^end todolist + next todo grows down, todo grows up. If they meet, the array is resized. + + */ + +typedef short int offset_type; +static scm_t_cell ** todo_list; +static scm_t_cell ** end_todo_list; +static offset_type * offset_list; +static offset_type * end_offset_list; + +/* + Last object recursed on. + */ +scm_t_cell ** last_done; +offset_type * last_offset_done; + +/* + The ptr we added last to the NEXT_TODO list. + */ +scm_t_cell ** next_todo; +offset_type * next_offset_todo; + +static void +resize_todo_list (int incr) +{ + int newsize = (end_todo_list - todo_list) + incr; + scm_t_cell ** nmt = malloc (newsize* sizeof (scm_t_cell*)); + int added_size = end_todo_list - next_todo; + int todo_size = last_done - todo_list ; + offset_type * noff = malloc (newsize* sizeof (offset_type)); + + if (!nmt) + abort(); + + memcpy (nmt, todo_list, todo_size * sizeof (scm_t_cell*)); + memcpy (noff, offset_list, todo_size * sizeof (offset_type)); + + memcpy (nmt + newsize - added_size, next_todo, added_size*sizeof(scm_t_cell*)); + memcpy (noff + newsize - added_size, next_offset_todo, added_size * sizeof (offset_type)); + + last_done = nmt + todo_size; + last_offset_done = noff + todo_size; + + end_todo_list = nmt + newsize; + end_offset_list = noff + newsize; + + next_todo = end_todo_list - added_size; + next_offset_todo = end_offset_list - added_size; + + free (todo_list); + todo_list = nmt; + + free (offset_list); + offset_list = noff; +} + +static inline +void +move_to_next_todo () +{ + int todo_size = end_todo_list - next_todo; + memmove (todo_list, next_todo, todo_size* sizeof (scm_t_cell*) ); + memmove (offset_list, next_offset_todo, todo_size * sizeof(offset_type)); + last_done = todo_list + todo_size; + next_todo = end_todo_list; + + next_offset_todo = end_offset_list; + last_offset_done = offset_list + todo_size; +} + +void +reset_todo_list () +{ + last_done = todo_list; + last_offset_done = offset_list; + next_todo = end_todo_list; + next_offset_todo = end_offset_list; +} + +//static inline +//void add_nimm_gc_todo (SCM x) + +#define add_nimm_gc_todo(x) \ +do { \ + if (next_todo == last_done) \ + resize_todo_list (256); \ + \ + next_todo -- ; \ + *next_todo = (scm_t_cell*) SCM_GC_CELL_CARD(x); \ + next_offset_todo --; \ + *next_offset_todo = SCM_GC_CELL_OFFSET(x); \ +} while (0) + +#define add_gc_todo(x) \ +do { \ + if (SCM_NIMP(x)) \ + add_nimm_gc_todo (x); \ +} while (0) + + +#define PREFETCH 22 + +void +enter_mark_loop () +#define FUNC_NAME "enter_mark_loop" +{ + register long i = 0; + + move_to_next_todo(); + while (last_done != todo_list) + { + while (last_done -- != todo_list) + { + offset_type offset = *--last_offset_done; + scm_t_cell * card_header = *last_done; + long * bvec = (long*) card_header->word_0; + SCM ptr = (SCM) (card_header + offset ); + + if (last_done - todo_list > PREFETCH + 1) + __builtin_prefetch (last_done[-PREFETCH],1,1 ); + + if (SCM_C_BVEC_GET(bvec, offset)) + continue; + + SCM_C_BVEC_SET (bvec, offset); + + scm_t_bits cell_type = SCM_GC_CELL_TYPE (ptr); + + switch (SCM_ITAG7 (cell_type)) + { + case scm_tcs_cons_nimcar: + add_gc_todo (SCM_CDR (ptr)); + add_nimm_gc_todo (SCM_CAR(ptr)); + break; + + case scm_tcs_cons_imcar: + add_gc_todo(SCM_CDR (ptr)); + break; + case scm_tc7_pws: + add_gc_todo (SCM_SETTER (ptr)); + add_gc_todo (SCM_PROCEDURE (ptr)); + break; + case scm_tcs_struct: + { + /* XXX - use less explicit code. */ + scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct; + scm_t_bits * vtable_data = (scm_t_bits *) word0; + SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); + long len = SCM_SYMBOL_LENGTH (layout); + char * fields_desc = SCM_SYMBOL_CHARS (layout); + scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); + + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + { + add_gc_todo (SCM_PACK (struct_data[scm_struct_i_procedure])); + add_gc_todo (SCM_PACK (struct_data[scm_struct_i_setter])); + } + if (len) + { + long x; + + for (x = 0; x < len - 2; x += 2, ++struct_data) + if (fields_desc[x] == 'p') + add_gc_todo (SCM_PACK (*struct_data)); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *struct_data++; x; --x, ++struct_data) + add_gc_todo (SCM_PACK (*struct_data)); + else + add_gc_todo (SCM_PACK (*struct_data)); + } + } + /* mark vtable */ + add_gc_todo (SCM_PACK (vtable_data [scm_vtable_index_vtable])); + break; + } + break; + case scm_tcs_closures: + if (SCM_IMP (SCM_ENV (ptr))) + { + add_gc_todo (SCM_CLOSCAR (ptr)); + break ; + } + add_gc_todo (SCM_CLOSCAR (ptr)); + add_gc_todo (SCM_ENV (ptr)); + break ; + case scm_tc7_vector: + i = SCM_VECTOR_LENGTH (ptr); + while (i-- > 0) + { + add_gc_todo (SCM_VELTS (ptr)[i]); + } + break; +#ifdef CCLO + case scm_tc7_cclo: + { + size_t i = SCM_CCLO_LENGTH (ptr); + size_t j; + for (j = 0; j != i; ++j) + { + SCM obj = SCM_CCLO_REF (ptr, j); + add_gc_todo (obj); + } + break; + } +#endif +#ifdef HAVE_ARRAYS + case scm_tc7_bvect: + case scm_tc7_byvect: + case scm_tc7_ivect: + case scm_tc7_uvect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_svect: +#ifdef HAVE_LONG_LONGS + case scm_tc7_llvect: +#endif +#endif + case scm_tc7_string: + break; + + case scm_tc7_wvect: + SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors); + scm_weak_vectors = ptr; + if (SCM_IS_WHVEC_ANY (ptr)) + { + long x; + long len; + int weak_keys; + int weak_values; + + len = SCM_VECTOR_LENGTH (ptr); + weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); + weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); + + for (x = 0; x < len; ++x) + { + SCM alist; + alist = SCM_VELTS (ptr)[x]; +#if 0 + add_gc_todo (alist); /* ugh. fixme. */ +#else + /* mark everything on the alist except the keys or + * values, according to weak_values and weak_keys. */ + while ( SCM_CONSP (alist) + && !SCM_GC_MARK_P (alist) /* ugh, there goes the cache. */ + && SCM_CONSP (SCM_CAR (alist))) + { + SCM kvpair; + SCM next_alist; + + kvpair = SCM_CAR (alist); + next_alist = SCM_CDR (alist); + /* + * Do not do this: + * SCM_SET_GC_MARK (alist); + * SCM_SET_GC_MARK (kvpair); + * + * It may be that either the key or value is protected by + * an escaped reference to part of the spine of this alist. + * If we mark the spine here, and only mark one or neither of the + * key and value, they may never be properly marked. + * This leads to a horrible situation in which an alist containing + * freelist cells is exported. + * + * So only mark the spines of these arrays last of all marking. + * If somebody confuses us by constructing a weak vector + * with a circular alist then we are hosed, but at least we + * won't prematurely drop table entries. + */ + if (!weak_keys) + add_gc_todo (SCM_CAR (kvpair)); + if (!weak_values) + add_gc_todo (SCM_CDR (kvpair)); + alist = next_alist; + } + add_gc_todo (alist); +#endif + } + } + break; + + case scm_tc7_symbol: + add_gc_todo (SCM_PROP_SLOTS (ptr)); + break; + case scm_tc7_variable: + add_gc_todo (SCM_CELL_OBJECT_1 (ptr)); + break; + case scm_tcs_subrs: + break; + case scm_tc7_port: + i = SCM_PTOBNUM (ptr); + +#if (SCM_DEBUG_CELL_ACCESSES == 1) + if (!(i < scm_numptob)) + SCM_MISC_ERROR ("undefined port type", SCM_EOL); +#endif + if (SCM_PTAB_ENTRY(ptr)) + add_gc_todo (SCM_FILENAME (ptr)); + if (scm_ptobs[i].mark) + add_gc_todo ((scm_ptobs[i].mark) (ptr)); + break; + + case scm_tc7_smob: + switch (SCM_TYP16 (ptr)) + { /* should be faster than going through scm_smobs */ + case scm_tc_free_cell: + /* We have detected a free cell. This can happen if non-object data + * on the C stack points into guile's heap and is scanned during + * conservative marking. */ + break; + case scm_tc16_big: + case scm_tc16_real: + case scm_tc16_complex: + break; + default: + i = SCM_SMOBNUM (ptr); +#if (SCM_DEBUG_CELL_ACCESSES == 1) + if (!(i < scm_numsmob)) + SCM_MISC_ERROR ("undefined smob type", SCM_EOL); +#endif + if (scm_smobs[i].mark) + { + add_gc_todo ((scm_smobs[i].mark) (ptr)); + break; + } + } + break; + default: + SCM_MISC_ERROR ("unknown type", SCM_EOL); + } + } + + move_to_next_todo (); + } +} +#undef FUNC_NAME + +void +scm_gc_mark_dependencies (SCM ptr) +{ + abort (); +} + + +void +scm_gc_mark (SCM ptr) +{ + add_gc_todo (ptr); +} + + +#endif Index: gc.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/gc.c,v retrieving revision 1.230 diff -p -u -r1.230 gc.c --- gc.c 4 Aug 2002 14:09:14 -0000 1.230 +++ gc.c 6 Aug 2002 16:05:23 -0000 @@ -90,16 +90,22 @@ extern unsigned long * __libc_ia64_regis unsigned int scm_gc_running_p = 0; -#if (SCM_DEBUG_CELL_ACCESSES == 1) - /* Set this to != 0 if every cell that is accessed shall be checked: */ -unsigned int scm_debug_cell_accesses_p = 1; +int scm_debug_cell_accesses_p = 1; +int scm_expensive_debug_cell_accesses_p = 0; /* Set this to 0 if no additional gc's shall be performed, otherwise set it to * the number of cell accesses after which a gc shall be called. */ -static unsigned int debug_cells_gc_interval = 0; +int scm_debug_cells_gc_interval = 100; + +/* + Global variable, so you can switch it off at runtime. + */ +int scm_i_cell_validation_already_running ; + +#if (SCM_DEBUG_CELL_ACCESSES == 1) /* Assert that the given object is a valid reference to a valid cell. This @@ -111,62 +117,33 @@ static unsigned int debug_cells_gc_inter * periods. */ + void -scm_assert_cell_valid (SCM cell) +scm_i_expensive_validation_check (SCM cell) { - static unsigned int already_running = 0; - - if (!already_running) + if (!scm_in_heap_p (cell)) { - already_running = 1; /* set to avoid recursion */ + fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n", + (unsigned long) SCM_UNPACK (cell)); + abort (); + } - /* - During GC, no user-code should be run, and the guile core should - use non-protected accessors. - */ - if (scm_gc_running_p) - abort(); + /* If desired, perform additional garbage collections after a user + * defined number of cell accesses. + */ + if (scm_debug_cells_gc_interval) + { + static unsigned int counter = 0; - /* - Only scm_in_heap_p is wildly expensive. - */ - if (scm_debug_cell_accesses_p) - if (!scm_in_heap_p (cell)) - { - fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n", - (unsigned long) SCM_UNPACK (cell)); - abort (); - } - - if (!SCM_GC_MARK_P (cell)) + if (counter != 0) { - fprintf (stderr, - "scm_assert_cell_valid: this object is unmarked. \n" - "It has been garbage-collected in the last GC run: " - "%lux\n", - (unsigned long) SCM_UNPACK (cell)); - abort (); + --counter; } - - - /* If desired, perform additional garbage collections after a user - * defined number of cell accesses. - */ - if (scm_debug_cell_accesses_p && debug_cells_gc_interval) + else { - static unsigned int counter = 0; - - if (counter != 0) - { - --counter; - } - else - { - counter = debug_cells_gc_interval; - scm_igc ("scm_assert_cell_valid"); - } + counter = scm_debug_cells_gc_interval; + scm_igc ("scm_assert_cell_valid"); } - already_running = 0; /* re-enable */ } } @@ -185,17 +162,23 @@ SCM_DEFINE (scm_set_debug_cell_accesses_ { if (SCM_FALSEP (flag)) { scm_debug_cell_accesses_p = 0; - } else if (SCM_EQ_P (flag, SCM_BOOL_T)) { - debug_cells_gc_interval = 0; - scm_debug_cell_accesses_p = 1; - } else if (SCM_INUMP (flag)) { - long int f = SCM_INUM (flag); - if (f <= 0) SCM_OUT_OF_RANGE (1, flag); - debug_cells_gc_interval = f; - scm_debug_cell_accesses_p = 1; - } else { - SCM_WRONG_TYPE_ARG (1, flag); } + else if (SCM_EQ_P (flag, SCM_BOOL_T)) + { + scm_debug_cells_gc_interval = 0; + scm_debug_cell_accesses_p = 1; + } + else if (SCM_INUMP (flag)) + { + long int f = SCM_INUM (flag); + if (f <= 0) SCM_OUT_OF_RANGE (1, flag); + scm_debug_cells_gc_interval = f; + scm_debug_cell_accesses_p = 1; + } + else + { + SCM_WRONG_TYPE_ARG (1, flag); + } return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -525,7 +508,7 @@ scm_igc (const char *what) /* During the critical section, only the current thread may run. */ SCM_CRITICAL_SECTION_START; - if (!scm_stack_base || scm_block_gc) + if (!scm_root || !scm_stack_base || scm_block_gc) { --scm_gc_running_p; return; @@ -585,15 +568,15 @@ scm_igc (const char *what) SCM_CRITICAL_SECTION_END; scm_c_hook_run (&scm_after_gc_c_hook, 0); --scm_gc_running_p; -} - - - - - + /* + For debugging purposes, you could do + scm_i_sweep_all_segments("debug"), but then the remains of the + cell aren't left to analyse. + */ + - +} /* {GC Protection Helper Functions} @@ -939,7 +922,7 @@ mark_gc_async (void * hook_data SCM_UNUS * after-gc-hook. */ #if (SCM_DEBUG_CELL_ACCESSES == 1) - if (debug_cells_gc_interval == 0) + if (scm_debug_cells_gc_interval == 0) scm_system_async_mark (gc_async); #else scm_system_async_mark (gc_async); Index: gc.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/gc.h,v retrieving revision 1.95 diff -p -u -r1.95 gc.h --- gc.h 5 Aug 2002 23:04:43 -0000 1.95 +++ gc.h 6 Aug 2002 16:05:23 -0000 @@ -216,6 +216,7 @@ typedef unsigned long scm_t_c_bvec_long; #define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x) #define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 (x, t) +#define SCM_GC_SET_CELL_TYPE(x, t) SCM_GC_SET_CELL_WORD (x, 0, t) /* Freelists consist of linked cells where the type entry holds the value @@ -245,7 +246,11 @@ typedef unsigned long scm_t_c_bvec_long; #if (SCM_DEBUG_CELL_ACCESSES == 1) -SCM_API unsigned int scm_debug_cell_accesses_p; +/* Set this to != 0 if every cell that is accessed shall be checked: + */ +SCM_API int scm_debug_cell_accesses_p; +SCM_API int scm_expensive_debug_cell_accesses_p; +SCM_API int scm_debug_cells_gc_interval ; #endif SCM_API int scm_block_gc; @@ -274,10 +279,11 @@ SCM_API size_t scm_max_segment_size; Deprecated scm_freelist, scm_master_freelist. No warning; this is not a user serviceable part. */ -SCM_API SCM scm_i_freelist; -SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist; -SCM_API SCM scm_i_freelist2; -SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2; +extern SCM scm_i_freelist; +extern struct scm_t_cell_type_statistics scm_i_master_freelist; +extern SCM scm_i_freelist2; +extern struct scm_t_cell_type_statistics scm_i_master_freelist2; + SCM_API unsigned long scm_gc_cells_swept; SCM_API unsigned long scm_gc_cells_collected; Index: init.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/init.c,v retrieving revision 1.137 diff -p -u -r1.137 init.c --- init.c 4 Aug 2002 00:17:18 -0000 1.137 +++ init.c 6 Aug 2002 16:05:23 -0000 @@ -47,6 +47,7 @@ #include #include #include +#include #include "libguile/_scm.h" @@ -167,9 +168,10 @@ restart_stack (void *base) static void start_stack (void *base) { - SCM root; - - root = scm_permanent_object (scm_make_root (SCM_UNDEFINED)); + SCM root = scm_make_root (SCM_UNDEFINED); + assert (root); + scm_permanent_object (root); + scm_set_root (SCM_ROOT_STATE (root)); scm_stack_base = base; Index: inline.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/inline.c,v retrieving revision 1.2 diff -p -u -r1.2 inline.c --- inline.c 4 Aug 2002 00:17:18 -0000 1.2 +++ inline.c 6 Aug 2002 16:05:23 -0000 @@ -39,10 +39,13 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ +#include #include "libguile/scmconfig.h" - +#ifndef HAVE_INLINE #define HAVE_INLINE +#endif + #define EXTERN_INLINE #undef SCM_INLINE_H Index: inline.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/inline.h,v retrieving revision 1.5 diff -p -u -r1.5 inline.h --- inline.h 4 Aug 2002 00:17:18 -0000 1.5 +++ inline.h 6 Aug 2002 16:05:23 -0000 @@ -50,13 +50,13 @@ */ -#if (SCM_DEBUG_CELL_ACCESSES == 1) -#include -#endif - #include "libguile/pairs.h" #include "libguile/gc.h" +#if (SCM_DEBUG_CELL_ACCESSES == 1) +#include +SCM_API void scm_i_expensive_validation_check (SCM); +#endif SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr); SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr, @@ -64,8 +64,6 @@ SCM_API SCM scm_double_cell (scm_t_bits #ifdef HAVE_INLINE - - #ifndef EXTERN_INLINE #define EXTERN_INLINE extern inline #endif @@ -74,6 +72,8 @@ extern unsigned scm_newcell2_count; extern unsigned scm_newcell_count; + + EXTERN_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr) @@ -137,6 +137,10 @@ scm_cell (scm_t_bits car, scm_t_bits cdr #endif +#if (SCM_DEBUG_CELL_ACCESSES == 1) + if (scm_expensive_debug_cell_accesses_p ) + scm_i_expensive_validation_check (z); +#endif return z; } @@ -200,6 +204,48 @@ scm_double_cell (scm_t_bits car, scm_t_b return z; } + +#if (SCM_DEBUG_CELL_ACCESSES == 1) + +extern int scm_i_cell_validation_already_running ; + +EXTERN_INLINE +void +scm_assert_cell_valid (SCM cell) +{ + if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p) + { + scm_i_cell_validation_already_running = 1; /* set to avoid recursion */ + + /* + During GC, no user-code should be run, and the guile core + should use non-protected accessors. + */ + if (scm_gc_running_p) + return; + + /* + Only scm_in_heap_p and rescanning the heap is wildly + expensive. + */ + if (scm_expensive_debug_cell_accesses_p) + scm_i_expensive_validation_check (cell); + + if (!SCM_GC_MARK_P (cell)) + { + fprintf (stderr, + "scm_assert_cell_valid: this object is unmarked. \n" + "It has been garbage-collected in the last GC run: " + "%lux\n", + (unsigned long) SCM_UNPACK (cell)); + abort (); + } + + scm_i_cell_validation_already_running = 0; /* re-enable */ + } +} +#endif + #endif #endif Index: procs.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/procs.c,v retrieving revision 1.69 diff -p -u -r1.69 procs.c --- procs.c 4 Aug 2002 00:17:18 -0000 1.69 +++ procs.c 6 Aug 2002 16:05:23 -0000 @@ -139,7 +139,7 @@ scm_mark_subr_table () long i; for (i = 0; i < scm_subr_table_size; ++i) { - SCM_SET_GC_MARK (scm_subr_table[i].name); + scm_gc_mark (scm_subr_table[i].name); if (scm_subr_table[i].generic && *scm_subr_table[i].generic) scm_gc_mark (*scm_subr_table[i].generic); if (SCM_NIMP (scm_subr_table[i].properties)) Index: root.c =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/root.c,v retrieving revision 1.61 diff -p -u -r1.61 root.c --- root.c 20 Apr 2002 20:57:09 -0000 1.61 +++ root.c 6 Aug 2002 16:05:23 -0000 @@ -100,10 +100,8 @@ SCM scm_make_root (SCM parent) { SCM root; - scm_root_state *root_state; - - root_state = (scm_root_state *) scm_gc_malloc (sizeof (scm_root_state), - "root state"); + scm_root_state * root_state = (scm_root_state *) scm_gc_calloc (sizeof (scm_root_state), + "root state"); if (SCM_ROOTP (parent)) { memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state)); Index: strings.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/strings.h,v retrieving revision 1.41 diff -p -u -r1.41 strings.h --- strings.h 28 Jan 2002 21:15:55 -0000 1.41 +++ strings.h 6 Aug 2002 16:05:23 -0000 @@ -53,11 +53,16 @@ #define SCM_STRINGP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_string)) #define SCM_STRING_UCHARS(x) ((unsigned char *) (SCM_CELL_WORD_1 (x))) #define SCM_STRING_CHARS(x) ((char *) (SCM_CELL_WORD_1 (x))) + + + #define SCM_SET_STRING_CHARS(s, c) (SCM_SET_CELL_WORD_1 ((s), (c))) #define SCM_STRING_MAX_LENGTH ((1UL << 24) - 1UL) #define SCM_STRING_LENGTH(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 8)) #define SCM_MAKE_STRING_TAG(l) ((((scm_t_bits) (l)) << 8) + scm_tc7_string) #define SCM_SET_STRING_LENGTH(s, l) (SCM_SET_CELL_WORD_0 ((s), SCM_MAKE_STRING_TAG (l))) + + Index: struct.h =================================================================== RCS file: /cvsroot/guile/guile/guile-core/libguile/struct.h,v retrieving revision 1.45 diff -p -u -r1.45 struct.h --- struct.h 11 Feb 2002 18:06:49 -0000 1.45 +++ struct.h 6 Aug 2002 16:05:23 -0000 @@ -102,7 +102,7 @@ typedef void (*scm_t_struct_free) (scm_t SCM_API SCM scm_struct_table; #define SCM_STRUCT_GC_CHAIN(X) SCM_CELL_OBJECT_3 (X) -#define SCM_SET_STRUCT_GC_CHAIN(X, Y) SCM_SET_CELL_OBJECT_3 (X, Y) +#define SCM_SET_STRUCT_GC_CHAIN(X, Y) SCM_GC_SET_CELL_OBJECT (X, 3, Y) SCM_API SCM scm_structs_to_free;