xemacs-beta: src/alloc.c comparison

comparison src/alloc.c @ 3092:141c2920ea48

[xemacs-hg @ 2005-11-25 01:41:31 by crestani] Incremental Garbage Collector

author	crestani
date	Fri, 25 Nov 2005 01:42:08 +0000
parents	d30cd499e445
children	db0631f96757

comparison

equal deleted inserted replaced

-:c22d8984148c
+:141c2920ea48
 #include "elhash.h"
 #include "events.h"
 #include "extents-impl.h"
 #include "file-coding.h"
 #include "frame-impl.h"
+#include "gc.h"
 #include "glyphs.h"
 #include "opaque.h"
 #include "lstream.h"
 #include "process.h"
 #include "profile.h"
 #include "redisplay.h"
 #include "specifier.h"
 #include "sysfile.h"
 #include "sysdep.h"
 #include "window.h"
+#ifdef NEW_GC
+#include "vdb.h"
+#endif /* NEW_GC */
 #include "console-stream.h"
 #ifdef DOUG_LEA_MALLOC
 #include <malloc.h>
 #endif
 EXFUN (Fgarbage_collect, 0);
-static void recompute_need_to_garbage_collect (void);
 #if 0 /* this is _way_ too slow to be part of the standard debug options */
 #if defined(DEBUG_XEMACS) && defined(MULE)
 #define VERIFY_STRING_CHARS_INTEGRITY
 #endif
 #ifdef DEBUG_XEMACS
 static Fixnum debug_allocation;
 static Fixnum debug_allocation_backtrace_length;
 #endif
-/* Number of bytes of consing done since the last gc */
-static EMACS_INT consing_since_gc;
-EMACS_UINT total_consing;
-EMACS_INT total_gc_usage;
-int total_gc_usage_set;
-int need_to_garbage_collect;
 int need_to_check_c_alloca;
 int need_to_signal_post_gc;
 int funcall_allocation_flag;
 Bytecount __temp_alloca_size__;
 Bytecount funcall_alloca_count;
 #define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size)
 #define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \
 INCREMENT_CONS_COUNTER_1 (size)
 #endif
+#ifdef NEW_GC
+/* The call to recompute_need_to_garbage_collect is moved to
+free_lrecord, since DECREMENT_CONS_COUNTER is extensively called
+during sweep and recomputing need_to_garbage_collect all the time
+is not needed. */
+#define DECREMENT_CONS_COUNTER(size) do {	\
+consing_since_gc -= (size);			\
+total_consing -= (size);			\
+if (profiling_active)				\
+profile_record_unconsing (size);		\
+if (consing_since_gc < 0)			\
+consing_since_gc = 0;			\
+} while (0)
+#else /* not NEW_GC */
 #define DECREMENT_CONS_COUNTER(size) do {	\
 consing_since_gc -= (size);			\
 total_consing -= (size);			\
 if (profiling_active)				\
 profile_record_unconsing (size);		\
 if (consing_since_gc < 0)			\
 consing_since_gc = 0;			\
 recompute_need_to_garbage_collect ();		\
 } while (0)
+#endif /*not NEW_GC */
-/* Number of bytes of consing since gc before another gc should be done. */
-static EMACS_INT gc_cons_threshold;
-/* Percentage of consing of total data size before another GC. */
-static EMACS_INT gc_cons_percentage;
-#ifdef ERROR_CHECK_GC
-int always_gc;			/* Debugging hack; equivalent to
-				   (setq gc-cons-thresold -1) */
-#else
-#define always_gc 0
-#endif
-/* Nonzero during gc */
-int gc_in_progress;
-/* Nonzero means display messages at beginning and end of GC.  */
-int garbage_collection_messages;
-/* Number of times GC has happened at this level or below.
-* Level 0 is most volatile, contrary to usual convention.
-*  (Of course, there's only one level at present) */
-EMACS_INT gc_generation_number[1];
 /* This is just for use by the printer, to allow things to print uniquely */
 int lrecord_uid_counter;
-/* Nonzero when calling certain hooks or doing other things where
-a GC would be bad */
-int gc_currently_forbidden;
-/* Hooks. */
-Lisp_Object Vpre_gc_hook, Qpre_gc_hook;
-Lisp_Object Vpost_gc_hook, Qpost_gc_hook;
-/* "Garbage collecting" */
-Lisp_Object Vgc_message;
-Lisp_Object Vgc_pointer_glyph;
-static const Ascbyte gc_default_message[] = "Garbage collecting";
-Lisp_Object Qgarbage_collecting;
-static Lisp_Object QSin_garbage_collection;
 /* Non-zero means we're in the process of doing the dump */
 int purify_flag;
 /* Non-zero means we're pdumping out or in */
 /* Non-zero means ignore malloc warnings.  Set during initialization.  */
 int ignore_malloc_warnings;
 #ifndef MC_ALLOC
-static void *breathing_space;
+void *breathing_space;
 void
 release_breathing_space (void)
 {
 if (breathing_space)
 /* Called if malloc returns zero */
 DOESNT_RETURN
 memory_full (void)
 {
+fprintf (stderr, "##### M E M O R Y   F U L L #####\n");
 /* Force a GC next time eval is called.
 It's better to loop garbage-collecting (we might reclaim enough
 to win) than to loop beeping and barfing "Memory exhausted"
 */
 consing_since_gc = gc_cons_threshold + 1;
 int bytes_in_use;
 int bytes_in_use_including_overhead;
 } lrecord_stats [countof (lrecord_implementations_table)
 		 + MODULE_DEFINABLE_TYPE_COUNT];
-int lrecord_string_data_instances_in_use;
-int lrecord_string_data_bytes_in_use;
-int lrecord_string_data_bytes_in_use_including_overhead;
 void
 init_lrecord_stats ()
 {
 xzero (lrecord_stats);
-lrecord_string_data_instances_in_use = 0;
-lrecord_string_data_bytes_in_use = 0;
-lrecord_string_data_bytes_in_use_including_overhead = 0;
-}
-void
-inc_lrecord_string_data_stats (Bytecount size)
-{
-lrecord_string_data_instances_in_use++;
-lrecord_string_data_bytes_in_use += size;
-lrecord_string_data_bytes_in_use_including_overhead += size;
-}
-void
-dec_lrecord_string_data_stats (Bytecount size)
-{
-lrecord_string_data_instances_in_use--;
-lrecord_string_data_bytes_in_use -= size;
-lrecord_string_data_bytes_in_use_including_overhead -= size;
 }
 void
 inc_lrecord_stats (Bytecount size, const struct lrecord_header *h)
 {
 lrecord_stats[type_index].bytes_in_use_including_overhead
 -= size_including_overhead;
 DECREMENT_CONS_COUNTER (size);
 }
+int
+lrecord_stats_heap_size (void)
+{
+int i;
+int size = 0;
+for (i = 0; i < (countof (lrecord_implementations_table)
+		   + MODULE_DEFINABLE_TYPE_COUNT); i++)
+size += lrecord_stats[i].bytes_in_use;
+return size;
+}
 #endif /* not (MC_ALLOC && ALLOC_TYPE_STATS) */
 #ifndef MC_ALLOC
 /* lcrecords are chained together through their "next" field.
 After doing the mark phase, GC will walk this linked list
 #endif /* ALLOC_TYPE_STATS */
 INCREMENT_CONS_COUNTER (size, implementation->name);
 return lheader;
 }
 void *
 noseeum_alloc_lrecord (Bytecount size,
 		       const struct lrecord_implementation *implementation)
 {
 struct lrecord_header *lheader;
 #endif /* ALLOC_TYPE_STATS */
 NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name);
 return lheader;
 }
