xemacs-beta: src/alloc.c comparison

comparison src/alloc.c @ 5133:444a448b2f53

Merge branch ben-lisp-object into default branch

author	Ben Wing <ben@xemacs.org>
date	Sun, 07 Mar 2010 06:47:37 -0600
parents	a9c41067dd88
children	f965e31a35f0

comparison

equal deleted inserted replaced

-:b2dcf6a6d8ab
+:444a448b2f53
 #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
+/* [[ The call to recompute_need_to_garbage_collect is moved to
-free_lrecord, since DECREMENT_CONS_COUNTER is extensively called
+free_normal_lisp_object, since DECREMENT_CONS_COUNTER is extensively called
 during sweep and recomputing need_to_garbage_collect all the time
-is not needed. */
+is not needed. ]] -- not accurate! */
 #define DECREMENT_CONS_COUNTER(size) do {	\
 consing_since_gc -= (size);			\
 total_consing -= (size);			\
 if (profiling_active)				\
 profile_record_unconsing (size);		\
 size += lrecord_stats[i].bytes_in_use;
 return size;
 }
 #endif /* NEW_GC && ALLOC_TYPE_STATS */
+#define assert_proper_sizing(size)			\
+type_checking_assert					\
+(implementation->static_size == 0 ?			\
+implementation->size_in_bytes_method != NULL :	\
+implementation->size_in_bytes_method == NULL &&	\
+implementation->static_size == size)
 #ifndef NEW_GC
 /* lcrecords are chained together through their "next" field.
 After doing the mark phase, GC will walk this linked list
 and free any lcrecord which hasn't been marked. */
 static struct old_lcrecord_header *all_lcrecords;
 #endif /* not NEW_GC */
 #ifdef NEW_GC
 /* The basic lrecord allocation functions. See lrecord.h for details. */
-void *
+static Lisp_Object
-alloc_lrecord (Bytecount size,
+alloc_sized_lrecord_1 (Bytecount size,
-	       const struct lrecord_implementation *implementation)
+		       const struct lrecord_implementation *implementation,
+		       int noseeum)
 {
 struct lrecord_header *lheader;
-type_checking_assert
+assert_proper_sizing (size);
-((implementation->static_size == 0 ?
-implementation->size_in_bytes_method != NULL :
-implementation->static_size == size));
 lheader = (struct lrecord_header *) mc_alloc (size);
 gc_checking_assert (LRECORD_FREE_P (lheader));
 set_lheader_implementation (lheader, implementation);
+lheader->uid = lrecord_uid_counter++;
 #ifdef ALLOC_TYPE_STATS
 inc_lrecord_stats (size, lheader);
 #endif /* ALLOC_TYPE_STATS */
 if (implementation->finalizer)
 add_finalizable_obj (wrap_pointer_1 (lheader));
-INCREMENT_CONS_COUNTER (size, implementation->name);
+if (noseeum)
-return lheader;
+NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name);
-}
+else
+INCREMENT_CONS_COUNTER (size, implementation->name);
+return wrap_pointer_1 (lheader);
-void *
+}
-noseeum_alloc_lrecord (Bytecount size,
-		       const struct lrecord_implementation *implementation)
+Lisp_Object
-{
+alloc_sized_lrecord (Bytecount size,
-struct lrecord_header *lheader;
-type_checking_assert
-((implementation->static_size == 0 ?
-implementation->size_in_bytes_method != NULL :
-implementation->static_size == size));
-lheader = (struct lrecord_header *) mc_alloc (size);
-gc_checking_assert (LRECORD_FREE_P (lheader));
-set_lheader_implementation (lheader, implementation);
-#ifdef ALLOC_TYPE_STATS
-inc_lrecord_stats (size, lheader);
-#endif /* ALLOC_TYPE_STATS */
-if (implementation->finalizer)
-add_finalizable_obj (wrap_pointer_1 (lheader));
-NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name);
-return lheader;
-}
-void *
-alloc_lrecord_array (Bytecount size, int elemcount,
 		     const struct lrecord_implementation *implementation)
+{
+return alloc_sized_lrecord_1 (size, implementation, 0);
+}
+Lisp_Object
+noseeum_alloc_sized_lrecord (Bytecount size,
+			     const struct lrecord_implementation *
+			     implementation)
+{
+return alloc_sized_lrecord_1 (size, implementation, 1);
+}
+Lisp_Object
+alloc_lrecord (const struct lrecord_implementation *implementation)
+{
+type_checking_assert (implementation->static_size > 0);
+return alloc_sized_lrecord (implementation->static_size, implementation);
+}
+Lisp_Object
+noseeum_alloc_lrecord (const struct lrecord_implementation *implementation)
+{
+type_checking_assert (implementation->static_size > 0);
+return noseeum_alloc_sized_lrecord (implementation->static_size, implementation);
+}
+Lisp_Object
+alloc_sized_lrecord_array (Bytecount size, int elemcount,
+			   const struct lrecord_implementation *implementation)
 {
 struct lrecord_header *lheader;
 Rawbyte *start, *stop;
-type_checking_assert
+assert_proper_sizing (size);
-((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);
+	 /* #### FIXME: why is this -1 present? */
+	 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++;
 inc_lrecord_stats (size, lh);
 #endif /* not ALLOC_TYPE_STATS */
 if (implementation->finalizer)
 	add_finalizable_obj (wrap_pointer_1 (lh));
 }
 INCREMENT_CONS_COUNTER (size * elemcount, implementation->name);
-return lheader;
+return wrap_pointer_1 (lheader);
 }
