xemacs-beta: src/alloc.c comparison

comparison src/alloc.c @ 183:e121b013d1f0 r20-3b18

Import from CVS: tag r20-3b18

author	cvs
date	Mon, 13 Aug 2007 09:54:23 +0200
parents	6075d714658b
children	3d6bfa290dbd

comparison

equal deleted inserted replaced

-:f07455f06202
+:e121b013d1f0
 consing_since_gc += __sz__;			\
 cadillac_record_backtrace (2, __sz__);	\
 } while (0)
 #else
 #define INCREMENT_CONS_COUNTER_1(size) (consing_since_gc += (size))
-#endif
+#endif /* EMACS_BTL */
 #define debug_allocation_backtrace()				\
 do {								\
 if (debug_allocation_backtrace_length > 0)			\
 debug_short_backtrace (debug_allocation_backtrace_length);	\
 static int purecopying_for_bytecode;
 static int pure_sizeof (Lisp_Object /*, int recurse */);
 /* Keep statistics on how much of what is in purespace */
-struct purestat
+static struct purestat
 {
 int nobjects;
 int nbytes;
 CONST char *name;
-};
+}
+purestat_cons = {0, 0, "cons cells"},
-#define FMH(s,n) static struct purestat s = { 0, 0, n }
+purestat_float = {0, 0, "float objects"},
-FMH (purestat_cons, "cons cells:");
+purestat_string_pname = {0, 0, "symbol-name strings"},
-FMH (purestat_float, "float objects:");
+purestat_bytecode = {0, 0, "compiled-function objects"},
-FMH (purestat_string_pname, "symbol-name strings:");
+purestat_string_bytecodes = {0, 0, "byte-code strings"},
-FMH (purestat_bytecode, "compiled-function objects:");
+purestat_vector_bytecode_constants = {0, 0, "byte-constant vectors"},
-FMH (purestat_string_bytecodes, "byte-code strings:");
+purestat_string_interactive = {0, 0, "interactive strings"},
-FMH (purestat_vector_bytecode_constants, "byte-constant vectors:");
-FMH (purestat_string_interactive, "interactive strings:");
 #ifdef I18N3
-FMH (purestat_string_domain, "domain strings:");
+purestat_string_domain = {0, 0, "domain strings"},
 #endif
-FMH (purestat_string_documentation, "documentation strings:");
+purestat_string_documentation = {0, 0, "documentation strings"},
-FMH (purestat_string_other_function, "other function strings:");
+purestat_string_other_function = {0, 0, "other function strings"},
-FMH (purestat_vector_other, "other vectors:");
+purestat_vector_other = {0, 0, "other vectors"},
-FMH (purestat_string_other, "other strings:");
+purestat_string_other = {0, 0, "other strings"},
-FMH (purestat_string_all, "all strings:");
+purestat_string_all = {0, 0, "all strings"},
-FMH (purestat_vector_all, "all vectors:");
+purestat_vector_all = {0, 0, "all vectors"};
 static struct purestat *purestats[] =
 {
 &purestat_cons,
 &purestat_float,
 &purestat_string_other,
 0,
 &purestat_string_all,
 &purestat_vector_all
 };