+#ifdef NEW_GC
+void *
+alloc_lrecord_array (Bytecount size, int elemcount,
+		     const struct lrecord_implementation *implementation)
+{
+struct lrecord_header *lheader;
+Rawbyte *start, *stop;
+type_checking_assert
+((implementation->static_size == 0 ?
+implementation->size_in_bytes_method != NULL :
+implementation->static_size == size));
+lheader = (struct lrecord_header *) mc_alloc_array (size, elemcount);
+gc_checking_assert (LRECORD_FREE_P (lheader));
+for (start = (Rawbyte *) lheader,
+stop = ((Rawbyte *) lheader) + (size * elemcount -1);
+start < stop; start += size)
+{
+struct lrecord_header *lh = (struct lrecord_header *) start;
+set_lheader_implementation (lh, implementation);
+lh->uid = lrecord_uid_counter++;
+#ifdef ALLOC_TYPE_STATS
+inc_lrecord_stats (size, lh);
+#endif /* not ALLOC_TYPE_STATS */
+}
+INCREMENT_CONS_COUNTER (size * elemcount, implementation->name);
+return lheader;
+}
+#endif /* NEW_GC */
 void
 free_lrecord (Lisp_Object lrecord)
 {
+#ifndef NEW_GC
 gc_checking_assert (!gc_in_progress);
+#endif /* not NEW_GC */
 gc_checking_assert (!LRECORD_FREE_P (XRECORD_LHEADER (lrecord)));
 gc_checking_assert (!XRECORD_LHEADER (lrecord)->free);
+#ifdef NEW_GC
+GC_STAT_EXPLICITLY_TRIED_FREED;
+/* Ignore requests to manual free objects while in garbage collection. */
+if (write_barrier_enabled || gc_in_progress)
+return;
+GC_STAT_EXPLICITLY_FREED;
+#endif /* NEW_GC */
 MC_ALLOC_CALL_FINALIZER (XPNTR (lrecord));
 mc_free (XPNTR (lrecord));
+recompute_need_to_garbage_collect ();
 }
 #else /* not MC_ALLOC */
 /* The most basic of the lcrecord allocation functions.  Not usually called
 directly.  Allocates an lrecord not managed by any lcrecord-list, of a
 unless there's a large number (usually 1000, but
 varies depending on type) of them already on the list.
 This way, we ensure that an object that gets freed will
 remain free for the next 1000 (or whatever) times that
 an object of that type is allocated.  */
-#ifndef MALLOC_OVERHEAD
-#ifdef GNU_MALLOC
-#define MALLOC_OVERHEAD 0
-#elif defined (rcheck)
-#define MALLOC_OVERHEAD 20
-#else
-#define MALLOC_OVERHEAD 8
-#endif
-#endif /* MALLOC_OVERHEAD */
 #if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC)
 /* If we released our reserve (due to running out of memory),
 and we have a fair amount free once again,
 try to set aside another reserve in case we run out once more.
 f->flags.interactivep = 0;
 f->flags.domainp = 0; /* I18N3 */
 f->instructions = Qzero;
 f->constants = Qzero;
 f->arglist = Qnil;
+#ifdef NEW_GC
+f->arguments = Qnil;
+#else /* not NEW_GC */
 f->args = NULL;
+#endif /* not NEW_GC */
 f->max_args = f->min_args = f->args_in_array = 0;
 f->doc_and_interactive = Qnil;
 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
 f->annotated = Qnil;
 #endif
 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
 	  !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
 }
 static const struct memory_description string_description[] = {
+#ifdef NEW_GC
+{ XD_LISP_OBJECT,     offsetof (Lisp_String, data_object) },
+#else /* not NEW_GC */
 { XD_BYTECOUNT,       offsetof (Lisp_String, size_) },
 { XD_OPAQUE_DATA_PTR, offsetof (Lisp_String, data_), XD_INDIRECT(0, 1) },
+#endif /* not NEW_GC */
 { XD_LISP_OBJECT,     offsetof (Lisp_String, plist) },
 { XD_END }
 };
 /* We store the string's extent info as the first element of the string's
 						string_remprop,
 						string_plist,
 						Lisp_String);
 #endif /* not MC_ALLOC */
+#ifdef NEW_GC
+#define STRING_FULLSIZE(size) \
+ALIGN_SIZE (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_String_Direct_Data, Lisp_Object, data, (size) + 1), sizeof (Lisp_Object *));
+#else /* not NEW_GC */
 /* String blocks contain this many useful bytes. */
 #define STRING_CHARS_BLOCK_SIZE					\
 ((Bytecount) (8192 - MALLOC_OVERHEAD -			\
 	        ((2 * sizeof (struct string_chars_block *))	\
 	         + sizeof (EMACS_INT))))
 #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE)
 #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size)))
 #define STRING_CHARS_FREE_P(ptr) ((ptr)->string == NULL)
 #define MARK_STRING_CHARS_AS_FREE(ptr) ((void) ((ptr)->string = NULL))
+#endif /* not NEW_GC */
 #ifdef MC_ALLOC
+#ifndef NEW_GC
 static void
 finalize_string (void *header, int for_disksave)
 {
 if (!for_disksave)
 {
 Lisp_String *s = (Lisp_String *) header;
 Bytecount size = s->size_;
-#ifdef ALLOC_TYPE_STATS
-dec_lrecord_string_data_stats (size);
-#endif /* ALLOC_TYPE_STATS */
 if (BIG_STRING_SIZE_P (size))
 	xfree (s->data_, Ibyte *);
 }
 }
 					  string_getprop,
 					  string_putprop,
 					  string_remprop,
 					  string_plist,
 					  Lisp_String);
+#else /* NEW_GC */
+DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
+					  1, /*dumpable-flag*/
+					  mark_string, print_string,
+					  0,
+					  string_equal, 0,
+					  string_description,
+					  string_getprop,
+					  string_putprop,
+					  string_remprop,
+					  string_plist,
+					  Lisp_String);
+static const struct memory_description string_direct_data_description[] = {
+{ XD_BYTECOUNT,       offsetof (Lisp_String_Indirect_Data, size) },
+{ XD_END }
+};
+static Bytecount
+size_string_direct_data (const void *lheader)
+{
+return STRING_FULLSIZE (((Lisp_String_Direct_Data *) lheader)->size);
+}
+DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("string-direct-data",
+					string_direct_data,
+					1, /*dumpable-flag*/
+					0, 0, 0, 0, 0,
+					string_direct_data_description,
+					size_string_direct_data,
+					Lisp_String_Direct_Data);
+static const struct memory_description string_indirect_data_description[] = {
+{ XD_BYTECOUNT,       offsetof (Lisp_String_Indirect_Data, size) },
+{ XD_OPAQUE_DATA_PTR, offsetof (Lisp_String_Indirect_Data, data),
+XD_INDIRECT(0, 1) },
+{ XD_END }
+};
+DEFINE_LRECORD_IMPLEMENTATION ("string-indirect-data",
+			       string_indirect_data,
+			       1, /*dumpable-flag*/
+			       0, 0, 0, 0, 0,
+			       string_indirect_data_description,
+			       Lisp_String_Indirect_Data);
+#endif /* NEW_GC */
 #endif /* MC_ALLOC */
+#ifndef NEW_GC
 struct string_chars
 {
 Lisp_String *string;
 unsigned char chars[1];
 };
 INCREMENT_CONS_COUNTER (fullsize, "string chars");
 return s_chars;
 }
+#endif /* not NEW_GC */
 #ifdef SLEDGEHAMMER_CHECK_ASCII_BEGIN
 void
 sledgehammer_check_ascii_begin (Lisp_Object str)
 {
 assert (length >= 0 && fullsize > 0);
 #ifdef MC_ALLOC
 s = alloc_lrecord_type (Lisp_String, &lrecord_string);
-#ifdef ALLOC_TYPE_STATS
-inc_lrecord_string_data_stats (length);
-#endif /* ALLOC_TYPE_STATS */
 #else /* not MC_ALLOC */
 /* Allocate the string header */
 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
 xzero (*s);
 set_lheader_implementation (&s->u.lheader, &lrecord_string);
 /* The above allocations set the UID field, which overlaps with the
 ascii-length field, to some non-zero value.  We need to zero it. */
 XSET_STRING_ASCII_BEGIN (wrap_string (s), 0);
+#ifdef NEW_GC
+STRING_DATA_OBJECT (s) =
+wrap_string_direct_data (alloc_lrecord (fullsize,
+					    &lrecord_string_direct_data));
+#else /* not NEW_GC */
 set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize)
 			? allocate_big_string_chars (length + 1)
 			: allocate_string_chars_struct (wrap_string (s),
 							fullsize)->chars);