-void
+Lisp_Object
-free_lrecord (Lisp_Object UNUSED (lrecord))
+alloc_lrecord_array (int elemcount,
-{
+		     const struct lrecord_implementation *implementation)
-/* Manual frees are not allowed with asynchronous finalization */
+{
-return;
+type_checking_assert (implementation->static_size > 0);
-}
+return alloc_sized_lrecord_array (implementation->static_size, elemcount,
+				    implementation);
+}
 #else /* not NEW_GC */
 /* The most basic of the lcrecord allocation functions.  Not usually called
 directly.  Allocates an lrecord not managed by any lcrecord-list, of a
 specified size.  See lrecord.h. */
-void *
+Lisp_Object
-old_basic_alloc_lcrecord (Bytecount size,
+old_alloc_sized_lcrecord (Bytecount size,
 			  const struct lrecord_implementation *implementation)
 {
 struct old_lcrecord_header *lcheader;
+assert_proper_sizing (size);
 type_checking_assert
-((implementation->static_size == 0 ?
+(!implementation->frob_block_p
-implementation->size_in_bytes_method != NULL :
-implementation->static_size == size)
 &&
-(! implementation->basic_p)
+!(implementation->hash == NULL && implementation->equal != NULL));
-&&
-(! (implementation->hash == NULL && implementation->equal != NULL)));
 lcheader = (struct old_lcrecord_header *) allocate_lisp_storage (size);
 set_lheader_implementation (&lcheader->lheader, implementation);
 lcheader->next = all_lcrecords;
 #if 1                           /* mly prefers to see small ID numbers */
 lcheader->uid = (int) &lcheader;
 #endif
 lcheader->free = 0;
 all_lcrecords = lcheader;
 INCREMENT_CONS_COUNTER (size, implementation->name);
-return lcheader;
+return wrap_pointer_1 (lcheader);
+}
+Lisp_Object
+old_alloc_lcrecord (const struct lrecord_implementation *implementation)
+{
+type_checking_assert (implementation->static_size > 0);
+return old_alloc_sized_lcrecord (implementation->static_size,
+				   implementation);
 }
 #if 0 /* Presently unused */
 /* Very, very poor man's EGC?
 * This may be slow and thrash pages all over the place.
 	  else
 	    header = next;
 	}
 }
 if (lrecord->implementation->finalizer)
-lrecord->implementation->finalizer (lrecord, 0);
+lrecord->implementation->finalizer (wrap_pointer_1 (lrecord));
 xfree (lrecord);
 return;
 }
 #endif /* Unused */
 #endif /* not NEW_GC */
 #else /* not NEW_GC */
 struct old_lcrecord_header *header;
 for (header = all_lcrecords; header; header = header->next)
 {
-if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
+struct lrecord_header *objh = &header->lheader;
-	  !header->free)
+const struct lrecord_implementation *imp = LHEADER_IMPLEMENTATION (objh);
-	LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
+#if 0 /* possibly useful for debugging */
+if (!RECORD_DUMPABLE (objh) && !header->free)
+	{
+	  stderr_out ("Disksaving a non-dumpable object: ");
+	  debug_print (wrap_pointer_1 (header));
+	}
+#endif
+if (imp->disksaver && !header->free)
+	(imp->disksaver) (wrap_pointer_1 (header));
 }
 #endif /* not NEW_GC */
 }
 /* Bitwise copy all parts of a Lisp object other than the header */
 #ifdef NEW_GC
 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header),
 	  (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header),
 	  size - sizeof (struct lrecord_header));
 #else /* not NEW_GC */
-if (imp->basic_p)
+if (imp->frob_block_p)
 memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header),
 	    (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header),
 	    size - sizeof (struct lrecord_header));
 else
 memcpy ((char *) XRECORD_LHEADER (dst) +
 	    sizeof (struct old_lcrecord_header),
 	    (char *) XRECORD_LHEADER (src) +
 	    sizeof (struct old_lcrecord_header),
 	    size - sizeof (struct old_lcrecord_header));
 #endif /* not NEW_GC */