-#undef FMH
 static void
 bump_purestat (struct purestat *purestat, int nbytes)
 {
 if (pure_lossage) return;
 static void *breathing_space;
 void
 release_breathing_space (void)
 {
 if (breathing_space)
 {
 void *tmp = breathing_space;
 breathing_space = 0;
 xfree (tmp);
 }
 /* Unbelievably, calling free() on 0xDEADBEEF doesn't cause an
 error until much later on for many system mallocs, such as
 the one that comes with Solaris 2.3.  FMH!! */
 assert (block != (void *) 0xDEADBEEF);
 assert (block);
-#endif
+#endif /* ERROR_CHECK_MALLOC */
 free (block);
 }
 #if INTBITS == 32
 # define FOUR_BYTE_TYPE unsigned int
 deadbeef_memory (void *ptr, unsigned long size)
 {
 unsigned long long_length = size / sizeof (FOUR_BYTE_TYPE);
 unsigned long i;
 unsigned long bytes_left_over = size - sizeof (FOUR_BYTE_TYPE) * long_length;
 for (i = 0; i < long_length; i++)
 ((FOUR_BYTE_TYPE *) ptr)[i] = 0xdeadbeef;
 for (i = i; i < bytes_left_over; i++)
 ((unsigned char *) ptr + long_length)[i] = deadbeef_as_char[i];
 }
-#else
+#else /* !ERROR_CHECK_GC */
 #define deadbeef_memory(ptr, size)
-#endif
+#endif /* !ERROR_CHECK_GC */
 #ifdef xstrdup
 #undef xstrdup
 #endif
 do { (((lheader)->implementation)--); } while (0)
 /* lrecords are chained together through their "next.v" field.
 * After doing the mark phase, the GC will walk this linked
 *  list and free any record which hasn't been marked
 */
 static struct lcrecord_header *all_lcrecords;
 void *
 alloc_lcrecord (int size, CONST struct lrecord_implementation *implementation)
 {
 if (header->lheader.implementation->finalizer && !header->free)
 	((header->lheader.implementation->finalizer) (header, 1));
 }
 }
 /* This must not be called -- it just serves as for EQ test
 *  If lheader->implementation->finalizer is this_marks_a_marked_record,
 *  then lrecord has been marked by the GC sweeper
 * header->implementation is put back to its correct value by
 make more sense) are malloc()ed separately and not stored in
 string_chars_blocks.  Furthermore, no one string stretches across
 two string_chars_blocks.
 Vectors are each malloc()ed separately, similar to lcrecords.
 In the following discussion, we use conses, but it applies equally
 well to the other fixed-size types.
 We store cons cells inside of cons_blocks, allocating a new
 cons_block with malloc() whenever necessary.  Cons cells reclaimed
 #elif defined (rcheck)
 #define MALLOC_OVERHEAD 20
 #else
 #define MALLOC_OVERHEAD 8
 #endif
-#endif
+#endif /* MALLOC_OVERHEAD */
 #ifdef ALLOC_NO_POOLS
 # define TYPE_ALLOC_SIZE(type, structtype) 1
 #else
 # define TYPE_ALLOC_SIZE(type, structtype)			\
 ((2048 - MALLOC_OVERHEAD - sizeof (struct type##_block *))	\
 / sizeof (structtype))
-#endif
+#endif /* ALLOC_NO_POOLS */
 #define DECLARE_FIXED_TYPE_ALLOC(type, structtype)			  \
 									  \
 struct type##_block							  \
 {									  \
 else									 \
 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);			 \
 MARK_STRUCT_AS_NOT_FREE (result);					 \
 } while (0)
-#else
+#else /* !ERROR_CHECK_GC */
 #define ALLOCATE_FIXED_TYPE_1(type, structtype, result)		\
 do								\
 {								\
 if (type##_free_list)						\
 else								\
 ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result);		\
 MARK_STRUCT_AS_NOT_FREE (result);				\
 } while (0)
-#endif
+#endif /* !ERROR_CHECK_GC */
 #define ALLOCATE_FIXED_TYPE(type, structtype, result)	\
 do							\
 {							\
 ALLOCATE_FIXED_TYPE_1 (type, structtype, result);	\
 be a pointer, and the pointer will be misaligned.
 Even if Emacs is run on some weirdo system that allows and allocates
 byte-aligned pointers, this pointer is at the very top of the address
 space and so it's almost inconceivable that it could ever be valid. */
 #if INTBITS == 32
 # define INVALID_POINTER_VALUE 0xFFFFFFFF
 #elif INTBITS == 48
 # define INVALID_POINTER_VALUE 0xFFFFFFFFFFFF
 #elif INTBITS == 64
 else								\
 type##_free_list = ptr;						\
 type##_free_list_tail = ptr;					\
 } while (0)
-#else
+#else /* !ERROR_CHECK_GC */
 #define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr)	\
 do { * (structtype **) ((char *) ptr + sizeof (void *)) =	\
 type##_free_list;					\
 type##_free_list = ptr;					\
 } while (0)
-#endif
+#endif /* !ERROR_CHECK_GC */
 /* TYPE and STRUCTTYPE are the same as in ALLOCATE_FIXED_TYPE(). */
 #define FREE_FIXED_TYPE(type, structtype, ptr)			\
 do { structtype *_weird_ = (ptr);				\
 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(type, structtype, ptr)	\
 do { FREE_FIXED_TYPE (type, structtype, ptr);			\
 DECREMENT_CONS_COUNTER (sizeof (structtype));		\
 gc_count_num_##type##_freelist++;				\
 } while (0)
 /**********************************************************************/
 /*                         Cons allocation                            */
 /**********************************************************************/
 the objects are sitting on Vload_force_doc_string_list, which
 is staticpro'd, so we're OK. */
 int purecopy_instructions = 1;
 if (nargs > 6)
 return Fsignal (Qwrong_number_of_arguments,
 		    list2 (intern ("make-byte-code"), make_int (nargs)));
 CHECK_LIST (arglist);
 /* instructions is a string or a cons (string . int) for a
 lazy-loaded function. */
 if (STRINGP (interactive))
 	bump_purestat (&purestat_string_interactive,
 		       pure_sizeof (interactive));
 #endif /* PURESTAT */
 }
 {
 int docp = !NILP (doc_string);
 int intp = !UNBOUNDP (interactive);
 #ifdef I18N3
 int domp = !NILP (Vfile_domain);
 	Vload_file_name_internal_the_purecopy =
 	  Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
 	b->annotated = Vload_file_name_internal_the_purecopy;
 	UNGCPRO;
 }
-#endif
+#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
 #ifdef I18N3
 if (docp && intp && domp)
 b->doc_and_interactive = (((purify_flag) ? pure_cons : Fcons)
 				(doc_string,
 set_lheader_implementation (&(e->lheader), lrecord_event);
 XSETEVENT (val, e);
 return val;
 }
 /**********************************************************************/
 /*                       Marker allocation                            */
 /**********************************************************************/
 /**********************************************************************/
 /*                        String allocation                           */
 /**********************************************************************/
 /* The data for "short" strings generally resides inside of structs of type
 string_chars_block. The Lisp_String structure is allocated just like any
 other Lisp object (except for vectors), and these are freelisted when
 they get garbage collected. The data for short strings get compacted,
 but the data for large strings do not.
 Previously Lisp_String structures were relocated, but this caused a lot
 of bus-errors because the C code didn't include enough GCPRO's for
 strings (since EVERY REFERENCE to a short string needed to be GCPRO'd so
 that the reference would get relocated).
 };
 static void
 init_string_chars_alloc (void)
 {
 first_string_chars_block =
 (struct string_chars_block *) xmalloc (sizeof (struct string_chars_block));
 first_string_chars_block->prev = 0;
 first_string_chars_block->next = 0;
 first_string_chars_block->pos = 0;
 current_string_chars_block = first_string_chars_block;
 current_string_chars_block->pos += fullsize;
 }
 else
 {
 /* Make a new current string chars block */
 struct string_chars_block *new
 	= (struct string_chars_block *)
 	  xmalloc (sizeof (struct string_chars_block));
 current_string_chars_block->next = new;
 new->prev = current_string_chars_block;
 new->next = 0;
 current_string_chars_block = new;
 new->pos = fullsize;
 s_chars = allocate_string_chars_struct (s, fullsize);
 set_string_data (s, &(s_chars->chars[0]));
 set_string_length (s, length);
 s->plist = Qnil;
 set_string_byte (s, length, 0);
 XSETSTRING (val, s);
 return val;
 }
 #ifdef VERIFY_STRING_CHARS_INTEGRITY
 static void verify_string_chars_integrity (void);
 #endif
 /* Resize the string S so that DELTA bytes can be inserted starting
 at POS.  If DELTA < 0, it means deletion starting at POS.  If
 POS < 0, resize the string but don't copy any characters.  Use
 this if you're planning on completely overwriting the string.
 */
 else
 {
 if (delta < 0)
 	assert ((-delta) <= string_length (s));
 }
-#endif
+#endif /* ERROR_CHECK_BUFPOS */
 if (pos >= 0 && delta < 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. */
 	     allocation size won't change (up or down; code somewhere
 	     depends on there not being any unused allocation space,
 	     modulo any alignment constraints). */
 	  if (pos >= 0)
 	    {
 	      Bufbyte *addroff = pos + string_data (s);
 	      memmove (addroff + delta, addroff,
 		       /* +1 due to zero-termination. */
 		       string_length (s) + 1 - pos);
 	    }
 	     string could result in memory leakage. */
 	  set_string_data (s, (Bufbyte *) xrealloc (string_data (s),
 						    newfullsize));
 	  if (pos >= 0)
 	    {
 	      Bufbyte *addroff = pos + string_data (s);
 	      memmove (addroff + delta, addroff,
 		       /* +1 due to zero-termination. */
 		       string_length (s) + 1 - pos);
 	    }
 /* Make sure we find out about bad make_string's when they happen */
 #if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
 bytecount_to_charcount (contents, length); /* Just for the assertions */
 #endif
 val = make_uninit_string (length);
 memcpy (XSTRING_DATA (val), contents, length);
 return val;
 }
 #endif /* ERROR_CHECK_GC */
 MARK_RECORD_HEADER (lheader);
 chain = free_header->chain;
 }
 return Qnil;
 }
 Lisp_Object
 make_lcrecord_list (int size,
 /* The type of the lcrecord must be right. */
 assert (implementation == list->implementation);
 /* So must the size. */
 assert (implementation->static_size == 0
 	      || implementation->static_size == list->size);
-#endif
+#endif /* ERROR_CHECK_GC */
 list->free = free_header->chain;
 free_header->lcheader.free = 0;
 return val;
 }
 else
 if (implementation->size_in_bytes_method)
 assert (((implementation->size_in_bytes_method) (lheader))
 	    == list->size);
 else
 assert (implementation->static_size == list->size);