+#endif /* not NEW_GC */
 set_lispstringp_length (s, length);
 s->plist = Qnil;
 set_string_byte (wrap_string (s), length, 0);
 */
 void
 resize_string (Lisp_Object s, Bytecount pos, Bytecount delta)
 {
+#ifdef NEW_GC
+Bytecount newfullsize, len;
+#else /* not NEW_GC */
 Bytecount oldfullsize, newfullsize;
+#endif /* not NEW_GC */
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
 verify_string_chars_integrity ();
 #endif
 #ifdef ERROR_CHECK_TEXT
 if (pos >= 0)
 /* If DELTA < 0, the functions below will delete the characters
 before POS.  We want to delete characters *after* POS, however,
 so convert this to the appropriate form. */
 pos += -delta;
+#ifdef NEW_GC
+newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
+len = XSTRING_LENGTH (s) + 1 - pos;
+if (delta < 0 && pos >= 0)
+memmove (XSTRING_DATA (s) + pos + delta,
+	     XSTRING_DATA (s) + pos, len);
+XSTRING_DATA_OBJECT (s) =
+wrap_string_direct_data (mc_realloc (XPNTR (XSTRING_DATA_OBJECT (s)),
+					 newfullsize));
+if (delta > 0 && pos >= 0)
+memmove (XSTRING_DATA (s) + pos + delta, XSTRING_DATA (s) + pos,
+	     len);
+#else /* NEW_GC */
 oldfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s));
 newfullsize = STRING_FULLSIZE (XSTRING_LENGTH (s) + delta);
 if (BIG_STRING_FULLSIZE_P (oldfullsize))
 {
 	    ((struct unused_string_chars *) old_s_chars)->fullsize =
 	      oldfullsize;
 	  }
 	}
 }
+#endif /* not NEW_GC */
 XSET_STRING_LENGTH (s, XSTRING_LENGTH (s) + delta);
 /* If pos < 0, the string won't be zero-terminated.
 Terminate now just to make sure. */
 XSTRING_DATA (s)[XSTRING_LENGTH (s)] = '\0';
 bytecount_to_charcount (contents, length); /* Just for the assertions */
 #endif
 #ifdef MC_ALLOC
 s = alloc_lrecord_type (Lisp_String, &lrecord_string);
-#ifdef ALLOC_TYPE_STATS
-inc_lrecord_string_data_stats (length);
-#endif /* ALLOC_TYPE_STATS */
 mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get
 				 collected and static data is tried to
 				 be freed. */
 #else /* not MC_ALLOC */
 /* Allocate the string header */
 SET_C_READONLY_RECORD_HEADER (&s->u.lheader);
 #endif /* not MC_ALLOC */
 /* Don't need to XSET_STRING_ASCII_BEGIN() here because it happens in
 init_string_ascii_begin(). */
 s->plist = Qnil;
+#ifdef NEW_GC
+set_lispstringp_indirect (s);
+STRING_DATA_OBJECT (s) =
+wrap_string_indirect_data
+(alloc_lrecord_type (Lisp_String_Indirect_Data,
+			 &lrecord_string_indirect_data));
+XSTRING_INDIRECT_DATA_DATA (STRING_DATA_OBJECT (s)) = (Ibyte *) contents;
+XSTRING_INDIRECT_DATA_SIZE (STRING_DATA_OBJECT (s)) = length;
+#else /* not NEW_GC */
 set_lispstringp_data (s, (Ibyte *) contents);
 set_lispstringp_length (s, length);
+#endif /* not NEW_GC */
 val = wrap_string (s);
 init_string_ascii_begin (val);
 sledgehammer_check_ascii_begin (val);
 return val;
 Dynarr_add (mcpros, varaddress);
 }
 #endif /* not DEBUG_XEMACS */
 #endif /* MC_ALLOC */