+}
+/* Zero out all parts of a Lisp object other than the header, for a
+variable-sized object.  The size needs to be given explicitly because
+at the time this is called, the contents of the object may not be
+defined, or may not be set up in such a way that we can reliably
+retrieve the size, since it may depend on settings inside of the object. */
+void
+zero_sized_lisp_object (Lisp_Object obj, Bytecount size)
+{
+#ifndef NEW_GC
+const struct lrecord_implementation *imp =
+XRECORD_LHEADER_IMPLEMENTATION (obj);
+#endif /* not NEW_GC */
+#ifdef NEW_GC
+memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0,
+	  size - sizeof (struct lrecord_header));
+#else /* not NEW_GC */
+if (imp->frob_block_p)
+memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0,
+	    size - sizeof (struct lrecord_header));
+else
+memset ((char *) XRECORD_LHEADER (obj) +
+	    sizeof (struct old_lcrecord_header), 0,
+	    size - sizeof (struct old_lcrecord_header));
+#endif /* not NEW_GC */
+}
+/* Zero out all parts of a Lisp object other than the header, for an object
+that isn't variable-size.  Objects that are variable-size need to use
+zero_sized_lisp_object().
+*/
+void
+zero_nonsized_lisp_object (Lisp_Object obj)
+{
+const struct lrecord_implementation *imp =
+XRECORD_LHEADER_IMPLEMENTATION (obj);
+assert (!imp->size_in_bytes_method);
+zero_sized_lisp_object (obj, lisp_object_size (obj));
+}
+#ifdef MEMORY_USAGE_STATS
+Bytecount
+lisp_object_storage_size (Lisp_Object obj, struct overhead_stats *ovstats)
+{
+#ifndef NEW_GC
+const struct lrecord_implementation *imp =
+XRECORD_LHEADER_IMPLEMENTATION (obj);
+#endif /* not NEW_GC */
+Bytecount size = lisp_object_size (obj);
+#ifdef NEW_GC
+return mc_alloced_storage_size (size, ovstats);
+#else
+if (imp->frob_block_p)
+{
+Bytecount overhead = fixed_type_block_overhead (size);
+if (ovstats)
+	{
+	  ovstats->was_requested += size;
+	  ovstats->malloc_overhead += overhead;
+	}
+return size + overhead;
+}
+else
+return malloced_storage_size (XPNTR (obj), size, ovstats);
+#endif
+}
+#endif /* MEMORY_USAGE_STATS */
+void
+free_normal_lisp_object (Lisp_Object obj)
+{
+#ifndef NEW_GC
+const struct lrecord_implementation *imp =
+XRECORD_LHEADER_IMPLEMENTATION (obj);
+#endif /* not NEW_GC */
+#ifdef NEW_GC
+/* Manual frees are not allowed with asynchronous finalization */
+return;
+#else
+assert (!imp->frob_block_p);
+assert (!imp->size_in_bytes_method);
+old_free_lcrecord (obj);
+#endif
 }
 /************************************************************************/
 /*			  Debugger support				*/
 } while (0)
 #endif /* NEW_GC */
 #ifdef NEW_GC
 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr)	\
-free_lrecord (lo)
+free_normal_lisp_object (lo)
 #else /* not NEW_GC */
 /* Like FREE_FIXED_TYPE() but used when we are explicitly
 freeing a structure through free_cons(), free_marker(), etc.
 rather than through the normal process of sweeping.
 We attempt to undo the changes made to the allocation counters
 #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr)
 #endif
 #endif /* (not) NEW_GC */
 #ifdef NEW_GC
-#define ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, lrec_ptr) \
+#define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr)\
 do {									\
-(var) = alloc_lrecord_type (lisp_type, lrec_ptr);			\
+(var) = (lisp_type *) XPNTR (ALLOC_NORMAL_LISP_OBJECT (type));               \
 } while (0)
-#define NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var,	\
+#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var,	\
 lrec_ptr)		\
 do {									\
-(var) = noseeum_alloc_lrecord_type (lisp_type, lrec_ptr);		\
+(var) = (lisp_type *) XPNTR (noseeum_alloc_lrecord (lrec_ptr));	\
 } while (0)
 #else /* not NEW_GC */
-#define ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, lrec_ptr) \
+#define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \
 do									\
 {									\
 ALLOCATE_FIXED_TYPE (type, lisp_type, var);				\
 set_lheader_implementation (&(var)->lheader, lrec_ptr);		\
 } while (0)
-#define NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var,	\
+#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var,	\
 lrec_ptr)		\
 do									\
 {									\
 NOSEEUM_ALLOCATE_FIXED_TYPE (type, lisp_type, var);			\
 set_lheader_implementation (&(var)->lheader, lrec_ptr);		\
 { XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) },
 { XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) },
 { XD_END }
 };
-DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
+DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("cons", cons,
-				     1, /*dumpable-flag*/
+					mark_cons, print_cons, 0, cons_equal,
-				     mark_cons, print_cons, 0,
+					/*
-				     cons_equal,
+					 * No `hash' method needed.
-				     /*
+					 * internal_hash knows how to
-				      * No `hash' method needed.
+					 * handle conses.
-				      * internal_hash knows how to
+					 */
-				      * handle conses.
+					0, cons_description, Lisp_Cons);
-				      */
-				     0,
-				     cons_description,
-				     Lisp_Cons);
 DEFUN ("cons", Fcons, 2, 2, 0, /*
 Create a new cons cell, give it CAR and CDR as components, and return it.
 A cons cell is a Lisp object (an area in memory) made up of two pointers
 {
 /* This cannot GC. */
 Lisp_Object val;
 Lisp_Cons *c;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (cons, Lisp_Cons, c, &lrecord_cons);
+ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons);
 val = wrap_cons (c);
 XSETCAR (val, car);
 XSETCDR (val, cdr);
 return val;
 }
 noseeum_cons (Lisp_Object car, Lisp_Object cdr)
 {
 Lisp_Object val;
 Lisp_Cons *c;
-NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL (cons, Lisp_Cons, c, &lrecord_cons);
+NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons);
 val = wrap_cons (c);
 XCAR (val) = car;
 XCDR (val) = cdr;
 return val;
 }
 Lisp_Object
 make_float (double float_value)
 {
 Lisp_Float *f;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (float, Lisp_Float, f, &lrecord_float);
+ALLOC_FROB_BLOCK_LISP_OBJECT (float, Lisp_Float, f, &lrecord_float);
 /* Avoid dump-time `uninitialized memory read' purify warnings. */
 if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
-zero_lrecord (f);
+zero_nonsized_lisp_object (wrap_float (f));
 float_data (f) = float_value;
 return wrap_float (f);
 }
 Lisp_Object
 make_bignum (long bignum_value)
 {
 Lisp_Bignum *b;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bignum, Lisp_Bignum, b, &lrecord_bignum);
+ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum);
 bignum_init (bignum_data (b));
 bignum_set_long (bignum_data (b), bignum_value);
 return wrap_bignum (b);
 }
 Lisp_Object
 make_bignum_bg (bignum bg)
 {
 Lisp_Bignum *b;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bignum, Lisp_Bignum, b, &lrecord_bignum);
+ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum);
 bignum_init (bignum_data (b));
 bignum_set (bignum_data (b), bg);
 return wrap_bignum (b);
 }
 #endif /* HAVE_BIGNUM */
 Lisp_Object
 make_ratio (long numerator, unsigned long denominator)
 {
 Lisp_Ratio *r;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio);
+ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio);
 ratio_init (ratio_data (r));
 ratio_set_long_ulong (ratio_data (r), numerator, denominator);
 ratio_canonicalize (ratio_data (r));
 return wrap_ratio (r);
 }
 Lisp_Object
 make_ratio_bg (bignum numerator, bignum denominator)
 {
 Lisp_Ratio *r;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio);
+ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio);
 ratio_init (ratio_data (r));
 ratio_set_bignum_bignum (ratio_data (r), numerator, denominator);
 ratio_canonicalize (ratio_data (r));
 return wrap_ratio (r);
 }
 Lisp_Object
 make_ratio_rt (ratio rat)
 {
 Lisp_Ratio *r;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio);
+ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio);
 ratio_init (ratio_data (r));
 ratio_set (ratio_data (r), rat);
 return wrap_ratio (r);
 }
 #endif /* HAVE_RATIO */
 Lisp_Object
 make_bigfloat (double float_value, unsigned long precision)
 {
 Lisp_Bigfloat *f;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
+ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
 if (precision == 0UL)
 bigfloat_init (bigfloat_data (f));
 else
 bigfloat_init_prec (bigfloat_data (f), precision);
 bigfloat_set_double (bigfloat_data (f), float_value);
 Lisp_Object
 make_bigfloat_bf (bigfloat float_value)
 {
 Lisp_Bigfloat *f;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
+ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat);
 bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value));
 bigfloat_set (bigfloat_data (f), float_value);
 return wrap_bigfloat (f);
 }
 #endif /* HAVE_BIGFLOAT */
 mark_object (ptr->contents[i]);
 return (len > 0) ? ptr->contents[len - 1] : Qnil;
 }
 static Bytecount
