-/* 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
#include <errno.h>
#include <string.h>
+#ifdef __ia64__
+#include <ucontext.h>
+extern unsigned long * __libc_ia64_register_backing_store_base;
+#endif
+
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
#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;
static unsigned int debug_cells_gc_interval = 0;
-/* 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. */
-static SCM
-allocated_mark (SCM allocated)
-{
- scm_gc_mark_cell_conservatively (allocated);
- return SCM_BOOL_F;
-}
-
-
/* Assert that the given object is a valid reference to a valid cell. This
* test involves to determine whether the object is a cell pointer, whether
* this pointer actually points into a heap segment and whether the cell
* 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.]
# 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 */
#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
# 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) \
};
/* 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;
}
#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 */
\f
scm_t_c_hook scm_after_sweep_c_hook;
scm_t_c_hook scm_after_gc_c_hook;
+#ifdef __ia64__
+# define SCM_MARK_BACKING_STORE() do { \
+ ucontext_t ctx; \
+ SCM_STACKITEM * top, * bot; \
+ getcontext (&ctx); \
+ scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
+ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
+ / sizeof (SCM_STACKITEM))); \
+ bot = (SCM_STACKITEM *) __libc_ia64_register_backing_store_base; \
+ top = (SCM_STACKITEM *) ctx.uc_mcontext.sc_ar_bsp; \
+ scm_mark_locations (bot, top - bot); } while (0)
+#else
+# define SCM_MARK_BACKING_STORE()
+#endif
void
scm_igc (const char *what)
++scm_gc_heap_lock;
- /* flush dead entries from the continuation stack */
- {
- long x;
- long bound;
- SCM * elts;
- elts = SCM_VELTS (scm_continuation_stack);
- bound = SCM_VECTOR_LENGTH (scm_continuation_stack);
- x = SCM_INUM (scm_continuation_stack_ptr);
- while (x < bound)
- {
- elts[x] = SCM_BOOL_F;
- ++x;
- }
- }
-
scm_c_hook_run (&scm_before_mark_c_hook, 0);
clear_mark_space ();
scm_mark_locations (scm_stack_base - stack_len, stack_len);
#endif
}
+ SCM_MARK_BACKING_STORE();
#else /* USE_THREADS */
/* 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. */
-#if (SCM_DEBUG_CELL_ACCESSES == 0)
- /* If cell debugging is disabled, there is a second situation in
- * which a free cell can be encountered, namely if with preemptive
- * threading one thread has just obtained a fresh cell and was
- * preempted before the cell initialization was completed. In this
- * case, some entries of the cell may already contain objects.
- * Thus, if cell debugging is disabled, free cells are scanned
- * conservatively. */
- scm_gc_mark_cell_conservatively (ptr);
-#else /* SCM_DEBUG_CELL_ACCESSES == 1 */
- /* With cell debugging enabled, a freshly obtained but not fully
- * initialized cell is guaranteed to be of type scm_tc16_allocated.
- * Thus, no conservative scanning for free cells is necessary, but
- * instead cells of type scm_tc16_allocated have to be scanned
- * conservatively. This is done in the mark function of the
- * scm_tc16_allocated smob type. */
-#endif
break;
case scm_tc16_big:
case scm_tc16_real:
* heap segment. If this is the case, the number of the heap segment is
* returned. Otherwise, -1 is returned. Binary search is used in order to
* determine the heap segment that contains the cell.*/
-/* FIXME: To be used within scm_gc_mark_cell_conservatively,
- * scm_mark_locations and scm_cellp this function should be an inline
- * function. */
+/* FIXME: To be used within scm_mark_locations and scm_cellp this function
+ * should be an inline function. */
static long int
heap_segment (SCM obj)
{
}
-/* Mark the entries of a cell conservatively. The given cell is known to be
- * on the heap. Still we have to determine its heap segment in order to
- * figure out whether it is a single or a double cell. Then, each of the cell
- * elements itself is checked and potentially marked. */
-void
-scm_gc_mark_cell_conservatively (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);
- }
-}
-
-
/* Mark a region conservatively */
void
scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
#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__); \
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
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;
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;
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);
/* 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++;
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:
{
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;
}
}
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;
\f
-/* {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;
- if (nm <= scm_mtrigger)
+ SCM_SYSCALL (ptr = realloc (mem, size));
+ if (ptr)
+ return ptr;
+
+ scm_igc ("realloc");
+ SCM_SYSCALL (ptr = realloc (mem, size));
+ if (ptr)
+ return ptr;
+
+ 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);
+}
+
+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.");
- scm_memory_error (what);
+ 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
#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_mallocated += size;
+ scm_c_issue_deprecation_warning
+ ("scm_done_malloc is deprecated. "
+ "Use scm_gc_register_collectable_memory instead.");
- 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 */
\f
/* {Heap Segments}
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);
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);
/* 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
#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;
}
scm_gc_unregister_root (p);
}
-int terminating;
+int scm_i_terminating;
/* called on process termination. */
#ifdef HAVE_ATEXIT
#endif
#endif
{
- terminating = 1;
+ scm_i_terminating = 1;
scm_flush_all_ports ();
}
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);
- scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
-#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
-
j = SCM_NUM_PROTECTS;
while (j)
scm_sys_protects[--j] = SCM_BOOL_F;
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;
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);
HCoop / bpt / guile.git / blobdiff