-#ifdef ERROR_CHECK_GC
-#ifdef MC_ALLOC
-#define GC_CHECK_LHEADER_INVARIANTS(lheader) do {		\
-struct lrecord_header * GCLI_lh = (lheader);			\
-assert (GCLI_lh != 0);					\
-assert (GCLI_lh->type < (unsigned int) lrecord_type_count);	\
-} while (0)
-#else /* not MC_ALLOC */
-#define GC_CHECK_LHEADER_INVARIANTS(lheader) do {		\
-struct lrecord_header * GCLI_lh = (lheader);			\
-assert (GCLI_lh != 0);					\
-assert (GCLI_lh->type < (unsigned int) lrecord_type_count);	\
-assert (! C_READONLY_RECORD_HEADER_P (GCLI_lh) ||		\
-	  (MARKED_RECORD_HEADER_P (GCLI_lh) &&			\
-	   LISP_READONLY_RECORD_HEADER_P (GCLI_lh)));		\
-} while (0)
-#endif /* not MC_ALLOC */
-#else
-#define GC_CHECK_LHEADER_INVARIANTS(lheader)
-#endif
-static const struct memory_description lisp_object_description_1[] = {
-{ XD_LISP_OBJECT, 0 },
-{ XD_END }
-};
-const struct sized_memory_description lisp_object_description = {
-sizeof (Lisp_Object),
-lisp_object_description_1
-};
-#if defined (USE_KKCC) || defined (PDUMP)
-/* This function extracts the value of a count variable described somewhere
-else in the description. It is converted corresponding to the type */
-EMACS_INT
-lispdesc_indirect_count_1 (EMACS_INT code,
-			   const struct memory_description *idesc,
-			   const void *idata)
-{
-EMACS_INT count;
-const void *irdata;
-int line = XD_INDIRECT_VAL (code);
-int delta = XD_INDIRECT_DELTA (code);
-irdata = ((char *) idata) +
-lispdesc_indirect_count (idesc[line].offset, idesc, idata);
-switch (idesc[line].type)
-{
-case XD_BYTECOUNT:
-count = * (Bytecount *) irdata;
-break;
-case XD_ELEMCOUNT:
-count = * (Elemcount *) irdata;
-break;
-case XD_HASHCODE:
-count = * (Hashcode *) irdata;
-break;
-case XD_INT:
-count = * (int *) irdata;
-break;
-case XD_LONG:
-count = * (long *) irdata;
-break;
-default:
-stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n",
-		  idesc[line].type, line, (long) code);
-#if defined(USE_KKCC) && defined(DEBUG_XEMACS)
-if (gc_in_progress)
-	kkcc_backtrace ();
-#endif
-#ifdef PDUMP
-if (in_pdump)
-	pdump_backtrace ();
-#endif
-count = 0; /* warning suppression */
-ABORT ();
-}
-count += delta;
-return count;
-}
-/* SDESC is a "description map" (basically, a list of offsets used for
-successive indirections) and OBJ is the first object to indirect off of.
-Return the description ultimately found. */
-const struct sized_memory_description *
-lispdesc_indirect_description_1 (const void *obj,
-				 const struct sized_memory_description *sdesc)
-{
-int pos;
-for (pos = 0; sdesc[pos].size >= 0; pos++)
-obj = * (const void **) ((const char *) obj + sdesc[pos].size);
-return (const struct sized_memory_description *) obj;
-}
-/* Compute the size of the data at RDATA, described by a single entry
-DESC1 in a description array.  OBJ and DESC are used for
-XD_INDIRECT references. */
-static Bytecount
-lispdesc_one_description_line_size (void *rdata,
-				    const struct memory_description *desc1,
-				    const void *obj,
-				    const struct memory_description *desc)
-{
-union_switcheroo:
-switch (desc1->type)
-{
-case XD_LISP_OBJECT_ARRAY:
-{
-	EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
-	return (val * sizeof (Lisp_Object));
-}
-case XD_LISP_OBJECT:
-case XD_LO_LINK:
-return sizeof (Lisp_Object);
-case XD_OPAQUE_PTR:
-return sizeof (void *);
-case XD_BLOCK_PTR:
-{
-	EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
-	return val * sizeof (void *);
-}
-case XD_BLOCK_ARRAY:
-{
-	EMACS_INT val = lispdesc_indirect_count (desc1->data1, desc, obj);
-	return (val *
-		lispdesc_block_size
-		(rdata,
-		 lispdesc_indirect_description (obj, desc1->data2.descr)));
-}
-case XD_OPAQUE_DATA_PTR:
-return sizeof (void *);
-case XD_UNION_DYNAMIC_SIZE:
-{
-	/* If an explicit size was given in the first-level structure
-	   description, use it; else compute size based on current union
-	   constant. */
-	const struct sized_memory_description *sdesc =
-	  lispdesc_indirect_description (obj, desc1->data2.descr);
-	if (sdesc->size)
-	  return sdesc->size;
-	else
-	  {
-	    desc1 = lispdesc_process_xd_union (desc1, desc, obj);
-	    if (desc1)
-	      goto union_switcheroo;
-	    break;
-	  }
-}
-case XD_UNION:
-{
-	/* If an explicit size was given in the first-level structure
-	   description, use it; else compute size based on maximum of all
-	   possible structures. */
-	const struct sized_memory_description *sdesc =
-	  lispdesc_indirect_description (obj, desc1->data2.descr);
-	if (sdesc->size)
-	  return sdesc->size;
-	else
-	  {
-	    int count;
-	    Bytecount max_size = -1, size;
-	    desc1 = sdesc->description;
-	    for (count = 0; desc1[count].type != XD_END; count++)
-	      {
-		size = lispdesc_one_description_line_size (rdata,
-							   &desc1[count],
-							   obj, desc);
-		if (size > max_size)
-		  max_size = size;
-	      }
-	    return max_size;
-	  }
-}
-case XD_ASCII_STRING:
-return sizeof (void *);
-case XD_DOC_STRING:
-return sizeof (void *);
-case XD_INT_RESET:
-return sizeof (int);
-case XD_BYTECOUNT:
-return sizeof (Bytecount);
-case XD_ELEMCOUNT:
-return sizeof (Elemcount);
-case XD_HASHCODE:
-return sizeof (Hashcode);
-case XD_INT:
-return sizeof (int);
-case XD_LONG:
-return sizeof (long);
-default:
-stderr_out ("Unsupported dump type : %d\n", desc1->type);
-ABORT ();
-}
-return 0;
-}
-/* Return the size of the memory block (NOT necessarily a structure!)
-described by SDESC and pointed to by OBJ.  If SDESC records an
-explicit size (i.e. non-zero), it is simply returned; otherwise,
-the size is calculated by the maximum offset and the size of the
-object at that offset, rounded up to the maximum alignment.  In
-this case, we may need the object, for example when retrieving an
-"indirect count" of an inlined array (the count is not constant,
-but is specified by one of the elements of the memory block). (It
-is generally not a problem if we return an overly large size -- we
-will simply end up reserving more space than necessary; but if the
-size is too small we could be in serious trouble, in particular
-with nested inlined structures, where there may be alignment
-padding in the middle of a block. #### In fact there is an (at
-least theoretical) problem with an overly large size -- we may
-trigger a protection fault when reading from invalid memory.  We
-need to handle this -- perhaps in a stupid but dependable way,
-i.e. by trapping SIGSEGV and SIGBUS.) */
-Bytecount
-lispdesc_block_size_1 (const void *obj, Bytecount size,
-		       const struct memory_description *desc)
-{
-EMACS_INT max_offset = -1;
-int max_offset_pos = -1;
-int pos;
-if (size)
-return size;
-for (pos = 0; desc[pos].type != XD_END; pos++)
-{
-EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj);
-if (offset == max_offset)
-	{
-	  stderr_out ("Two relocatable elements at same offset?\n");
-	  ABORT ();
-	}
-else if (offset > max_offset)
-	{
-	  max_offset = offset;
-	  max_offset_pos = pos;
-	}
-}
-if (max_offset_pos < 0)
-return 0;
-{
-Bytecount size_at_max;
-size_at_max =
-lispdesc_one_description_line_size ((char *) obj + max_offset,
-					  &desc[max_offset_pos], obj, desc);
-/* We have no way of knowing the required alignment for this structure,
-so just make it maximally aligned. */
-return MAX_ALIGN_SIZE (max_offset + size_at_max);
-}
-}
-#endif /* defined (USE_KKCC) || defined (PDUMP) */
-#ifdef MC_ALLOC
-#define GC_CHECK_NOT_FREE(lheader)			\
-gc_checking_assert (! LRECORD_FREE_P (lheader));
-#else /* MC_ALLOC */
-#define GC_CHECK_NOT_FREE(lheader)					\
-gc_checking_assert (! LRECORD_FREE_P (lheader));			\
-gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||	\
-			  ! ((struct old_lcrecord_header *) lheader)->free)
-#endif /* MC_ALLOC */
-#ifdef USE_KKCC
-/* The following functions implement the new mark algorithm.
-They mark objects according to their descriptions.  They
-are modeled on the corresponding pdumper procedures. */
-#ifdef DEBUG_XEMACS
-/* The backtrace for the KKCC mark functions. */
-#define KKCC_INIT_BT_STACK_SIZE 4096
-typedef struct
-{
-void *obj;
-const struct memory_description *desc;
-int pos;
-} kkcc_bt_stack_entry;
-static kkcc_bt_stack_entry *kkcc_bt;
-static int kkcc_bt_stack_size;
-static int kkcc_bt_depth = 0;
-static void
-kkcc_bt_init (void)
-{
-kkcc_bt_depth = 0;
-kkcc_bt_stack_size = KKCC_INIT_BT_STACK_SIZE;
-kkcc_bt = (kkcc_bt_stack_entry *)
-malloc (kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry));
-if (!kkcc_bt)
-{
-stderr_out ("KKCC backtrace stack init failed for size %d\n",
-		  kkcc_bt_stack_size);
-ABORT ();
-}
-}
-void
-kkcc_backtrace (void)
-{
-int i;
-stderr_out ("KKCC mark stack backtrace :\n");
-for (i = kkcc_bt_depth - 1; i >= 0; i--)
-{
-Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj);
-stderr_out (" [%d]", i);
-#ifdef MC_ALLOC
-if ((XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type)
-#else /* not MC_ALLOC */
-if ((XRECORD_LHEADER (obj)->type >= lrecord_type_free)
-#endif /* not MC_ALLOC */
-	  || (!LRECORDP (obj))
-	  || (!XRECORD_LHEADER_IMPLEMENTATION (obj)))
-	{
-	  stderr_out (" non Lisp Object");
-	}
-else
-	{
-	  stderr_out (" %s",
-		      XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
-	}
-stderr_out (" (addr: 0x%x, desc: 0x%x, ",
-		  (int) kkcc_bt[i].obj,
-		  (int) kkcc_bt[i].desc);
-if (kkcc_bt[i].pos >= 0)
-	stderr_out ("pos: %d)\n", kkcc_bt[i].pos);
-else
-	stderr_out ("root set)\n");
-}
-}
-static void
-kkcc_bt_stack_realloc (void)
-{
-kkcc_bt_stack_size *= 2;
-kkcc_bt = (kkcc_bt_stack_entry *)
-realloc (kkcc_bt, kkcc_bt_stack_size * sizeof (kkcc_bt_stack_entry));
-if (!kkcc_bt)
-{
-stderr_out ("KKCC backtrace stack realloc failed for size %d\n",
-		  kkcc_bt_stack_size);
-ABORT ();
-}
-}
-static void
-kkcc_bt_free (void)
-{
-free (kkcc_bt);
-kkcc_bt = 0;
-kkcc_bt_stack_size = 0;
-}
-static void
-kkcc_bt_push (void *obj, const struct memory_description *desc,
-	      int level, int pos)
-{
-kkcc_bt_depth = level;
-kkcc_bt[kkcc_bt_depth].obj = obj;
-kkcc_bt[kkcc_bt_depth].desc = desc;
-kkcc_bt[kkcc_bt_depth].pos = pos;
-kkcc_bt_depth++;
-if (kkcc_bt_depth >= kkcc_bt_stack_size)
-kkcc_bt_stack_realloc ();
-}
-#else /* not DEBUG_XEMACS */
-#define kkcc_bt_init()
-#define kkcc_bt_push(obj, desc, level, pos)
-#endif /* not DEBUG_XEMACS */
-/* Object memory descriptions are in the lrecord_implementation structure.
-But copying them to a parallel array is much more cache-friendly. */
-const struct memory_description *lrecord_memory_descriptions[countof (lrecord_implementations_table)];
-/* the initial stack size in kkcc_gc_stack_entries */
-#define KKCC_INIT_GC_STACK_SIZE 16384
-typedef struct
-{
-void *data;
-const struct memory_description *desc;
-#ifdef DEBUG_XEMACS
-int level;
-int pos;
-#endif
-} kkcc_gc_stack_entry;
-static kkcc_gc_stack_entry *kkcc_gc_stack_ptr;
-static kkcc_gc_stack_entry *kkcc_gc_stack_top;
-static kkcc_gc_stack_entry *kkcc_gc_stack_last_entry;
-static int kkcc_gc_stack_size;
-static void
-kkcc_gc_stack_init (void)
-{
-kkcc_gc_stack_size = KKCC_INIT_GC_STACK_SIZE;
-kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *)
-malloc (kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry));
-if (!kkcc_gc_stack_ptr)
-{
-stderr_out ("stack init failed for size %d\n", kkcc_gc_stack_size);
-ABORT ();
-}
-kkcc_gc_stack_top = kkcc_gc_stack_ptr - 1;
-kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1;
-}
-static void
-kkcc_gc_stack_free (void)
-{
-free (kkcc_gc_stack_ptr);
-kkcc_gc_stack_ptr = 0;
-kkcc_gc_stack_top = 0;
-kkcc_gc_stack_size = 0;
-}
-static void
-kkcc_gc_stack_realloc (void)
-{
-int current_offset = (int)(kkcc_gc_stack_top - kkcc_gc_stack_ptr);
-kkcc_gc_stack_size *= 2;
-kkcc_gc_stack_ptr = (kkcc_gc_stack_entry *)
-realloc (kkcc_gc_stack_ptr,
-	     kkcc_gc_stack_size * sizeof (kkcc_gc_stack_entry));
-if (!kkcc_gc_stack_ptr)
-{
-stderr_out ("stack realloc failed for size %d\n", kkcc_gc_stack_size);
-ABORT ();
-}
-kkcc_gc_stack_top = kkcc_gc_stack_ptr + current_offset;
-kkcc_gc_stack_last_entry = kkcc_gc_stack_ptr + kkcc_gc_stack_size - 1;
-}
-#define KKCC_GC_STACK_FULL (kkcc_gc_stack_top >= kkcc_gc_stack_last_entry)
-#define KKCC_GC_STACK_EMPTY (kkcc_gc_stack_top < kkcc_gc_stack_ptr)
-static void
-#ifdef DEBUG_XEMACS
-kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc,
-		    int level, int pos)
-#else
-kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc)
-#endif
-{
-if (KKCC_GC_STACK_FULL)
-kkcc_gc_stack_realloc();
-kkcc_gc_stack_top++;
-kkcc_gc_stack_top->data = data;
-kkcc_gc_stack_top->desc = desc;
-#ifdef DEBUG_XEMACS
-kkcc_gc_stack_top->level = level;
-kkcc_gc_stack_top->pos = pos;
-#endif
-}
-#ifdef DEBUG_XEMACS
-#define kkcc_gc_stack_push(data, desc, level, pos)	\
-kkcc_gc_stack_push_1 (data, desc, level, pos)
-#else
-#define kkcc_gc_stack_push(data, desc, level, pos)	\
-kkcc_gc_stack_push_1 (data, desc)
-#endif
-static kkcc_gc_stack_entry *
-kkcc_gc_stack_pop (void)
-{
-if (KKCC_GC_STACK_EMPTY)
-return 0;
-kkcc_gc_stack_top--;
-return kkcc_gc_stack_top + 1;
-}
-void
-#ifdef DEBUG_XEMACS
-kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos)
-#else
-kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj)
-#endif
-{
-if (XTYPE (obj) == Lisp_Type_Record)
-{
-struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-const struct memory_description *desc;
-GC_CHECK_LHEADER_INVARIANTS (lheader);
-desc = RECORD_DESCRIPTION (lheader);
-if (! MARKED_RECORD_HEADER_P (lheader))
-	{
-	  MARK_RECORD_HEADER (lheader);
-	  kkcc_gc_stack_push ((void*) lheader, desc, level, pos);
-	}
-}
-}
-#ifdef DEBUG_XEMACS
-#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \
-kkcc_gc_stack_push_lisp_object_1 (obj, level, pos)
-#else
-#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \
-kkcc_gc_stack_push_lisp_object_1 (obj)
-#endif
-#ifdef ERROR_CHECK_GC
-#define KKCC_DO_CHECK_FREE(obj, allow_free)			\
-do								\
-{								\
-if (!allow_free && XTYPE (obj) == Lisp_Type_Record)		\
-{								\
-struct lrecord_header *lheader = XRECORD_LHEADER (obj);	\
-GC_CHECK_NOT_FREE (lheader);				\
-}								\
-} while (0)
-#else
-#define KKCC_DO_CHECK_FREE(obj, allow_free)
-#endif
-#ifdef ERROR_CHECK_GC
-#ifdef DEBUG_XEMACS
-static void
-mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free,
-				 int level, int pos)
-#else
-static void
-mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free)
-#endif
-{
-KKCC_DO_CHECK_FREE (obj, allow_free);
-kkcc_gc_stack_push_lisp_object (obj, level, pos);
-}
-#ifdef DEBUG_XEMACS
-#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
-mark_object_maybe_checking_free_1 (obj, allow_free, level, pos)
-#else
-#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \
-mark_object_maybe_checking_free_1 (obj, allow_free)
-#endif
-#else /* not ERROR_CHECK_GC */
-#define mark_object_maybe_checking_free(obj, allow_free, level, pos) 	\
-kkcc_gc_stack_push_lisp_object (obj, level, pos)
-#endif /* not ERROR_CHECK_GC */
-/* This function loops all elements of a struct pointer and calls
-mark_with_description with each element. */
-static void
-#ifdef DEBUG_XEMACS
-mark_struct_contents_1 (const void *data,
-		      const struct sized_memory_description *sdesc,
-		      int count, int level, int pos)
-#else
-mark_struct_contents_1 (const void *data,
-		      const struct sized_memory_description *sdesc,
-		      int count)
-#endif
-{
-int i;
-Bytecount elsize;
-elsize = lispdesc_block_size (data, sdesc);
-for (i = 0; i < count; i++)
-{
-kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description,
-			  level, pos);
-}
-}
-#ifdef DEBUG_XEMACS
-#define mark_struct_contents(data, sdesc, count, level, pos) \
-mark_struct_contents_1 (data, sdesc, count, level, pos)
-#else
-#define mark_struct_contents(data, sdesc, count, level, pos) \
-mark_struct_contents_1 (data, sdesc, count)
-#endif
-/* This function implements the KKCC mark algorithm.
-Instead of calling mark_object, all the alive Lisp_Objects are pushed
-on the kkcc_gc_stack. This function processes all elements on the stack
-according to their descriptions. */
-static void
-kkcc_marking (void)
-{
-kkcc_gc_stack_entry *stack_entry = 0;
-void *data = 0;
-const struct memory_description *desc = 0;
-int pos;
-#ifdef DEBUG_XEMACS
-int level = 0;
-kkcc_bt_init ();
-#endif
-while ((stack_entry = kkcc_gc_stack_pop ()) != 0)
-{
-data = stack_entry->data;
-desc = stack_entry->desc;
-#ifdef DEBUG_XEMACS
-level = stack_entry->level + 1;
-#endif
-kkcc_bt_push (data, desc, stack_entry->level, stack_entry->pos);
-gc_checking_assert (data);
-gc_checking_assert (desc);
-for (pos = 0; desc[pos].type != XD_END; pos++)
-	{
-	  const struct memory_description *desc1 = &desc[pos];
-	  const void *rdata =
-	    (const char *) data + lispdesc_indirect_count (desc1->offset,
-							   desc, data);
-	union_switcheroo:
-	  /* If the flag says don't mark, then don't mark. */
-	  if ((desc1->flags) & XD_FLAG_NO_KKCC)
-	    continue;
-	  switch (desc1->type)
-	    {
-	    case XD_BYTECOUNT:
-	    case XD_ELEMCOUNT:
-	    case XD_HASHCODE:
-	    case XD_INT:
-	    case XD_LONG:
-	    case XD_INT_RESET:
-	    case XD_LO_LINK:
-	    case XD_OPAQUE_PTR:
-	    case XD_OPAQUE_DATA_PTR:
-	    case XD_ASCII_STRING:
-	    case XD_DOC_STRING:
-	      break;
-	    case XD_LISP_OBJECT:
-	      {
-		const Lisp_Object *stored_obj = (const Lisp_Object *) rdata;
-		/* Because of the way that tagged objects work (pointers and
-		   Lisp_Objects have the same representation), XD_LISP_OBJECT
-		   can be used for untagged pointers.  They might be NULL,
-		   though. */
-		if (EQ (*stored_obj, Qnull_pointer))
-		  break;
-#ifdef MC_ALLOC
-		mark_object_maybe_checking_free (*stored_obj, 0, level, pos);
-#else /* not MC_ALLOC */
-		mark_object_maybe_checking_free
-		  (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT,
-		   level, pos);
-#endif /* not MC_ALLOC */
-		break;
-	      }
-	    case XD_LISP_OBJECT_ARRAY:
-	      {
-		int i;
-		EMACS_INT count =
-		  lispdesc_indirect_count (desc1->data1, desc, data);
-		for (i = 0; i < count; i++)
-		  {
-		    const Lisp_Object *stored_obj =
-		      (const Lisp_Object *) rdata + i;
-		    if (EQ (*stored_obj, Qnull_pointer))
-		      break;
-#ifdef MC_ALLOC
-		    mark_object_maybe_checking_free (*stored_obj, 0, level, pos);
-#else /* not MC_ALLOC */
-		    mark_object_maybe_checking_free
-		      (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT,
-		       level, pos);
-#endif /* not MC_ALLOC */
-		  }
-		break;
-	      }
-	    case XD_BLOCK_PTR:
-	      {
-		EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
-							   data);
-		const struct sized_memory_description *sdesc =
-		  lispdesc_indirect_description (data, desc1->data2.descr);
-		const char *dobj = * (const char **) rdata;
-		if (dobj)
-		  mark_struct_contents (dobj, sdesc, count, level, pos);
-		break;
-	      }
-	    case XD_BLOCK_ARRAY:
-	      {
-		EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc,
-							   data);
-		const struct sized_memory_description *sdesc =
-		  lispdesc_indirect_description (data, desc1->data2.descr);
-		mark_struct_contents (rdata, sdesc, count, level, pos);
-		break;
-	      }
-	    case XD_UNION:
-	    case XD_UNION_DYNAMIC_SIZE:
-	      desc1 = lispdesc_process_xd_union (desc1, desc, data);
-	      if (desc1)
-		goto union_switcheroo;
-	      break;
-	    default:
-	      stderr_out ("Unsupported description type : %d\n", desc1->type);
-	      kkcc_backtrace ();
-	      ABORT ();
-	    }
-	}
-}
-#ifdef DEBUG_XEMACS
-kkcc_bt_free ();
-#endif
-}
-#endif /* USE_KKCC */
-/* Mark reference to a Lisp_Object.  If the object referred to has not been
-seen yet, recursively mark all the references contained in it. */
-void
-mark_object (
-#ifdef USE_KKCC
-	     Lisp_Object UNUSED (obj)
-#else
-	     Lisp_Object obj
-#endif
-	     )
-{
-#ifdef USE_KKCC
-/* this code should never be reached when configured for KKCC */
-stderr_out ("KKCC: Invalid mark_object call.\n");
-stderr_out ("Replace mark_object with kkcc_gc_stack_push_lisp_object.\n");
-ABORT ();
-#else /* not USE_KKCC */
-tail_recurse:
-/* Checks we used to perform */
-/* if (EQ (obj, Qnull_pointer)) return; */
-/* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
-/* if (PURIFIED (XPNTR (obj))) return; */
-if (XTYPE (obj) == Lisp_Type_Record)
-{
-struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-GC_CHECK_LHEADER_INVARIANTS (lheader);
-/* We handle this separately, above, so we can mark free objects */
-GC_CHECK_NOT_FREE (lheader);
-/* All c_readonly objects have their mark bit set,
-	 so that we only need to check the mark bit here. */
-if (! MARKED_RECORD_HEADER_P (lheader))
-	{
-	  MARK_RECORD_HEADER (lheader);
-	  if (RECORD_MARKER (lheader))
-	    {
-	      obj = RECORD_MARKER (lheader) (obj);
-	      if (!NILP (obj)) goto tail_recurse;
-	    }
-	}
-}
-#endif /* not KKCC */
-}
 #ifndef MC_ALLOC
 static int gc_count_num_short_string_in_use;
 static Bytecount gc_count_string_total_size;
 }
 }
 #endif /* defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY) */