-size_vector (const void *lheader)
+size_vector (Lisp_Object obj)
 {
 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
-				       ((Lisp_Vector *) lheader)->size);
+				       XVECTOR (obj)->size);
 }
 static int
 vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase)
 {
 { XD_LONG,              offsetof (Lisp_Vector, size) },
 { XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
 { XD_END }
 };
-DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("vector", vector,
+DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("vector", vector,
-					1, /*dumpable-flag*/
+				     mark_vector, print_vector, 0,
-					mark_vector, print_vector, 0,
+				     vector_equal,
-					vector_equal,
+				     vector_hash,
-					vector_hash,
+				     vector_description,
-					vector_description,
+				     size_vector, Lisp_Vector);
-					size_vector, Lisp_Vector);
 /* #### should allocate `small' vectors from a frob-block */
 static Lisp_Vector *
 make_vector_internal (Elemcount sizei)
 {
 /* no `next' field; we use lcrecords */
 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
 						  contents, sizei);
-Lisp_Vector *p =
+Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, vector);
-(Lisp_Vector *) BASIC_ALLOC_LCRECORD (sizem, &lrecord_vector);
+Lisp_Vector *p = XVECTOR (obj);
 p->size = sizei;
 return p;
 }
 /* no `next' field; we use lcrecords */
 Elemcount num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
 Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector,
 						  unsigned long,
 						  bits, num_longs);