-#endif
+#endif /* ERROR_CHECK_GC */
 if (implementation->finalizer)
 ((implementation->finalizer) (lheader, 0));
 free_header->chain = list->free;
 free_header->lcheader.free = 1;
 make_pure_string (CONST Bufbyte *data, Bytecount length,
 		  Lisp_Object plist, int no_need_to_copy_data)
 {
 Lisp_Object new;
 struct Lisp_String *s;
 int size = (sizeof (struct Lisp_String) + ((no_need_to_copy_data)
 ? 0
 /* + 1 for terminating 0 */
 : (length + 1)));
 size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
 if (symbols_initialized && !pure_lossage)
 #ifdef PURESTAT
 bump_purestat (&purestat_string_all, size);
 if (purecopying_for_bytecode)
 bump_purestat (&purestat_string_other_function, size);
-#endif
+#endif /* PURESTAT */
 /* Do this after the official "completion" of the purecopying. */
 s->plist = Fpurecopy (plist);
 XSETSTRING (new, s);
 that the `double' slot in it is supposed to be aligned to; this
 should be ok because presumably there is padding in the layout
 of the struct to account for this.
 */
 int alignment = sizeof (float_data (f));
-#endif
+#endif /* !GNUC */
 char *p = ((char *) PUREBEG + pureptr);
 p = (char *) (((unsigned EMACS_INT) p + alignment - 1) & - alignment);
 pureptr = p - (char *) PUREBEG;
 }
 set_lheader_implementation (header, implementation);
 header->next = 0;
 return header;
 }
-#endif
+#endif /* unused */
 DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
 Make a copy of OBJECT in pure storage.
 }
 static void
-PURESIZE_h(long int puresize)
+puresize_adjust_h (long int puresize)
 {
-int fd;
+FILE *stream = fopen ("puresize-adjust.h", "w");
-char *PURESIZE_h_file = "puresize_adjust.h";
-char *WARNING = "/* This file is generated by XEmacs, DO NOT MODIFY!!! */\n";
+if (stream == NULL)
-char define_PURESIZE[256];
+report_file_error ("Opening puresize adjustment file",
+		       Fcons (build_string ("puresize-adjust.h"), Qnil));
-if ((fd = open(PURESIZE_h_file, O_WRONLY|O_CREAT|O_TRUNC, 0666)) < 0) {
-report_file_error("Can't write PURESIZE_ADJUSTMENT",
+fprintf (stream,
-		      Fcons(build_ext_string(PURESIZE_h_file, FORMAT_FILENAME),
+	   "/*\tDo not edit this file!\n"
-			    Qnil));
+	   "\tAutomatically generated by XEmacs */\n"
-}
+	   "# define PURESIZE_ADJUSTMENT (%ld)\n",
+	   puresize - RAW_PURESIZE);
-write(fd, WARNING, strlen(WARNING));
+fclose (stream);
-sprintf(define_PURESIZE, "# define PURESIZE_ADJUSTMENT (%ld)\n",
-	  puresize - RAW_PURESIZE);
-write(fd, define_PURESIZE, strlen(define_PURESIZE));
-close(fd);
 }
 void
 report_pure_usage (int report_impurities,
 int die_if_pure_storage_exceeded)
 int rc = 0;
 if (pure_lossage)
 {
 message ("\n****\tPure Lisp storage exhausted!\n"
-"\tPurespace usage: %ld of %ld\n"
+	       "\tPurespace usage: %ld of %ld\n"
-"****",
+	       "****",
 get_PURESIZE()+pure_lossage, (long) get_PURESIZE());
 if (die_if_pure_storage_exceeded) {
-	PURESIZE_h(get_PURESIZE() + pure_lossage);
+	puresize_adjust_h (get_PURESIZE() + pure_lossage);
 	rc = -1;
 }
 }
 else
 {
 pureptr, (long) get_PURESIZE(),
 (int) (pureptr / (get_PURESIZE() / 100.0) + 0.5));
 if (lost > 2) {
 sprintf (buf + strlen (buf), " -- %dk wasted", lost);
 	if (die_if_pure_storage_exceeded) {
-	  PURESIZE_h(pureptr + 16);
+	  puresize_adjust_h (pureptr + 16);
 	  rc = -1;
 	}
 }
 strcat (buf, ").");
 message ("%s", buf);
 }
 #ifdef PURESTAT
+purestat_vector_other.nbytes =
+purestat_vector_all.nbytes -
+purestat_vector_bytecode_constants.nbytes;
+purestat_vector_other.nobjects =
+purestat_vector_all.nobjects -
+purestat_vector_bytecode_constants.nobjects;
+purestat_string_other.nbytes =
+purestat_string_all.nbytes -
+(purestat_string_pname.nbytes +
+purestat_string_bytecodes.nbytes +
+purestat_string_interactive.nbytes +
+purestat_string_documentation.nbytes +
+#ifdef I18N3
+purestat_string_domain.nbytes +
+#endif
+purestat_string_other_function.nbytes);
+purestat_string_other.nobjects =
+purestat_string_all.nobjects -
+(purestat_string_pname.nobjects +
+purestat_string_bytecodes.nobjects +
+purestat_string_interactive.nobjects +
+purestat_string_documentation.nobjects +
+#ifdef I18N3
+purestat_string_domain.nobjects +
+#endif
+purestat_string_other_function.nobjects);
+message ("   %-26s Total    Bytes", "");
 {
-int iii;
+int j;
-purestat_vector_other.nbytes =
+for (j = 0; j < countof (purestats); j++)
-purestat_vector_all.nbytes - purestat_vector_bytecode_constants.nbytes;
+if (!purestats[j])
-purestat_vector_other.nobjects =
-purestat_vector_all.nobjects -
-	purestat_vector_bytecode_constants.nobjects;
-purestat_string_other.nbytes =
-purestat_string_all.nbytes - (purestat_string_pname.nbytes +
-purestat_string_bytecodes.nbytes +
-purestat_string_interactive.nbytes +
-purestat_string_documentation.nbytes +
-#ifdef I18N3
-purestat_string_domain.nbytes +
-#endif
-purestat_string_other_function.nbytes);
-purestat_string_other.nobjects =
-purestat_string_all.nobjects - (purestat_string_pname.nobjects +
-purestat_string_bytecodes.nobjects +
-purestat_string_interactive.nobjects +
-purestat_string_documentation.nobjects +
-#ifdef I18N3
-purestat_string_domain.nobjects +
-#endif
-purestat_string_other_function.nobjects);
-message ("   %-24stotal:   bytes:", "");
-for (iii = 0; iii < countof (purestats); iii++)
-if (!purestats[iii])
 clear_message ();
 else
-message ("   %-24s%5d  %7d  %2d%%",
+	{
-purestats[iii]->name,
+	  char buf [100];
-purestats[iii]->nobjects,
+	  sprintf(buf, "%s:", purestats[j]->name);
-purestats[iii]->nbytes,
+	  message ("   %-26s %5d  %7d  %2d%%",
-(int) (purestats[iii]->nbytes / (pureptr / 100.0) + 0.5));
+		   buf,
+		   purestats[j]->nobjects,
+		   purestats[j]->nbytes,
+		   (int) (purestats[j]->nbytes / (pureptr / 100.0) + 0.5));
+	}
 }
 #endif /* PURESTAT */
 if (report_impurities)
 		  char *s = buf;
 		  memcpy (buf, string_data (XSYMBOL (Fcar (tem))->name),
 			  string_length (XSYMBOL (Fcar (tem))->name) + 1);
 		  while (*s++) if (*s == '-') *s = ' ';
 		  s--; *s++ = ':'; *s = 0;
-		  message ("   %-32s%6d", buf, total);
+		  message ("   %-33s %6d", buf, total);
 		}
 	      tem = Fcdr (Fcdr (tem));
 	    }
 	  else			/* WTF?! */
 	    {
 garbage_collect_1 ();         /* GC garbage_collect's garbage */
 }
 clear_message ();
 if (rc < 0) {
-(void)unlink("SATISFIED");
+unlink("SATISFIED");
 				/* Current build process on NT does */
 				/* not know how to restart itself. */
 				/* --marcpa */
 #ifndef WINDOWSNT
 fatal ("Pure size adjusted, Don't Panic!  I will restart the `make'");
 #endif
 } else if (pure_lossage && die_if_pure_storage_exceeded) {
 fatal ("Pure storage exhausted");
 }
 /* Mark reference to a Lisp_Object.  If the object referred to has not been
 seen yet, recursively mark all the references contained in it. */
 static void
 mark_object (Lisp_Object obj)
 {
 tail_recurse:
 mark_object (rest);
 }
 #ifdef PURESTAT
 /* Simpler than mark-object, because pure structure can't
-have any circularities
+have any circularities */
-*/
 #if 0 /* unused */
 static int idiot_c_doesnt_have_closures;
 static void
 idiot_c (Lisp_Object obj)
 int size = string_length (ptr);
 if (string_data (ptr) !=
 	    (unsigned char *) ptr + sizeof (struct Lisp_String))
 	  {
 	    /* string-data not allocated contiguously.
 	       Probably (better be!!) a pointer constant "C" data. */
 	    size = sizeof (struct Lisp_String);
 	  }
 else
 	  {
 total += (sizeof (struct Lisp_Vector)
 + (len - 1) * sizeof (Lisp_Object));
 #if 0 /* unused */
 if (!recurse)
 break;
 {
 int i;
 	  for (i = 0; i < len - 1; i++)
 	    total += pure_sizeof (ptr->contents[i], 1);
 	}
 if (len > 0)
 	    idiot_c_doesnt_have_closures = 0;
 	    obj = ((implementation->marker) (obj, idiot_c));
 	    total += idiot_c_doesnt_have_closures;
 	    idiot_c_doesnt_have_closures = old;
 	    if (!NILP (obj)) goto tail_recurse;
 	  }
 #endif /* unused */
 }
 break;
 *used = num_used;
 /* *total = total_size; */
 }
 static void
 sweep_vectors_1 (Lisp_Object *prev,
 int *used, int *total, int *storage)
 {
 Lisp_Object vector;
 int num_used = 0;
 int total_size = 0;
 *total = total_size;
 *storage = total_storage;
 }
 static void
 sweep_bit_vectors_1 (Lisp_Object *prev,
 		     int *used, int *total, int *storage)
 {
 Lisp_Object bit_vector;
 int num_used = 0;
 int total_size = 0;
 									\
 gc_count_num_##typename##_in_use = num_used;				\
 gc_count_num_##typename##_freelist = num_free;			\
 } while (0)