+#ifndef NEW_GC
 /* Compactify string chars, relocating the reference to each --
 free any empty string_chars_block we see. */
-static void
+void
 compact_string_chars (void)
 {
 struct string_chars_block *to_sb = first_string_chars_block;
 int to_pos = 0;
 struct string_chars_block *from_sb;
 current_string_chars_block = to_sb;
 current_string_chars_block->pos = to_pos;
 current_string_chars_block->next = 0;
 }
 }
+#endif /* not NEW_GC */
 #ifndef MC_ALLOC
 #if 1 /* Hack to debug missing purecopy's */
 static int debug_string_purity;
 gc_count_string_total_size = num_bytes;
 gc_count_short_string_total_size = num_small_bytes;
 }
 #endif /* not MC_ALLOC */
-/* I hate duplicating all this crap! */
+#ifndef NEW_GC
-int
+void
-marked_p (Lisp_Object obj)
+gc_sweep_1 (void)
-{
-/* Checks we used to perform. */
-/* if (EQ (obj, Qnull_pointer)) return 1; */
-/* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
-/* if (PURIFIED (XPNTR (obj))) return 1; */
-if (XTYPE (obj) == Lisp_Type_Record)
-{
-struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-GC_CHECK_LHEADER_INVARIANTS (lheader);
-return MARKED_RECORD_HEADER_P (lheader);
-}
-return 1;
-}
-static void
-gc_sweep (void)
 {
 #ifdef MC_ALLOC
 compact_string_chars ();
 mc_finalize ();
 mc_sweep ();
 #ifdef PDUMP
 pdump_objects_unmark ();
 #endif
 #endif /* not MC_ALLOC */
 }