-Lisp_Bit_Vector *p = (Lisp_Bit_Vector *)
+Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, bit_vector);
-BASIC_ALLOC_LCRECORD (sizem, &lrecord_bit_vector);
+Lisp_Bit_Vector *p = XBIT_VECTOR (obj);
 bit_vector_length (p) = sizei;
 return p;
 }
 static Lisp_Object
 make_compiled_function (void)
 {
 Lisp_Compiled_Function *f;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (compiled_function, Lisp_Compiled_Function,
+ALLOC_FROB_BLOCK_LISP_OBJECT (compiled_function, Lisp_Compiled_Function,
 				    f, &lrecord_compiled_function);
 f->stack_depth = 0;
 f->specpdl_depth = 0;
 f->flags.documentationp = 0;
 {
 Lisp_Symbol *p;
 CHECK_STRING (name);
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (symbol, Lisp_Symbol, p, &lrecord_symbol);
+ALLOC_FROB_BLOCK_LISP_OBJECT (symbol, Lisp_Symbol, p, &lrecord_symbol);
 p->name     = name;
 p->plist    = Qnil;
 p->value    = Qunbound;
 p->function = Qunbound;
 symbol_next (p) = 0;
 struct extent *
 allocate_extent (void)
 {
 struct extent *e;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (extent, struct extent, e, &lrecord_extent);
+ALLOC_FROB_BLOCK_LISP_OBJECT (extent, struct extent, e, &lrecord_extent);
 extent_object (e) = Qnil;
 set_extent_start (e, -1);
 set_extent_end (e, -1);
 e->plist = Qnil;
 Lisp_Object
 allocate_event (void)
 {
 Lisp_Event *e;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (event, Lisp_Event, e, &lrecord_event);
+ALLOC_FROB_BLOCK_LISP_OBJECT (event, Lisp_Event, e, &lrecord_event);
 return wrap_event (e);
 }
 #ifdef EVENT_DATA_AS_OBJECTS
 Lisp_Object
 make_key_data (void)
 {
 Lisp_Key_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (key_data, Lisp_Key_Data, d,
+ALLOC_FROB_BLOCK_LISP_OBJECT (key_data, Lisp_Key_Data, d,
 				    &lrecord_key_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_key_data (d));
 d->keysym = Qnil;
 return wrap_key_data (d);
 }
 Lisp_Object
 make_button_data (void)
 {
 Lisp_Button_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (button_data, Lisp_Button_Data, d, &lrecord_button_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (button_data, Lisp_Button_Data, d, &lrecord_button_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_button_data (d));
 return wrap_button_data (d);
 }
 DECLARE_FIXED_TYPE_ALLOC (motion_data, Lisp_Motion_Data);
 #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_motion_data 1000
 Lisp_Object
 make_motion_data (void)
 {
 Lisp_Motion_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (motion_data, Lisp_Motion_Data, d, &lrecord_motion_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (motion_data, Lisp_Motion_Data, d, &lrecord_motion_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_motion_data (d));
 return wrap_motion_data (d);
 }
 DECLARE_FIXED_TYPE_ALLOC (process_data, Lisp_Process_Data);
 Lisp_Object
 make_process_data (void)
 {
 Lisp_Process_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (process_data, Lisp_Process_Data, d, &lrecord_process_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (process_data, Lisp_Process_Data, d, &lrecord_process_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_process_data (d));
 d->process = Qnil;
 return wrap_process_data (d);
 }
 Lisp_Object
 make_timeout_data (void)
 {
 Lisp_Timeout_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (timeout_data, Lisp_Timeout_Data, d, &lrecord_timeout_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (timeout_data, Lisp_Timeout_Data, d, &lrecord_timeout_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_timeout_data (d));
 d->function = Qnil;
 d->object = Qnil;
 return wrap_timeout_data (d);
 }
 Lisp_Object
 make_magic_data (void)
 {
 Lisp_Magic_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (magic_data, Lisp_Magic_Data, d, &lrecord_magic_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (magic_data, Lisp_Magic_Data, d, &lrecord_magic_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_magic_data (d));
 return wrap_magic_data (d);
 }
 DECLARE_FIXED_TYPE_ALLOC (magic_eval_data, Lisp_Magic_Eval_Data);
 Lisp_Object
 make_magic_eval_data (void)
 {
 Lisp_Magic_Eval_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (magic_eval_data, Lisp_Magic_Eval_Data, d, &lrecord_magic_eval_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (magic_eval_data, Lisp_Magic_Eval_Data, d, &lrecord_magic_eval_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_magic_eval_data (d));
 d->object = Qnil;
 return wrap_magic_eval_data (d);
 }
 Lisp_Object
 make_eval_data (void)
 {
 Lisp_Eval_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (eval_data, Lisp_Eval_Data, d, &lrecord_eval_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (eval_data, Lisp_Eval_Data, d, &lrecord_eval_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_eval_data (d));
 d->function = Qnil;
 d->object = Qnil;
 return wrap_eval_data (d);
 }
 Lisp_Object
 make_misc_user_data (void)
 {
 Lisp_Misc_User_Data *d;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (misc_user_data, Lisp_Misc_User_Data, d, &lrecord_misc_user_data);
+ALLOC_FROB_BLOCK_LISP_OBJECT (misc_user_data, Lisp_Misc_User_Data, d, &lrecord_misc_user_data);
-zero_lrecord (d);
+zero_nonsized_lisp_object (wrap_misc_user_data (d));
 d->function = Qnil;
 d->object = Qnil;
 return wrap_misc_user_data (d);
 }
 */
 ())
 {
 Lisp_Marker *p;
-ALLOCATE_FIXED_TYPE_AND_SET_IMPL (marker, Lisp_Marker, p, &lrecord_marker);
+ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, &lrecord_marker);
 p->buffer = 0;
 p->membpos = 0;
 marker_next (p) = 0;
 marker_prev (p) = 0;
 p->insertion_type = 0;
 Lisp_Object
 noseeum_make_marker (void)
 {
 Lisp_Marker *p;
-NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL (marker, Lisp_Marker, p,
+NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p,
 					    &lrecord_marker);
 p->buffer = 0;
 p->membpos = 0;
 marker_next (p) = 0;
 marker_prev (p) = 0;
 /*			  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 basic lrecord, and these are freelisted when they get garbage
+other frob-block lrecord, 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
 internal_hash() already knows how to hash strings and finalization
 is done with the ADDITIONAL_FREE_string macro, which is the
 standard way to do finalization when using
 SWEEP_FIXED_TYPE_BLOCK(). */
-DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
+DEFINE_DUMPABLE_FROB_BLOCK_GENERAL_LISP_OBJECT ("string", string,
-						1, /*dumpable-flag*/
 						mark_string, print_string,
 						0, string_equal, 0,
 						string_description,
 						string_getprop,
 						string_putprop,
 						string_remprop,
 						string_plist,
+						0 /* no disksaver */,
 						Lisp_String);
 #endif /* not NEW_GC */
 #ifdef NEW_GC
 #define 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 NEW_GC
-DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string,
+DEFINE_DUMPABLE_GENERAL_LISP_OBJECT ("string", string,
-					  1, /*dumpable-flag*/
+				     mark_string, print_string,
-					  mark_string, print_string,
+				     0,
-					  0,
+				     string_equal, 0,
-					  string_equal, 0,
+				     string_description,
-					  string_description,
+				     string_getprop,
-					  string_getprop,
+				     string_putprop,
-					  string_putprop,
+				     string_remprop,
-					  string_remprop,
+				     string_plist,
-					  string_plist,
+				     0 /* no disksaver */,
-					  Lisp_String);
+				     Lisp_String);
 static const struct memory_description string_direct_data_description[] = {
 { XD_BYTECOUNT,       offsetof (Lisp_String_Direct_Data, size) },
 { XD_END }
 };
 static Bytecount
-size_string_direct_data (const void *lheader)
+size_string_direct_data (Lisp_Object obj)
 {
-return STRING_FULLSIZE (((Lisp_String_Direct_Data *) lheader)->size);
+return STRING_FULLSIZE (XSTRING_DIRECT_DATA (obj)->size);
 }
-DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("string-direct-data",
+DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("string-direct-data",
-					string_direct_data,
+					      string_direct_data,
-					1, /*dumpable-flag*/
+					      0,
-					0, 0, 0, 0, 0,
+					      string_direct_data_description,
-					string_direct_data_description,
+					      size_string_direct_data,
-					size_string_direct_data,
+					      Lisp_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",
+DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("string-indirect-data",
-			       string_indirect_data,
+				      string_indirect_data,
-			       1, /*dumpable-flag*/
+				      0,
-			       0, 0, 0, 0, 0,
+				      string_indirect_data_description,
-			       string_indirect_data_description,
+				      Lisp_String_Indirect_Data);
-			       Lisp_String_Indirect_Data);
 #endif /* NEW_GC */
 #ifndef NEW_GC
 struct string_chars
 {
 Bytecount fullsize = STRING_FULLSIZE (length);
 assert (length >= 0 && fullsize > 0);
 #ifdef NEW_GC
-s = alloc_lrecord_type (Lisp_String, &lrecord_string);
+s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string));
 #else /* not NEW_GC */
 /* Allocate the string header */
 ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
 xzero (*s);
 set_lheader_implementation (&s->u.lheader, &lrecord_string);
 XSET_STRING_ASCII_BEGIN (wrap_string (s), 0);
 #ifdef NEW_GC
 set_lispstringp_direct (s);
 STRING_DATA_OBJECT (s) =
-wrap_string_direct_data (alloc_lrecord (fullsize,
+alloc_sized_lrecord (fullsize, &lrecord_string_direct_data);
-					    &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);
 #if defined (ERROR_CHECK_TEXT) && defined (MULE)
 bytecount_to_charcount (contents, length); /* Just for the assertions */
 #endif
 #ifdef NEW_GC
-s = alloc_lrecord_type (Lisp_String, &lrecord_string);
+s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string));
 mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get
 				 collected and static data is tried to
 				 be freed. */
 #else /* not NEW_GC */
 /* Allocate the string header */
 /* 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) =
+STRING_DATA_OBJECT (s) = ALLOC_NORMAL_LISP_OBJECT (string_indirect_data);
-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);
 /************************************************************************/
 /*                           lcrecord lists                             */
 /************************************************************************/
 /* Lcrecord lists are used to manage the allocation of particular
-sorts of lcrecords, to avoid calling BASIC_ALLOC_LCRECORD() (and thus
+sorts of lcrecords, to avoid calling ALLOC_NORMAL_LISP_OBJECT() (and thus
 malloc() and garbage-collection junk) as much as possible.
 It is similar to the Blocktype class.
 See detailed comment in lcrecord.h.
 */
 { XD_LISP_OBJECT, offsetof (struct free_lcrecord_header, chain), 0, { 0 },
 XD_FLAG_FREE_LISP_OBJECT },
 { XD_END }
 };
-DEFINE_LRECORD_IMPLEMENTATION ("free", free,
+DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("free", free, 0, free_description,
-			       0, /*dumpable-flag*/
+				    struct free_lcrecord_header);
-			       0, internal_object_printer,
-			       0, 0, 0, free_description,
-			       struct free_lcrecord_header);
 const struct memory_description lcrecord_list_description[] = {
 { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 },
 XD_FLAG_FREE_LISP_OBJECT },
 { XD_END }
 gc_checking_assert
 	(/* There should be no other pointers to the free list. */
 	 ! MARKED_RECORD_HEADER_P (lheader)
 	 &&
 	 /* Only lcrecords should be here. */
-	 ! list->implementation->basic_p
+	 ! list->implementation->frob_block_p
 	 &&
 	 /* Only free lcrecords should be here. */
 	 free_header->lcheader.free
 	 &&
 	 /* The type of the lcrecord must be right. */
 }
 return Qnil;
 }
-DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
+DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("lcrecord-list", lcrecord_list,
-			       0, /*dumpable-flag*/
+				    mark_lcrecord_list,
-			       mark_lcrecord_list, internal_object_printer,
+				    lcrecord_list_description,
-			       0, 0, 0, lcrecord_list_description,
+				    struct lcrecord_list);
-			       struct lcrecord_list);
 Lisp_Object
 make_lcrecord_list (Elemcount size,
 		    const struct lrecord_implementation *implementation)
 {
-/* Don't use old_alloc_lcrecord_type() avoid infinite recursion
+/* Don't use alloc_automanaged_lcrecord() avoid infinite recursion
-allocating this, */
+allocating this. */
 struct lcrecord_list *p = (struct lcrecord_list *)
-old_basic_alloc_lcrecord (sizeof (struct lcrecord_list),
+old_alloc_lcrecord (&lrecord_lcrecord_list);
-			      &lrecord_lcrecord_list);
 p->implementation = implementation;
 p->size = size;
 p->free = Qnil;
 return wrap_lcrecord_list (p);
 assert (! MARKED_RECORD_HEADER_P (lheader));
 /* Only free lcrecords should be here. */
 assert (free_header->lcheader.free);
 assert (lheader->type == lrecord_type_free);
 /* Only lcrecords should be here. */
-assert (! (list->implementation->basic_p));
+assert (! (list->implementation->frob_block_p));
 #if 0 /* Not used anymore, now that we set the type of the header to
 	 lrecord_type_free. */
 /* The type of the lcrecord must be right. */
 assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
 #endif /* 0 */
 list->free = free_header->chain;
 free_header->lcheader.free = 0;
 /* Put back the correct type, as we set it to lrecord_type_free. */
 lheader->type = list->implementation->lrecord_type_index;
-old_zero_sized_lcrecord (free_header, list->size);
+zero_sized_lisp_object (val, list->size);
 return val;
 }
 else
-return wrap_pointer_1 (old_basic_alloc_lcrecord (list->size,
+return wrap_pointer_1 (old_alloc_sized_lcrecord (list->size,
 						     list->implementation));
 }
 /* "Free" a Lisp object LCRECORD by placing it on its associated free list
 LCRECORD_LIST; next time alloc_managed_lcrecord() is called with the
 problems. */
 gc_checking_assert (!gc_in_progress);
 /* Make sure the size is correct.  This will catch, for example,
 putting a window configuration on the wrong free list. */
-gc_checking_assert (detagged_lisp_object_size (lheader) == list->size);
+gc_checking_assert (lisp_object_size (lcrecord) == list->size);
 /* Make sure the object isn't already freed. */
 gc_checking_assert (!free_header->lcheader.free);
 /* Freeing stuff in dumped memory is bad.  If you trip this, you
 may need to check for this before freeing. */
 gc_checking_assert (!OBJECT_DUMPED_P (lcrecord));
 if (implementation->finalizer)
-implementation->finalizer (lheader, 0);
+implementation->finalizer (lcrecord);
 /* Yes, there are two ways to indicate freeness -- the type is
 lrecord_type_free or the ->free flag is set.  We used to do only the
 latter; now we do the former as well for KKCC purposes.  Probably
 safer in any case, as we will lose quicker this way than keeping
 around an lrecord of apparently correct type but bogus junk in it. */
 list->free = lcrecord;
 }
 static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)];
-void *
+Lisp_Object
-alloc_automanaged_lcrecord (Bytecount size,
+alloc_automanaged_sized_lcrecord (Bytecount size,
-			    const struct lrecord_implementation *imp)
+				  const struct lrecord_implementation *imp)
 {
 if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero))
 all_lcrecord_lists[imp->lrecord_type_index] =
 make_lcrecord_list (size, imp);
-return XPNTR (alloc_managed_lcrecord
+return alloc_managed_lcrecord (all_lcrecord_lists[imp->lrecord_type_index]);
-		(all_lcrecord_lists[imp->lrecord_type_index]));
+}
+Lisp_Object
+alloc_automanaged_lcrecord (const struct lrecord_implementation *imp)
+{
+type_checking_assert (imp->static_size > 0);
+return alloc_automanaged_sized_lcrecord (imp->static_size, imp);
 }
 void
 old_free_lcrecord (Lisp_Object rec)
 {
 GC_CHECK_LHEADER_INVARIANTS (h);
 if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
 	{
 	  if (LHEADER_IMPLEMENTATION (h)->finalizer)
-	    LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
+	    LHEADER_IMPLEMENTATION (h)->finalizer (wrap_pointer_1 (h));
 	}
 }
 for (header = *prev; header; )
 {
 2 * sizeof (void *), is required as overhead and that
 blocks are allocated in the minimum required size except
 that some minimum block size is imposed (e.g. 16 bytes). */
 Bytecount
-malloced_storage_size (void *UNUSED (ptr), Bytecount claimed_size,
+malloced_storage_size (void * UNUSED (ptr), Bytecount claimed_size,
 		       struct overhead_stats *stats)
 {
 Bytecount orig_claimed_size = claimed_size;
 #ifndef SYSTEM_MALLOC
 int i;
 for (i = 0; i < countof (lrecord_implementations_table); i++)
 lrecord_implementations_table[i] = 0;
 }
-INIT_LRECORD_IMPLEMENTATION (cons);
+INIT_LISP_OBJECT (cons);
-INIT_LRECORD_IMPLEMENTATION (vector);
+INIT_LISP_OBJECT (vector);
-INIT_LRECORD_IMPLEMENTATION (string);
+INIT_LISP_OBJECT (string);
 #ifdef NEW_GC
-INIT_LRECORD_IMPLEMENTATION (string_indirect_data);
+INIT_LISP_OBJECT (string_indirect_data);
-INIT_LRECORD_IMPLEMENTATION (string_direct_data);
+INIT_LISP_OBJECT (string_direct_data);
 #endif /* NEW_GC */
 #ifndef NEW_GC
-INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
+INIT_LISP_OBJECT (lcrecord_list);
-INIT_LRECORD_IMPLEMENTATION (free);
+INIT_LISP_OBJECT (free);
 #endif /* not NEW_GC */
 staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
 Dynarr_resize (staticpros, 1410); /* merely a small optimization */
 dump_add_root_block_ptr (&staticpros, &staticpros_description);

Mercurial > hg > xemacs-beta

comparison src/alloc.c @ 5133:444a448b2f53