-#else
+#else /* !ERROR_CHECK_GC */
 #define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type)			      \
 do {									      \
 struct typename##_block *_frob_current;				      \
 struct typename##_block **_frob_prev;					      \
 									      \
 gc_count_num_##typename##_in_use = num_used;				      \
 gc_count_num_##typename##_freelist = num_free;			      \
 } while (0)
-#endif
+#endif /* !ERROR_CHECK_GC */
 static void
 a chain pointer to the next cons on the list, which has cleverly
 had all its 0's and 1's inverted.  This allows for a quick
 check to make sure we're not freeing something already freed. */
 if (POINTER_TYPE_P (XTYPE (ptr->car)))
 ASSERT_VALID_POINTER (XPNTR (ptr->car));
-#endif
+#endif /* ERROR_CHECK_GC */
 #ifndef ALLOC_NO_POOLS
 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
 #endif /* ALLOC_NO_POOLS */
 }
 #ifdef ERROR_CHECK_GC
 /* Perhaps this will catch freeing an already-freed marker. */
 Lisp_Object temmy;
 XSETMARKER (temmy, ptr);
 assert (GC_MARKERP (temmy));
-#endif
+#endif /* ERROR_CHECK_GC */
 #ifndef ALLOC_NO_POOLS
 FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
 #endif /* ALLOC_NO_POOLS */
 }
 {
 int pos = 0;
 /* POS is the index of the next string in the block.  */
 while (pos < sb->pos)
 {
 struct string_chars *s_chars =
 (struct string_chars *) &(sb->string_chars[pos]);
 struct Lisp_String *string;
 	  int size;
 	  int fullsize;
 {
 int from_pos = 0;
 /* FROM_POS is the index of the next string in the block.  */
 while (from_pos < from_sb->pos)
 {
 struct string_chars *from_s_chars =
 (struct string_chars *) &(from_sb->string_chars[from_pos]);
 struct string_chars *to_s_chars;
 struct Lisp_String *string;
 	  int size;
 	  int fullsize;
 {
 to_sb->pos = to_pos;
 to_sb = to_sb->next;
 to_pos = 0;
 }
 /* Compute new address of this string
 and update TO_POS for the space being used.  */
 to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
 /* Copy the string_chars to the new place.  */
 if (from_s_chars != to_s_chars)
 memmove (to_s_chars, from_s_chars, fullsize);
 /* Relocate FROM_S_CHARS's reference */
 set_string_data (string, &(to_s_chars->chars[0]));
 from_pos += fullsize;
 to_pos += fullsize;
 }
 }
 /* Set current to the last string chars block still used and
 free any that follow. */
 {
 struct string_chars_block *victim;
 for (victim = to_sb->next; victim; )
 else
 stderr_out ("%c", ch);
 }
 stderr_out ("\"\n");
 }
-#endif
+#endif /* 1 */
 static void
 sweep_strings (void)
 {
 	  char *msg = (STRINGP (Vgc_message)
 		       ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
 		       : 0);
 	  /* Show "...done" only if the echo area would otherwise be empty. */
 	  if (NILP (clear_echo_area (selected_frame (),
 				     Qgarbage_collecting, 0)))
 	    {
 	      Lisp_Object args[2], whole_msg;
 	      args[0] = build_string (msg ? msg :
 				      GETTEXT ((CONST char *)
 of the garbage collector by noting that PC is between &garbage_collect_1
 and &BTL_after_garbage_collect_1_stub.  So this fn must be right here.
 There's not any other way to know the address of the end of a function.
 */
 void BTL_after_garbage_collect_1_stub () { abort (); }
-#endif
+#endif /* EMACS_BTL */
 /* Debugging aids.  */
 static Lisp_Object
 gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
 DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
 Reclaim storage for Lisp objects no longer needed.
 Returns info on amount of space in use:
 ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
 (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
 PLIST)
 where `PLIST' is a list of alternating keyword/value pairs providing
 more detailed information.
 Garbage collection happens automatically if you cons more than
 `gc-cons-threshold' bytes of Lisp data since previous garbage collection.
 */
 garbage_collect_1 ();
 for (i = 0; i < last_lrecord_type_index_assigned; i++)
 {
 if (lcrecord_stats[i].bytes_in_use != 0
 || lcrecord_stats[i].bytes_freed != 0
 	  || lcrecord_stats[i].instances_on_free_list != 0)
 {
 char buf [255];
 CONST char *name = lrecord_implementations_table[i]->name;
 HACK_O_MATIC (float, "float-storage", pl);
 pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
 pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
 #endif /* LISP_FLOAT_TYPE */
 HACK_O_MATIC (string, "string-header-storage", pl);
 pl = gc_plist_hack ("long-strings-total-length",
 gc_count_string_total_size
 		      - gc_count_short_string_total_size, pl);
 HACK_O_MATIC (string_chars, "short-string-storage", pl);
 pl = gc_plist_hack ("short-strings-total-length",
 gc_count_short_string_total_size, pl);
 pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
 pl = gc_plist_hack ("long-strings-used",
 gc_count_num_string_in_use
 		      - gc_count_num_short_string_in_use, pl);
 pl = gc_plist_hack ("short-strings-used",
 gc_count_num_short_string_in_use, pl);
 HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
 pl = gc_plist_hack ("compiled-functions-free",
 		      gc_count_num_compiled_function_freelist, pl);
 pl = gc_plist_hack ("compiled-functions-used",
 		      gc_count_num_compiled_function_in_use, pl);
 pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
 pl = gc_plist_hack ("vectors-total-length",
 gc_count_vector_total_size, pl);
 pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
 pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
 pl = gc_plist_hack ("bit-vectors-total-length",
 gc_count_bit_vector_total_size, pl);
 pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
 HACK_O_MATIC (symbol, "symbol-storage", pl);
 pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
 */
 ())
 {
 return make_int (consing_since_gc);
 }
 DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
 Return the address of the last byte Emacs has allocated, divided by 1024.
 This may be helpful in debugging Emacs's memory usage.
 The value is divided by 1024 to make sure it will fit in a lisp integer.
 */
 	  (WINDOWP  (obj) && !WINDOW_LIVE_P  (XWINDOW  (obj))) ||
 	  (DEVICEP  (obj) && !DEVICE_LIVE_P  (XDEVICE  (obj))) ||
 	  (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
 	  (EVENTP   (obj) && !EVENT_LIVE_P   (XEVENT   (obj))) ||
 	  (EXTENTP  (obj) && !EXTENT_LIVE_P  (XEXTENT  (obj))));
 }
 #ifdef MEMORY_USAGE_STATS
 /* Attempt to determine the actual amount of space that is used for
 if (! purestats[iii]) continue;
 purestats[iii]->nobjects = 0;
 purestats[iii]->nbytes = 0;
 }
 purecopying_for_bytecode = 0;
-#endif
+#endif /* PURESTAT */
 last_lrecord_type_index_assigned = -1;
 for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
 {
 lrecord_implementations_table[iii] = 0;
 }
 symbols_initialized = 0;
 gc_generation_number[0] = 0;
 /* purify_flag 1 is correct even if CANNOT_DUMP.
 * loadup.el will set to nil at end. */
 purify_flag = 1;
 pureptr = 0;
 ERROR_ME_NOT.
 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
 ERROR_ME_WARN.
 really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
 3333632;
-#endif
+#endif /* ERROR_CHECK_TYPECHECK */
 }
 void
 reinit_alloc (void)
 {

Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 183:e121b013d1f0 r20-3b18