+#endif /* not NEW_GC */
 /* Clearing for disksave. */
 void
 disksave_object_finalization (void)
 			   defined(LOADHIST_BUILTIN))
 Vload_history = Qnil;
 #endif
 Vshell_file_name = Qnil;
+#ifdef NEW_GC
+gc_full ();
+#else /* not NEW_GC */
 garbage_collect_1 ();
+#endif /* not NEW_GC */
 /* Run the disksave finalization methods of all live objects. */
 disksave_object_finalization_1 ();
+#ifndef NEW_GC
 /* Zero out the uninitialized (really, unused) part of the containers
 for the live strings. */
 {
 struct string_chars_block *scb;
 for (scb = first_string_chars_block; scb; scb = scb->next)
 	    /* from the block's fill ptr to the end */
 	    memset ((scb->string_chars + scb->pos), 0, count);
 	  }
 }
 }
+#endif /* not NEW_GC */
 /* There, that ought to be enough... */
-}
-int
-begin_gc_forbidden (void)
-{
-return internal_bind_int (&gc_currently_forbidden, 1);
-}
-void
-end_gc_forbidden (int count)
-{
-unbind_to (count);
-}
-/* Maybe we want to use this when doing a "panic" gc after memory_full()? */
-static int gc_hooks_inhibited;
-struct post_gc_action
-{
-void (*fun) (void *);
-void *arg;
-};
-typedef struct post_gc_action post_gc_action;
-typedef struct
-{
-Dynarr_declare (post_gc_action);
-} post_gc_action_dynarr;
-static post_gc_action_dynarr *post_gc_actions;
-/* Register an action to be called at the end of GC.
-gc_in_progress is 0 when this is called.
-This is used when it is discovered that an action needs to be taken,
-but it's during GC, so it's not safe. (e.g. in a finalize method.)
-As a general rule, do not use Lisp objects here.
-And NEVER signal an error.
-*/
-void
-register_post_gc_action (void (*fun) (void *), void *arg)
-{
-post_gc_action action;
-if (!post_gc_actions)
-post_gc_actions = Dynarr_new (post_gc_action);
-action.fun = fun;
-action.arg = arg;
-Dynarr_add (post_gc_actions, action);
-}
-static void
-run_post_gc_actions (void)
-{
-int i;
-if (post_gc_actions)
-{
-for (i = 0; i < Dynarr_length (post_gc_actions); i++)
-	{
-	  post_gc_action action = Dynarr_at (post_gc_actions, i);
-	  (action.fun) (action.arg);
-	}
-Dynarr_reset (post_gc_actions);
-}
-}
-void
-garbage_collect_1 (void)
-{
-#if MAX_SAVE_STACK > 0
-char stack_top_variable;
-extern char *stack_bottom;
-#endif
-struct frame *f;
-int speccount;
-int cursor_changed;
-Lisp_Object pre_gc_cursor;
-struct gcpro gcpro1;
-PROFILE_DECLARE ();
-assert (!in_display || gc_currently_forbidden);
-if (gc_in_progress
-|| gc_currently_forbidden
-|| in_display
-|| preparing_for_armageddon)
-return;
-PROFILE_RECORD_ENTERING_SECTION (QSin_garbage_collection);
-/* We used to call selected_frame() here.
-The following functions cannot be called inside GC
-so we move to after the above tests. */
-{
-Lisp_Object frame;
-Lisp_Object device = Fselected_device (Qnil);
-if (NILP (device)) /* Could happen during startup, eg. if always_gc */
-return;
-frame = Fselected_frame (device);
-if (NILP (frame))
-invalid_state ("No frames exist on device", device);
-f = XFRAME (frame);
-}
-pre_gc_cursor = Qnil;
-cursor_changed = 0;
-GCPRO1 (pre_gc_cursor);
-/* Very important to prevent GC during any of the following
-stuff that might run Lisp code; otherwise, we'll likely
-have infinite GC recursion. */
-speccount = begin_gc_forbidden ();
-need_to_signal_post_gc = 0;
-recompute_funcall_allocation_flag ();
-if (!gc_hooks_inhibited)
-run_hook_trapping_problems
-(Qgarbage_collecting, Qpre_gc_hook,
-INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);
-/* Now show the GC cursor/message. */
-if (!noninteractive)
-{
-if (FRAME_WIN_P (f))
-	{
-	  Lisp_Object frame = wrap_frame (f);
-	  Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
-						     FRAME_SELECTED_WINDOW (f),
-						     ERROR_ME_NOT, 1);
-	  pre_gc_cursor = f->pointer;
-	  if (POINTER_IMAGE_INSTANCEP (cursor)
-	      /* don't change if we don't know how to change back. */
-	      && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
-	    {
-	      cursor_changed = 1;
-	      Fset_frame_pointer (frame, cursor);
-	    }
-	}
-/* Don't print messages to the stream device. */
-if (!cursor_changed && !FRAME_STREAM_P (f))
-	{
-	  if (garbage_collection_messages)
-	    {
-	      Lisp_Object args[2], whole_msg;
-	      args[0] = (STRINGP (Vgc_message) ? Vgc_message :
-			 build_msg_string (gc_default_message));
-	      args[1] = build_string ("...");
-	      whole_msg = Fconcat (2, args);
-	      echo_area_message (f, (Ibyte *) 0, whole_msg, 0, -1,
-				 Qgarbage_collecting);
-	    }
-	}
-}
-/***** Now we actually start the garbage collection. */
-gc_in_progress = 1;
-inhibit_non_essential_conversion_operations = 1;
-gc_generation_number[0]++;
-#if MAX_SAVE_STACK > 0
-/* Save a copy of the contents of the stack, for debugging.  */
-if (!purify_flag)
-{
-/* Static buffer in which we save a copy of the C stack at each GC.  */
-static char *stack_copy;
-static Bytecount stack_copy_size;
-ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
-Bytecount stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
-if (stack_size < MAX_SAVE_STACK)
-	{
-	  if (stack_copy_size < stack_size)
-	    {
-	      stack_copy = (char *) xrealloc (stack_copy, stack_size);
-	      stack_copy_size = stack_size;
-	    }
-	  memcpy (stack_copy,
-		  stack_diff > 0 ? stack_bottom : &stack_top_variable,
-		  stack_size);
-	}
-}
-#endif /* MAX_SAVE_STACK > 0 */
-/* Do some totally ad-hoc resource clearing. */
-/* #### generalize this? */
-clear_event_resource ();
-cleanup_specifiers ();
-cleanup_buffer_undo_lists ();
-/* Mark all the special slots that serve as the roots of accessibility. */
-#ifdef USE_KKCC
-/* initialize kkcc stack */
-kkcc_gc_stack_init();
-#define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1)
-#endif /* USE_KKCC */
-{ /* staticpro() */
-Lisp_Object **p = Dynarr_begin (staticpros);
-Elemcount count;
-for (count = Dynarr_length (staticpros); count; count--)
-mark_object (**p++);
-}
-{ /* staticpro_nodump() */
-Lisp_Object **p = Dynarr_begin (staticpros_nodump);
-Elemcount count;
-for (count = Dynarr_length (staticpros_nodump); count; count--)
-mark_object (**p++);
-}
-#ifdef MC_ALLOC
-{ /* mcpro () */
-Lisp_Object *p = Dynarr_begin (mcpros);
-Elemcount count;
-for (count = Dynarr_length (mcpros); count; count--)
-mark_object (*p++);
-}
-#endif /* MC_ALLOC */
-{ /* GCPRO() */
-struct gcpro *tail;
-int i;
-for (tail = gcprolist; tail; tail = tail->next)
-for (i = 0; i < tail->nvars; i++)
-	mark_object (tail->var[i]);
-}
-{ /* specbind() */
-struct specbinding *bind;
-for (bind = specpdl; bind != specpdl_ptr; bind++)
-{
-	mark_object (bind->symbol);
-	mark_object (bind->old_value);
-}
-}
-{
-struct catchtag *c;
-for (c = catchlist; c; c = c->next)
-{
-	mark_object (c->tag);
-	mark_object (c->val);
-	mark_object (c->actual_tag);
-	mark_object (c->backtrace);
-}
-}
-{
-struct backtrace *backlist;
-for (backlist = backtrace_list; backlist; backlist = backlist->next)
-{
-	int nargs = backlist->nargs;
-	int i;
-	mark_object (*backlist->function);
-	if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */
-	    /* might be fake (internal profiling entry) */
-	    && backlist->args)
-	  mark_object (backlist->args[0]);
-	else
-	  for (i = 0; i < nargs; i++)
-	    mark_object (backlist->args[i]);
-}
-}
-mark_profiling_info ();
-/* OK, now do the after-mark stuff.  This is for things that
-are only marked when something else is marked (e.g. weak hash tables).
-There may be complex dependencies between such objects -- e.g.
-a weak hash table might be unmarked, but after processing a later
-weak hash table, the former one might get marked.  So we have to
-iterate until nothing more gets marked. */
-#ifdef USE_KKCC
-kkcc_marking ();
-#endif /* USE_KKCC */
-init_marking_ephemerons ();
-while (finish_marking_weak_hash_tables () > 0 ||
-	 finish_marking_weak_lists       () > 0 ||
-	 continue_marking_ephemerons     () > 0)
-#ifdef USE_KKCC
-{
-kkcc_marking ();
-}
-#else /* NOT USE_KKCC */
-;
-#endif /* USE_KKCC */
-/* At this point, we know which objects need to be finalized: we
-still need to resurrect them */
-while (finish_marking_ephemerons       () > 0 ||
-	 finish_marking_weak_lists       () > 0 ||
-	 finish_marking_weak_hash_tables () > 0)
-#ifdef USE_KKCC
-{
-kkcc_marking ();
-}
-kkcc_gc_stack_free ();
-#undef mark_object
-#else /* NOT USE_KKCC */
-;
-#endif /* USE_KKCC */
-/* And prune (this needs to be called after everything else has been
-marked and before we do any sweeping). */
-/* #### this is somewhat ad-hoc and should probably be an object
-method */
-prune_weak_hash_tables ();
-prune_weak_lists ();
-prune_specifiers ();
-prune_syntax_tables ();
-prune_ephemerons ();
-prune_weak_boxes ();
-gc_sweep ();
-consing_since_gc = 0;
-#ifndef DEBUG_XEMACS
-/* Allow you to set it really fucking low if you really want ... */
-if (gc_cons_threshold < 10000)
-gc_cons_threshold = 10000;
-#endif
-recompute_need_to_garbage_collect ();
-inhibit_non_essential_conversion_operations = 0;
-gc_in_progress = 0;
-run_post_gc_actions ();
-/******* End of garbage collection ********/
-/* Now remove the GC cursor/message */
-if (!noninteractive)
-{
-if (cursor_changed)
-	Fset_frame_pointer (wrap_frame (f), pre_gc_cursor);
-else if (!FRAME_STREAM_P (f))
-	{
-	  /* Show "...done" only if the echo area would otherwise be empty. */
-	  if (NILP (clear_echo_area (selected_frame (),
-				     Qgarbage_collecting, 0)))
-	    {
-	      if (garbage_collection_messages)
-		{
-		  Lisp_Object args[2], whole_msg;
-		  args[0] = (STRINGP (Vgc_message) ? Vgc_message :
-			     build_msg_string (gc_default_message));
-		  args[1] = build_msg_string ("... done");
-		  whole_msg = Fconcat (2, args);
-		  echo_area_message (selected_frame (), (Ibyte *) 0,
-				     whole_msg, 0, -1,
-				     Qgarbage_collecting);
-		}
-	    }
-	}
-}
-/* now stop inhibiting GC */
-unbind_to (speccount);
-#ifndef MC_ALLOC
-if (!breathing_space)
-{
-breathing_space = malloc (4096 - MALLOC_OVERHEAD);
-}
-#endif /* not MC_ALLOC */
-UNGCPRO;
-need_to_signal_post_gc = 1;
-funcall_allocation_flag = 1;
-PROFILE_RECORD_EXITING_SECTION (QSin_garbage_collection);
-return;
 }
 #ifdef ALLOC_TYPE_STATS
 static Lisp_Object
 	  else
 	    sprintf (buf, "%ss-used", name);
 	  pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl);
 }
 }
