X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/bb1180ef26f737d0a071a8e830e295f6c88570af..9bc6fb0a7d91ae9a6c57cedb76022043db413ba5:/libguile/gc.c diff --git a/libguile/gc.c b/libguile/gc.c index de1b3ee0d..a96e9df9c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -107,8 +107,6 @@ unsigned int scm_gc_running_p = 0; #if (SCM_DEBUG_CELL_ACCESSES == 1) -scm_t_bits scm_tc16_allocated; - /* Set this to != 0 if every cell that is accessed shall be checked: */ unsigned int scm_debug_cell_accesses_p = 1; @@ -243,8 +241,8 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will * trigger a GC. * - * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be - * reclaimed by a GC triggered by must_malloc. If less than this is + * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must + * be reclaimed by a GC triggered by a malloc. If less than this is * reclaimed, the trigger threshold is raised. [I don't know what a * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to * work around a oscillation that caused almost constant GC.] @@ -279,9 +277,9 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb # define SCM_HEAP_SEG_SIZE 32768L #else # ifdef sequent -# define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_cell)) +# define SCM_HEAP_SEG_SIZE (7000L * sizeof (scm_t_cell)) # else -# define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_cell)) +# define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell)) # endif #endif /* Make heap grow with factor 1.5 */ @@ -289,7 +287,7 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb #define SCM_INIT_MALLOC_LIMIT 100000 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10) -/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_cell * span) +/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_t_cell * span) aligned inner bounds for allocated storage */ #ifdef PROT386 @@ -301,12 +299,12 @@ size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span))) # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p)) # else -# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L)) -# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p)) +# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_t_cell)*(span)-1L) & ((long)(p)+sizeof(scm_t_cell)*(span)-1L)) +# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_t_cell)*(span)-1L) & (long)(p)) # endif /* UNICOS */ #endif /* PROT386 */ -#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) +#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0) #define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1) #define CLUSTER_SIZE_IN_BYTES(freelist) \ @@ -361,7 +359,7 @@ scm_t_freelist scm_master_freelist2 = { }; /* scm_mtrigger - * is the number of bytes of must_malloc allocation needed to trigger gc. + * is the number of bytes of malloc allocation needed to trigger gc. */ unsigned long scm_mtrigger; @@ -695,65 +693,6 @@ SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1 } #undef FUNC_NAME - -SCM -scm_debug_newcell (void) -{ - SCM new; - - scm_newcell_count++; - if (scm_debug_check_freelist) - { - scm_check_freelist (scm_freelist); - scm_gc(); - } - - /* The rest of this is supposed to be identical to the SCM_NEWCELL - macro. */ - if (SCM_NULLP (scm_freelist)) - { - new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist); - SCM_GC_SET_ALLOCATED (new); - } - else - { - new = scm_freelist; - scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); - SCM_GC_SET_ALLOCATED (new); - } - - return new; -} - -SCM -scm_debug_newcell2 (void) -{ - SCM new; - - scm_newcell2_count++; - if (scm_debug_check_freelist) - { - scm_check_freelist (scm_freelist2); - scm_gc (); - } - - /* The rest of this is supposed to be identical to the SCM_NEWCELL - macro. */ - if (SCM_NULLP (scm_freelist2)) - { - new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2); - SCM_GC_SET_ALLOCATED (new); - } - else - { - new = scm_freelist2; - scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); - SCM_GC_SET_ALLOCATED (new); - } - - return new; -} - #endif /* GUILE_DEBUG_FREELIST */ @@ -1605,7 +1544,7 @@ gc_sweep_freelist_finish (scm_t_freelist *freelist) #define NEXT_DATA_CELL(ptr, span) \ do { \ - scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \ + scm_t_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \ (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \ CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \ : nxt__); \ @@ -1696,15 +1635,17 @@ scm_gc_sweep () unsigned long int length = SCM_VECTOR_LENGTH (scmptr); if (length > 0) { - m += length * sizeof (scm_t_bits); - scm_must_free (SCM_VECTOR_BASE (scmptr)); + scm_gc_free (SCM_VECTOR_BASE (scmptr), + length * sizeof (scm_t_bits), + "vector"); } break; } #ifdef CCLO case scm_tc7_cclo: - m += (SCM_CCLO_LENGTH (scmptr) * sizeof (SCM)); - scm_must_free (SCM_CCLO_BASE (scmptr)); + scm_gc_free (SCM_CCLO_BASE (scmptr), + SCM_CCLO_LENGTH (scmptr) * sizeof (SCM), + "compiled closure"); break; #endif #ifdef HAVE_ARRAYS @@ -1713,8 +1654,10 @@ scm_gc_sweep () unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); if (length > 0) { - m += sizeof (long) * ((length + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - scm_must_free (SCM_BITVECTOR_BASE (scmptr)); + scm_gc_free (SCM_BITVECTOR_BASE (scmptr), + (sizeof (long) + * ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)), + "vector"); } } break; @@ -1728,17 +1671,19 @@ scm_gc_sweep () case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: - m += SCM_UVECTOR_LENGTH (scmptr) * scm_uniform_element_size (scmptr); - scm_must_free (SCM_UVECTOR_BASE (scmptr)); + scm_gc_free (SCM_UVECTOR_BASE (scmptr), + (SCM_UVECTOR_LENGTH (scmptr) + * scm_uniform_element_size (scmptr)), + "vector"); break; #endif case scm_tc7_string: - m += SCM_STRING_LENGTH (scmptr) + 1; - scm_must_free (SCM_STRING_CHARS (scmptr)); + scm_gc_free (SCM_STRING_CHARS (scmptr), + SCM_STRING_LENGTH (scmptr) + 1, "string"); break; case scm_tc7_symbol: - m += SCM_SYMBOL_LENGTH (scmptr) + 1; - scm_must_free (SCM_SYMBOL_CHARS (scmptr)); + scm_gc_free (SCM_SYMBOL_CHARS (scmptr), + SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol"); break; case scm_tc7_variable: break; @@ -1749,6 +1694,7 @@ scm_gc_sweep () if SCM_OPENP (scmptr) { int k = SCM_PTOBNUM (scmptr); + size_t mm; #if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST)) if (!(k < scm_numptob)) SCM_MISC_ERROR ("undefined port type", SCM_EOL); @@ -1759,7 +1705,23 @@ scm_gc_sweep () /* Yes, I really do mean scm_ptobs[k].free */ /* rather than ftobs[k].close. .close */ /* is for explicit CLOSE-PORT by user */ - m += (scm_ptobs[k].free) (scmptr); + mm = scm_ptobs[k].free (scmptr); + + if (mm != 0) + { +#if SCM_ENABLE_DEPRECATED == 1 + scm_c_issue_deprecation_warning + ("Returning non-0 from a port free function is " + "deprecated. Use scm_gc_free et al instead."); + scm_c_issue_deprecation_warning_fmt + ("(You just returned non-0 while freeing a %s.)", + SCM_PTOBNAME (k)); + m += mm; +#else + abort (); +#endif + } + SCM_SETSTREAM (scmptr, 0); scm_remove_from_port_table (scmptr); scm_gc_ports_collected++; @@ -1774,13 +1736,14 @@ scm_gc_sweep () break; #ifdef SCM_BIGDIG case scm_tc16_big: - m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); - scm_must_free (SCM_BDIGITS (scmptr)); + scm_gc_free (SCM_BDIGITS (scmptr), + ((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG + / SCM_CHAR_BIT)), "bignum"); break; #endif /* def SCM_BIGDIG */ case scm_tc16_complex: - m += sizeof (scm_t_complex); - scm_must_free (SCM_COMPLEX_MEM (scmptr)); + scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double), + "complex"); break; default: { @@ -1791,7 +1754,24 @@ scm_gc_sweep () SCM_MISC_ERROR ("undefined smob type", SCM_EOL); #endif if (scm_smobs[k].free) - m += (scm_smobs[k].free) (scmptr); + { + size_t mm; + mm = scm_smobs[k].free (scmptr); + if (mm != 0) + { +#if SCM_ENABLE_DEPRECATED == 1 + scm_c_issue_deprecation_warning + ("Returning non-0 from a smob free function is " + "deprecated. Use scm_gc_free et al instead."); + scm_c_issue_deprecation_warning_fmt + ("(You just returned non-0 while freeing a %s.)", + SCM_SMOBNAME (k)); + m += mm; +#else + abort(); +#endif + } + } break; } } @@ -1861,12 +1841,18 @@ scm_gc_sweep () scm_gc_yield -= scm_cells_allocated; if (scm_mallocated < m) - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - abort (); + { + /* The byte count of allocated objects has underflowed. This is + probably because you forgot to report the sizes of objects you + have allocated, by calling scm_done_malloc or some such. When + the GC freed them, it subtracted their size from + scm_mallocated, which underflowed. */ + fprintf (stderr, + "scm_gc_sweep: Byte count of allocated objects has underflowed.\n" + "This is probably because the GC hasn't been correctly informed\n" + "about object sizes\n"); + abort (); + } scm_mallocated -= m; scm_gc_malloc_collected = m; @@ -1875,175 +1861,214 @@ scm_gc_sweep () -/* {Front end to malloc} - * - * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, - * scm_done_free - * - * These functions provide services comparable to malloc, realloc, and - * free. They should be used when allocating memory that will be under - * control of the garbage collector, i.e., if the memory may be freed - * during garbage collection. +/* Function for non-cell memory management. */ -/* scm_must_malloc - * Return newly malloced storage or throw an error. - * - * The parameter WHAT is a string for error reporting. - * If the threshold scm_mtrigger will be passed by this - * allocation, or if the first call to malloc fails, - * garbage collect -- on the presumption that some objects - * using malloced storage may be collected. - * - * The limit scm_mtrigger may be raised by this allocation. - */ void * -scm_must_malloc (size_t size, const char *what) +scm_malloc (size_t size) { void *ptr; - unsigned long nm = scm_mallocated + size; - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); + if (size == 0) + return NULL; + + SCM_SYSCALL (ptr = malloc (size)); + if (ptr) + return ptr; + + scm_igc ("malloc"); + SCM_SYSCALL (ptr = malloc (size)); + if (ptr) + return ptr; + + scm_memory_error ("malloc"); +} + +void * +scm_realloc (void *mem, size_t size) +{ + void *ptr; + + SCM_SYSCALL (ptr = realloc (mem, size)); + if (ptr) + return ptr; + + scm_igc ("realloc"); + SCM_SYSCALL (ptr = realloc (mem, size)); + if (ptr) + return ptr; - if (nm <= scm_mtrigger) + scm_memory_error ("realloc"); +} + +char * +scm_strndup (const char *str, size_t n) +{ + char *dst = scm_malloc (n+1); + memcpy (dst, str, n); + dst[n] = 0; + return dst; +} + +char * +scm_strdup (const char *str) +{ + return scm_strndup (str, strlen (str)); +} + +void +scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) +{ + scm_mallocated += size; + + if (scm_mallocated > scm_mtrigger) { - SCM_SYSCALL (ptr = malloc (size)); - if (NULL != ptr) + scm_igc (what); + if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - scm_mallocated = nm; -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_register (ptr, what); -#endif - return ptr; + if (scm_mallocated > scm_mtrigger) + scm_mtrigger = scm_mallocated + scm_mallocated / 2; + else + scm_mtrigger += scm_mtrigger / 2; } } - scm_igc (what); - - nm = scm_mallocated + size; +#ifdef GUILE_DEBUG_MALLOC + if (mem) + scm_malloc_register (mem, what); +#endif +} - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); +void +scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what) +{ + scm_mallocated -= size; - SCM_SYSCALL (ptr = malloc (size)); - if (NULL != ptr) - { - scm_mallocated = nm; - - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - unsigned long old_trigger = scm_mtrigger; - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - if (scm_mtrigger < old_trigger) - abort (); - } #ifdef GUILE_DEBUG_MALLOC - scm_malloc_register (ptr, what); + if (mem) + scm_malloc_unregister (mem); #endif +} - return ptr; - } +void * +scm_gc_malloc (size_t size, const char *what) +{ + /* XXX - The straightforward implementation below has the problem + that it might call the GC twice, once in scm_malloc and then + again in scm_gc_register_collectable_memory. We don't really + want the second GC since it will not find new garbage. + */ - scm_memory_error (what); + void *ptr = scm_malloc (size); + scm_gc_register_collectable_memory (ptr, size, what); + return ptr; } - -/* scm_must_realloc - * is similar to scm_must_malloc. - */ void * -scm_must_realloc (void *where, - size_t old_size, - size_t size, - const char *what) +scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what) { - void *ptr; - unsigned long nm; + /* XXX - see scm_gc_malloc. */ - if (size <= old_size) - return where; + void *ptr = scm_realloc (mem, new_size); + scm_gc_unregister_collectable_memory (mem, old_size, what); + scm_gc_register_collectable_memory (ptr, new_size, what); + return ptr; +} - nm = scm_mallocated + size - old_size; +void +scm_gc_free (void *mem, size_t size, const char *what) +{ + scm_gc_unregister_collectable_memory (mem, size, what); + free (mem); +} - if (nm < (size - old_size)) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); +char * +scm_gc_strndup (const char *str, size_t n, const char *what) +{ + char *dst = scm_gc_malloc (n+1, what); + memcpy (dst, str, n); + dst[n] = 0; + return dst; +} - if (nm <= scm_mtrigger) - { - SCM_SYSCALL (ptr = realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_reregister (where, ptr, what); -#endif - return ptr; - } - } +char * +scm_gc_strdup (const char *str, const char *what) +{ + return scm_gc_strndup (str, strlen (str), what); +} - scm_igc (what); +#if SCM_ENABLE_DEPRECATED == 1 - nm = scm_mallocated + size - old_size; +/* {Deprecated front end to malloc} + * + * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc, + * scm_done_free + * + * These functions provide services comparable to malloc, realloc, and + * free. They should be used when allocating memory that will be under + * control of the garbage collector, i.e., if the memory may be freed + * during garbage collection. + * + * They are deprecated because they weren't really used the way + * outlined above, and making sure to return the right amount from + * smob free routines was sometimes difficult when dealing with nested + * data structures. We basically want everybody to review their code + * and use the more symmetrical scm_gc_malloc/scm_gc_free functions + * instead. In some cases, where scm_must_malloc has been used + * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free. + */ - if (nm < (size - old_size)) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); +void * +scm_must_malloc (size_t size, const char *what) +{ + scm_c_issue_deprecation_warning + ("scm_must_malloc is deprecated. " + "Use scm_gc_malloc and scm_gc_free instead."); - SCM_SYSCALL (ptr = realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - unsigned long old_trigger = scm_mtrigger; - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - if (scm_mtrigger < old_trigger) - abort (); - } -#ifdef GUILE_DEBUG_MALLOC - scm_malloc_reregister (where, ptr, what); -#endif - return ptr; - } + return scm_gc_malloc (size, what); +} - scm_memory_error (what); +void * +scm_must_realloc (void *where, + size_t old_size, + size_t size, + const char *what) +{ + scm_c_issue_deprecation_warning + ("scm_must_realloc is deprecated. " + "Use scm_gc_realloc and scm_gc_free instead."); + + return scm_gc_realloc (where, old_size, size, what); } char * scm_must_strndup (const char *str, size_t length) { - char * dst = scm_must_malloc (length + 1, "scm_must_strndup"); - memcpy (dst, str, length); - dst[length] = 0; - return dst; + scm_c_issue_deprecation_warning + ("scm_must_strndup is deprecated. " + "Use scm_gc_strndup and scm_gc_free instead."); + + return scm_gc_strndup (str, length, "string"); } char * scm_must_strdup (const char *str) { - return scm_must_strndup (str, strlen (str)); + scm_c_issue_deprecation_warning + ("scm_must_strdup is deprecated. " + "Use scm_gc_strdup and scm_gc_free instead."); + + return scm_gc_strdup (str, "string"); } void scm_must_free (void *obj) #define FUNC_NAME "scm_must_free" { + scm_c_issue_deprecation_warning + ("scm_must_free is deprecated. " + "Use scm_gc_malloc and scm_gc_free instead."); + #ifdef GUILE_DEBUG_MALLOC scm_malloc_unregister (obj); #endif @@ -2055,78 +2080,27 @@ scm_must_free (void *obj) #undef FUNC_NAME -/* Announce that there has been some malloc done that will be freed - * during gc. A typical use is for a smob that uses some malloced - * memory but can not get it from scm_must_malloc (for whatever - * reason). When a new object of this smob is created you call - * scm_done_malloc with the size of the object. When your smob free - * function is called, be sure to include this size in the return - * value. - * - * If you can't actually free the memory in the smob free function, - * for whatever reason (like reference counting), you still can (and - * should) report the amount of memory freed when you actually free it. - * Do it by calling scm_done_malloc with the _negated_ size. Clever, - * eh? Or even better, call scm_done_free. */ - void scm_done_malloc (long size) { - if (size < 0) { - if (scm_mallocated < size) - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - abort (); - } else { - unsigned long nm = scm_mallocated + size; - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - } + scm_c_issue_deprecation_warning + ("scm_done_malloc is deprecated. " + "Use scm_gc_register_collectable_memory instead."); - scm_mallocated += size; - - if (scm_mallocated > scm_mtrigger) - { - scm_igc ("foreign mallocs"); - if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) - { - if (scm_mallocated > scm_mtrigger) - scm_mtrigger = scm_mallocated + scm_mallocated / 2; - else - scm_mtrigger += scm_mtrigger / 2; - } - } + scm_gc_register_collectable_memory (NULL, size, "foreign mallocs"); } void scm_done_free (long size) { - if (size >= 0) { - if (scm_mallocated < size) - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - abort (); - } else { - unsigned long nm = scm_mallocated - size; - if (nm < size) - /* The byte count of allocated objects has overflowed. This is - probably because you forgot to report the correct size of freed - memory in some of your smob free methods. */ - abort (); - } + scm_c_issue_deprecation_warning + ("scm_done_free is deprecated. " + "Use scm_gc_unregister_collectable_memory instead."); - scm_mallocated -= size; + scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs"); } +#endif /* SCM_ENABLE_DEPRECATED == 1 */ /* {Heap Segments} @@ -2227,9 +2201,9 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) NEXT_DATA_CELL (ptr, span); while (ptr < seg_end) { - scm_cell *nxt = ptr; - scm_cell *prv = NULL; - scm_cell *last_card = NULL; + scm_t_cell *nxt = ptr; + scm_t_cell *prv = NULL; + scm_t_cell *last_card = NULL; int n_data_cells = (SCM_GC_CARD_N_DATA_CELLS / span) * SCM_CARDS_PER_CLUSTER - 1; NEXT_DATA_CELL(nxt, span); @@ -2242,7 +2216,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) while (n_data_cells--) { - scm_cell *card = SCM_GC_CELL_CARD (ptr); + scm_t_cell *card = SCM_GC_CELL_CARD (ptr); SCM scmptr = PTR2SCM (ptr); nxt = ptr; NEXT_DATA_CELL (nxt, span); @@ -2265,7 +2239,7 @@ init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist) /* sanity check */ { - scm_cell *ref = seg_end; + scm_t_cell *ref = seg_end; NEXT_DATA_CELL (ref, span); if (ref != ptr) /* [cmm] looks like the segment size doesn't divide cleanly by @@ -2370,7 +2344,7 @@ alloc_some_heap (scm_t_freelist *freelist, policy_on_error error_policy) #endif if (len < min_cells) len = min_cells + freelist->cluster_size; - len *= sizeof (scm_cell); + len *= sizeof (scm_t_cell); /* force new sampling */ freelist->collected = LONG_MAX; } @@ -2611,7 +2585,7 @@ scm_gc_unregister_roots (SCM *b, unsigned long n) scm_gc_unregister_root (p); } -int terminating; +int scm_i_terminating; /* called on process termination. */ #ifdef HAVE_ATEXIT @@ -2628,7 +2602,7 @@ cleanup (int status, void *arg) #endif #endif { - terminating = 1; + scm_i_terminating = 1; scm_flush_all_ports (); } @@ -2703,10 +2677,6 @@ scm_init_storage () size_t init_heap_size_2; size_t j; -#if (SCM_DEBUG_CELL_ACCESSES == 1) - scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); -#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ - j = SCM_NUM_PROTECTS; while (j) scm_sys_protects[--j] = SCM_BOOL_F; @@ -2725,7 +2695,7 @@ scm_init_storage () j = SCM_HEAP_SEG_SIZE; scm_mtrigger = SCM_INIT_MALLOC_LIMIT; scm_heap_table = ((scm_t_heap_seg_data *) - scm_must_malloc (sizeof (scm_t_heap_seg_data) * 2, "hplims")); + scm_malloc (sizeof (scm_t_heap_seg_data) * 2)); heap_segment_table_size = 2; mark_space_ptr = &mark_space_head; @@ -2829,12 +2799,64 @@ mark_gc_async (void * hook_data SCM_UNUSED, return NULL; } +#if SCM_ENABLE_DEPRECATED == 1 + +/* If an allocated cell is detected during garbage collection, this + * means that some code has just obtained the object but was preempted + * before the initialization of the object was completed. This meanst + * that some entries of the allocated cell may already contain SCM + * objects. Therefore, allocated cells are scanned conservatively. + */ + +scm_t_bits scm_tc16_allocated; + +static SCM +allocated_mark (SCM cell) +{ + unsigned long int cell_segment = heap_segment (cell); + unsigned int span = scm_heap_table[cell_segment].span; + unsigned int i; + + for (i = 1; i != span * 2; ++i) + { + SCM obj = SCM_CELL_OBJECT (cell, i); + long int obj_segment = heap_segment (obj); + if (obj_segment >= 0) + scm_gc_mark (obj); + } + return SCM_BOOL_F; +} + +SCM +scm_deprecated_newcell (void) +{ + scm_c_issue_deprecation_warning + ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n"); + + return scm_cell (scm_tc16_allocated, 0); +} + +SCM +scm_deprecated_newcell2 (void) +{ + scm_c_issue_deprecation_warning + ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n"); + + return scm_double_cell (scm_tc16_allocated, 0, 0, 0); +} + +#endif /* SCM_ENABLE_DEPRECATED == 1 */ void scm_init_gc () { SCM after_gc_thunk; +#if SCM_ENABLE_DEPRECATED == 1 + scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); + scm_set_smob_mark (scm_tc16_allocated, allocated_mark); +#endif + scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0)); scm_c_define ("after-gc-hook", scm_after_gc_hook);