-pl = gc_plist_hack ("string-data-storage-including-overhead",
-		      lrecord_string_data_bytes_in_use_including_overhead, pl);
-pl = gc_plist_hack ("string-data-storage-additional",
-		      lrecord_string_data_bytes_in_use, pl);
-pl = gc_plist_hack ("string-data-used",
-		      lrecord_string_data_instances_in_use, pl);
-tgu_val += lrecord_string_data_bytes_in_use_including_overhead;
 #else /* not MC_ALLOC */
 #define HACK_O_MATIC(type, name, pl) do {				\
 EMACS_INT s = 0;							\
 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
 */
 ())
 {
 /* Record total usage for purposes of determining next GC */
+#ifdef NEW_GC
+gc_full ();
+#else /* not NEW_GC */
 garbage_collect_1 ();
+#endif /* not NEW_GC */
 /* This will get set to 1, and total_gc_usage computed, as part of the
 call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */
 total_gc_usage_set = 0;
 #ifdef ALLOC_TYPE_STATS
 need_to_garbage_collect ||
 need_to_check_c_alloca ||
 need_to_signal_post_gc;
 }
-/* True if it's time to garbage collect now. */
-static void
-recompute_need_to_garbage_collect (void)
-{
-if (always_gc)
-need_to_garbage_collect = 1;
-else
-need_to_garbage_collect =
-(consing_since_gc > gc_cons_threshold
-&&
-#if 0 /* #### implement this better */
-(100 * consing_since_gc) / total_data_usage () >=
-gc_cons_percentage
-#else
-(!total_gc_usage_set ||
-	(100 * consing_since_gc) / total_gc_usage >=
-	gc_cons_percentage)
-#endif
-);
-recompute_funcall_allocation_flag ();
-}
 int
 object_dead_p (Lisp_Object obj)
 {
 return ((BUFFERP  (obj) && !BUFFER_LIVE_P  (XBUFFER  (obj))) ||
 /* C guarantees that Qnull_pointer will be initialized to all 0 bits,
 so the following is actually a no-op.  */
 Qnull_pointer = wrap_pointer_1 (0);
 #endif
-gc_generation_number[0] = 0;
 #ifndef MC_ALLOC
 breathing_space = 0;
 #endif /* not MC_ALLOC */
-Vgc_message = Qzero;
 #ifndef MC_ALLOC
 all_lcrecords = 0;
 #endif /* not MC_ALLOC */
 ignore_malloc_warnings = 1;
 #ifdef DOUG_LEA_MALLOC
 mallopt (M_MMAP_THRESHOLD, 64*1024); /* mmap threshold */
 #if 0 /* Moved to emacs.c */
 mallopt (M_MMAP_MAX, 64); /* max. number of mmap'ed areas */
 #endif
 #endif
+#ifndef NEW_GC
 init_string_chars_alloc ();
+#endif /* not NEW_GC */
 #ifndef MC_ALLOC
 init_string_alloc ();
 init_string_chars_alloc ();
 init_cons_alloc ();
 init_symbol_alloc ();
 dump_add_root_block_ptr (&mcpro_names, &mcpro_names_description);
 #endif
 #endif /* MC_ALLOC */
 consing_since_gc = 0;
-need_to_garbage_collect = always_gc;
 need_to_check_c_alloca = 0;
 funcall_allocation_flag = 0;
 funcall_alloca_count = 0;
-#if 1
-gc_cons_threshold = 2000000; /* XEmacs change */
-#else
-gc_cons_threshold = 15000; /* debugging */
-#endif
-gc_cons_percentage = 40; /* #### what is optimal? */
-total_gc_usage_set = 0;
 lrecord_uid_counter = 259;
 #ifndef MC_ALLOC
 debug_string_purity = 0;
 #endif /* not MC_ALLOC */
-gc_currently_forbidden = 0;
-gc_hooks_inhibited = 0;
 #ifdef ERROR_CHECK_TYPES
 ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
 666;
 ERROR_ME_NOT.
 }
 INIT_LRECORD_IMPLEMENTATION (cons);
 INIT_LRECORD_IMPLEMENTATION (vector);
 INIT_LRECORD_IMPLEMENTATION (string);
+#ifdef NEW_GC
+INIT_LRECORD_IMPLEMENTATION (string_indirect_data);
+INIT_LRECORD_IMPLEMENTATION (string_direct_data);
+#endif /* NEW_GC */
 #ifndef MC_ALLOC
 INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
 INIT_LRECORD_IMPLEMENTATION (free);
 #endif /* not MC_ALLOC */
 }
 void
 syms_of_alloc (void)
 {
-DEFSYMBOL (Qpre_gc_hook);
-DEFSYMBOL (Qpost_gc_hook);
 DEFSYMBOL (Qgarbage_collecting);
 DEFSUBR (Fcons);
 DEFSUBR (Flist);
 DEFSUBR (Fvector);
 }
 void
 vars_of_alloc (void)
 {
-QSin_garbage_collection = build_msg_string ("(in garbage collection)");
-staticpro (&QSin_garbage_collection);
-DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
-*Number of bytes of consing between garbage collections.
-\"Consing\" is a misnomer in that this actually counts allocation
-of all different kinds of objects, not just conses.
-Garbage collection can happen automatically once this many bytes have been
-allocated since the last garbage collection.  All data types count.
-Garbage collection happens automatically when `eval' or `funcall' are
-called.  (Note that `funcall' is called implicitly as part of evaluation.)
-By binding this temporarily to a large number, you can effectively
-prevent garbage collection during a part of the program.
-Normally, you cannot set this value less than 10,000 (if you do, it is
-automatically reset during the next garbage collection).  However, if
-XEmacs was compiled with DEBUG_XEMACS, this does not happen, allowing
-you to set this value very low to track down problems with insufficient
-GCPRO'ing.  If you set this to a negative number, garbage collection will
-happen at *EVERY* call to `eval' or `funcall'.  This is an extremely
-effective way to check GCPRO problems, but be warned that your XEmacs
-will be unusable!  You almost certainly won't have the patience to wait
-long enough to be able to set it back.
-See also `consing-since-gc' and `gc-cons-percentage'.
-*/ );
-DEFVAR_INT ("gc-cons-percentage", &gc_cons_percentage /*
-*Percentage of memory allocated between garbage collections.
-Garbage collection will happen if this percentage of the total amount of
-memory used for data (see `lisp-object-memory-usage') has been allocated
-since the last garbage collection.  However, it will not happen if less
-than `gc-cons-threshold' bytes have been allocated -- this sets an absolute
-minimum in case very little data has been allocated or the percentage is
-set very low.  Set this to 0 to have garbage collection always happen after
-`gc-cons-threshold' bytes have been allocated, regardless of current memory
-usage.
-See also `consing-since-gc' and `gc-cons-threshold'.
-*/ );
 #ifdef DEBUG_XEMACS
 DEFVAR_INT ("debug-allocation", &debug_allocation /*
 If non-zero, print out information to stderr about all objects allocated.
 See also `debug-allocation-backtrace-length'.
 */ );
 DEFVAR_BOOL ("purify-flag", &purify_flag /*
 Non-nil means loading Lisp code in order to dump an executable.
 This means that certain objects should be allocated in readonly space.
 */ );
+}
-DEFVAR_BOOL ("garbage-collection-messages", &garbage_collection_messages /*
-Non-nil means display messages at start and end of garbage collection.
-*/ );
-garbage_collection_messages = 0;
-DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
-Function or functions to be run just before each garbage collection.
-Interrupts, garbage collection, and errors are inhibited while this hook
-runs, so be extremely careful in what you add here.  In particular, avoid
-consing, and do not interact with the user.
-*/ );
-Vpre_gc_hook = Qnil;
-DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
-Function or functions to be run just after each garbage collection.
-Interrupts, garbage collection, and errors are inhibited while this hook
-runs.  Each hook is called with one argument which is an alist with
-finalization data.
-*/ );
-Vpost_gc_hook = Qnil;
-DEFVAR_LISP ("gc-message", &Vgc_message /*
-String to print to indicate that a garbage collection is in progress.
-This is printed in the echo area.  If the selected frame is on a
-window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
-image instance) in the domain of the selected frame, the mouse pointer
-will change instead of this message being printed.
-*/ );
-Vgc_message = build_string (gc_default_message);
-DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
-Pointer glyph used to indicate that a garbage collection is in progress.
-If the selected window is on a window system and this glyph specifies a
-value (i.e. a pointer image instance) in the domain of the selected
-window, the pointer will be changed as specified during garbage collection.
-Otherwise, a message will be printed in the echo area, as controlled
-by `gc-message'.
-*/ );
-}
-void
-complex_vars_of_alloc (void)
-{
-Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
-}

Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 3092:141c2920ea48