Added lcrecord lists for 19.14.
slb: Lots of work on the purification and dump time code.
Synched Doug Lea malloc support from Emacs 20.2.
- og: Killed the purespace. Portable dumper.
+ og: Killed the purespace. Portable dumper (moved to dumper.c)
*/
#include <config.h>
#include "redisplay.h"
#include "specifier.h"
#include "sysfile.h"
+#include "sysdep.h"
#include "window.h"
#include "console-stream.h"
#include <malloc.h>
#endif
-#ifdef HAVE_MMAP
-#include <unistd.h>
-#include <sys/mman.h>
-#endif
-
#ifdef PDUMP
-typedef struct
-{
- const struct lrecord_description *desc;
- int count;
-} pdump_reloc_table;
-
-static char *pdump_rt_list = 0;
+#include "dumper.h"
#endif
EXFUN (Fgarbage_collect, 0);
#endif
#ifdef DEBUG_XEMACS
-static int debug_allocation;
-static int debug_allocation_backtrace_length;
+static Fixnum debug_allocation;
+static Fixnum debug_allocation_backtrace_length;
#endif
/* Number of bytes of consing done since the last gc */
static const char gc_default_message[] = "Garbage collecting";
Lisp_Object Qgarbage_collecting;
-#ifndef VIRT_ADDR_VARIES
-extern
-#endif /* VIRT_ADDR_VARIES */
- EMACS_INT malloc_sbrk_used;
-
-#ifndef VIRT_ADDR_VARIES
-extern
-#endif /* VIRT_ADDR_VARIES */
- EMACS_INT malloc_sbrk_unused;
-
/* Non-zero means we're in the process of doing the dump */
int purify_flag;
{
struct lcrecord_header *lcheader;
-#ifdef ERROR_CHECK_TYPECHECK
- if (implementation->static_size == 0)
- assert (implementation->size_in_bytes_method);
- else
- assert (implementation->static_size == size);
-
- assert (! implementation->basic_p);
-
- if (implementation->hash == NULL)
- assert (implementation->equal == NULL);
-#endif
+ type_checking_assert
+ ((implementation->static_size == 0 ?
+ implementation->size_in_bytes_method != NULL :
+ implementation->static_size == size)
+ &&
+ (! implementation->basic_p)
+ &&
+ (! (implementation->hash == NULL && implementation->equal != NULL)));
lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
- set_lheader_implementation (&(lcheader->lheader), implementation);
+ set_lheader_implementation (&lcheader->lheader, implementation);
lcheader->next = all_lcrecords;
#if 1 /* mly prefers to see small ID numbers */
lcheader->uid = lrecord_uid_counter++;
for (header = all_lcrecords; header; header = header->next)
{
- if (LHEADER_IMPLEMENTATION(&header->lheader)->finalizer &&
+ if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
!header->free)
- ((LHEADER_IMPLEMENTATION(&header->lheader)->finalizer)
- (header, 1));
+ LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
}
}
-/* Semi-kludge -- lrecord_symbol_value_forward objects get stuck
- in const space and you get SEGV's if you attempt to mark them.
- This sits in lheader->implementation->marker. */
-
-Lisp_Object
-this_one_is_unmarkable (Lisp_Object obj)
-{
- abort ();
- return Qnil;
-}
-
\f
/************************************************************************/
/* Debugger support */
unsigned char dbg_USE_UNION_TYPE = 0;
#endif
-unsigned char Lisp_Type_Int = 100;
-unsigned char Lisp_Type_Cons = 101;
-unsigned char Lisp_Type_String = 102;
-unsigned char Lisp_Type_Vector = 103;
-unsigned char Lisp_Type_Symbol = 104;
-
-#ifndef MULE
-unsigned char lrecord_char_table_entry;
-unsigned char lrecord_charset;
-#ifndef FILE_CODING
-unsigned char lrecord_coding_system;
-#endif
-#endif
-
-#if !((defined HAVE_X_WINDOWS) && \
- (defined (HAVE_MENUBARS) || \
- defined (HAVE_SCROLLBARS) || \
- defined (HAVE_DIALOGS) || \
- defined (HAVE_TOOLBARS) || \
- defined (HAVE_WIDGETS)))
-unsigned char lrecord_popup_data;
-#endif
-
-#ifndef HAVE_TOOLBARS
-unsigned char lrecord_toolbar_button;
-#endif
-
-#ifndef TOOLTALK
-unsigned char lrecord_tooltalk_message;
-unsigned char lrecord_tooltalk_pattern;
-#endif
-
-#ifndef HAVE_DATABASE
-unsigned char lrecord_database;
-#endif
-
unsigned char dbg_valbits = VALBITS;
unsigned char dbg_gctypebits = GCTYPEBITS;
+/* On some systems, the above definitions will be optimized away by
+ the compiler or linker unless they are referenced in some function. */
+long dbg_inhibit_dbg_symbol_deletion (void);
+long
+dbg_inhibit_dbg_symbol_deletion (void)
+{
+ return
+ (dbg_valmask +
+ dbg_typemask +
+ dbg_USE_UNION_TYPE +
+ dbg_valbits +
+ dbg_gctypebits);
+}
+
/* Macros turned into functions for ease of debugging.
Debuggers don't know about macros! */
int dbg_eq (Lisp_Object obj1, Lisp_Object obj2);
currently executing functions; the gcpro list; etc.) and
recursively marking all objects that are accessible.
- At the beginning of the sweep stage, the conses in the cons
- blocks are in one of three states: in use and marked, in use
- but not marked, and not in use (already freed). Any conses
- that are marked have been marked in the mark stage just
- executed, because as part of the sweep stage we unmark any
- marked objects. The way we tell whether or not a cons cell
- is in use is through the FREE_STRUCT_P macro. This basically
- looks at the first 4 bytes (or however many bytes a pointer
- fits in) to see if all the bits in those bytes are 1. The
- resulting value (0xFFFFFFFF) is not a valid pointer and is
- not a valid Lisp_Object. All current fixed-size types have
- a pointer or Lisp_Object as their first element with the
- exception of strings; they have a size value, which can
- never be less than zero, and so 0xFFFFFFFF is invalid for
- strings as well. Now assuming that a cons cell is in use,
- the way we tell whether or not it is marked is to look at
- the mark bit of its car (each Lisp_Object has one bit
- reserved as a mark bit, in case it's needed). Note that
- different types of objects use different fields to indicate
- whether the object is marked, but the principle is the same.
-
- Conses on the free_cons_list are threaded through a pointer
- stored in the bytes directly after the bytes that are set
- to 0xFFFFFFFF (we cannot overwrite these because the cons
- is still in a cons_block and needs to remain marked as
- not in use for the next time that GC happens). This
- implies that all fixed-size types must be at least big
- enough to store two pointers, which is indeed the case
- for all current fixed-size types.
+ At the beginning of the sweep stage, the conses in the cons blocks
+ are in one of three states: in use and marked, in use but not
+ marked, and not in use (already freed). Any conses that are marked
+ have been marked in the mark stage just executed, because as part
+ of the sweep stage we unmark any marked objects. The way we tell
+ whether or not a cons cell is in use is through the LRECORD_FREE_P
+ macro. This uses a special lrecord type `lrecord_type_free',
+ which is never associated with any valid object.
+
+ Conses on the free_cons_list are threaded through a pointer stored
+ in the conses themselves. Because the cons is still in a
+ cons_block and needs to remain marked as not in use for the next
+ time that GC happens, we need room to store both the "free"
+ indicator and the chaining pointer. So this pointer is stored
+ after the lrecord header (actually where C places a pointer after
+ the lrecord header; they are not necessarily contiguous). This
+ implies that all fixed-size types must be big enough to contain at
+ least one pointer. This is true for all current fixed-size types,
+ with the possible exception of Lisp_Floats, for which we define the
+ meat of the struct using a union of a pointer and a double to
+ ensure adequate space for the free list chain pointer.
Some types of objects need additional "finalization" done
when an object is converted from in use to not in use;
WARNING: Things are in an extremely bizarre state when
the ADDITIONAL_FREE_type macros are called, so beware!
- When ERROR_CHECK_GC is defined, we do things differently
- so as to maximize our chances of catching places where
- there is insufficient GCPROing. The thing we want to
- avoid is having an object that we're using but didn't
- GCPRO get freed by GC and then reallocated while we're
- in the process of using it -- this will result in something
- seemingly unrelated getting trashed, and is extremely
- difficult to track down. If the object gets freed but
- not reallocated, we can usually catch this because we
- set all bytes of a freed object to 0xDEADBEEF. (The
- first four bytes, however, are 0xFFFFFFFF, and the next
- four are a pointer used to chain freed objects together;
- we play some tricks with this pointer to make it more
+ When ERROR_CHECK_GC is defined, we do things differently so as to
+ maximize our chances of catching places where there is insufficient
+ GCPROing. The thing we want to avoid is having an object that
+ we're using but didn't GCPRO get freed by GC and then reallocated
+ while we're in the process of using it -- this will result in
+ something seemingly unrelated getting trashed, and is extremely
+ difficult to track down. If the object gets freed but not
+ reallocated, we can usually catch this because we set most of the
+ bytes of a freed object to 0xDEADBEEF. (The lisp object type is set
+ to the invalid type `lrecord_type_free', however, and a pointer
+ used to chain freed objects together is stored after the lrecord
+ header; we play some tricks with this pointer to make it more
bogus, so crashes are more likely to occur right away.)
We want freed objects to stay free as long as possible,
This is called when a relocatable block is freed in ralloc.c. */
void refill_memory_reserve (void);
void
-refill_memory_reserve ()
+refill_memory_reserve (void)
{
if (breathing_space == 0)
breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD);
static struct type##_block *current_##type##_block; \
static int current_##type##_block_index; \
\
-static structtype *type##_free_list; \
-static structtype *type##_free_list_tail; \
+static Lisp_Free *type##_free_list; \
+static Lisp_Free *type##_free_list_tail; \
\
static void \
init_##type##_alloc (void) \
cell was not GC-protected and was getting collected before
free_cons() was called. */
-#define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
-do \
-{ \
- if (gc_count_num_##type##_freelist > \
- MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
- { \
- result = type##_free_list; \
- /* Before actually using the chain pointer, we complement all its \
- bits; see FREE_FIXED_TYPE(). */ \
- type##_free_list = \
- (structtype *) ~(unsigned long) \
- (* (structtype **) ((char *) result + sizeof (void *))); \
- gc_count_num_##type##_freelist--; \
- } \
- else \
- ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
- MARK_STRUCT_AS_NOT_FREE (result); \
+#define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
+ if (gc_count_num_##type##_freelist > \
+ MINIMUM_ALLOWED_FIXED_TYPE_CELLS_##type) \
+ { \
+ result = (structtype *) type##_free_list; \
+ /* Before actually using the chain pointer, \
+ we complement all its bits; see FREE_FIXED_TYPE(). */ \
+ type##_free_list = (Lisp_Free *) \
+ (~ (EMACS_UINT) (type##_free_list->chain)); \
+ gc_count_num_##type##_freelist--; \
+ } \
+ else \
+ ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
+ MARK_LRECORD_AS_NOT_FREE (result); \
} while (0)
#else /* !ERROR_CHECK_GC */
-#define ALLOCATE_FIXED_TYPE_1(type, structtype, result) \
-do \
-{ \
+#define ALLOCATE_FIXED_TYPE_1(type, structtype, result) do { \
if (type##_free_list) \
{ \
- result = type##_free_list; \
- type##_free_list = \
- * (structtype **) ((char *) result + sizeof (void *)); \
+ result = (structtype *) type##_free_list; \
+ type##_free_list = type##_free_list->chain; \
} \
else \
ALLOCATE_FIXED_TYPE_FROM_BLOCK (type, result); \
- MARK_STRUCT_AS_NOT_FREE (result); \
+ MARK_LRECORD_AS_NOT_FREE (result); \
} while (0)
#endif /* !ERROR_CHECK_GC */
+
#define ALLOCATE_FIXED_TYPE(type, structtype, result) \
do \
{ \
NOSEEUM_INCREMENT_CONS_COUNTER (sizeof (structtype), #type); \
} while (0)
-/* INVALID_POINTER_VALUE should be a value that is invalid as a pointer
- to a Lisp object and invalid as an actual Lisp_Object value. We have
- to make sure that this value cannot be an integer in Lisp_Object form.
- 0xFFFFFFFF could be so on a 64-bit system, so we extend it to 64 bits.
- On a 32-bit system, the type bits will be non-zero, making the value
- 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
-# define INVALID_POINTER_VALUE 0xFFFFFFFFFFFFFFFF
+
+/* Lisp_Free is the type to represent a free list member inside a frob
+ block of any lisp object type. */
+typedef struct Lisp_Free
+{
+ struct lrecord_header lheader;
+ struct Lisp_Free *chain;
+} Lisp_Free;
+
+#define LRECORD_FREE_P(ptr) \
+((ptr)->lheader.type == lrecord_type_free)
+
+#define MARK_LRECORD_AS_FREE(ptr) \
+((void) ((ptr)->lheader.type = lrecord_type_free))
+
+#ifdef ERROR_CHECK_GC
+#define MARK_LRECORD_AS_NOT_FREE(ptr) \
+((void) ((ptr)->lheader.type = lrecord_type_undefined))
#else
-You have some weird system and need to supply a reasonable value here.
+#define MARK_LRECORD_AS_NOT_FREE(ptr) DO_NOTHING
#endif
-#define FREE_STRUCT_P(ptr) \
- (* (void **) ptr == (void *) INVALID_POINTER_VALUE)
-#define MARK_STRUCT_AS_FREE(ptr) \
- (* (void **) ptr = (void *) INVALID_POINTER_VALUE)
-#define MARK_STRUCT_AS_NOT_FREE(ptr) \
- (* (void **) ptr = 0)
-
#ifdef ERROR_CHECK_GC
-#define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) \
-do { if (type##_free_list_tail) \
- { \
- /* When we store the chain pointer, we complement all \
- its bits; this should significantly increase its \
- bogosity in case someone tries to use the value, and \
- should make us dump faster if someone stores something \
- over the pointer because when it gets un-complemented in \
- ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
- extremely bogus. */ \
- * (structtype **) \
- ((char *) type##_free_list_tail + sizeof (void *)) = \
- (structtype *) ~(unsigned long) ptr; \
- } \
- else \
- type##_free_list = ptr; \
- type##_free_list_tail = ptr; \
- } while (0)
+#define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
+ if (type##_free_list_tail) \
+ { \
+ /* When we store the chain pointer, we complement all \
+ its bits; this should significantly increase its \
+ bogosity in case someone tries to use the value, and \
+ should make us crash faster if someone overwrites the \
+ pointer because when it gets un-complemented in \
+ ALLOCATED_FIXED_TYPE(), the resulting pointer will be \
+ extremely bogus. */ \
+ type##_free_list_tail->chain = \
+ (Lisp_Free *) ~ (EMACS_UINT) (ptr); \
+ } \
+ else \
+ type##_free_list = (Lisp_Free *) (ptr); \
+ type##_free_list_tail = (Lisp_Free *) (ptr); \
+} while (0)
#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)
+#define PUT_FIXED_TYPE_ON_FREE_LIST(type, structtype, ptr) do { \
+ ((Lisp_Free *) (ptr))->chain = type##_free_list; \
+ type##_free_list = (Lisp_Free *) (ptr); \
+} while (0) \
#endif /* !ERROR_CHECK_GC */
ADDITIONAL_FREE_##type (FFT_ptr); \
deadbeef_memory (FFT_ptr, sizeof (structtype)); \
PUT_FIXED_TYPE_ON_FREE_LIST (type, structtype, FFT_ptr); \
- MARK_STRUCT_AS_FREE (FFT_ptr); \
+ MARK_LRECORD_AS_FREE (FFT_ptr); \
} while (0)
/* Like FREE_FIXED_TYPE() but used when we are explicitly
Lisp_Cons *c;
ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
- set_lheader_implementation (&(c->lheader), &lrecord_cons);
+ set_lheader_implementation (&c->lheader, &lrecord_cons);
XSETCONS (val, c);
c->car = car;
c->cdr = cdr;
Lisp_Cons *c;
NOSEEUM_ALLOCATE_FIXED_TYPE (cons, Lisp_Cons, c);
- set_lheader_implementation (&(c->lheader), &lrecord_cons);
+ set_lheader_implementation (&c->lheader, &lrecord_cons);
XSETCONS (val, c);
XCAR (val) = car;
XCDR (val) = cdr;
}
DEFUN ("make-list", Fmake_list, 2, 2, 0, /*
-Return a new list of length LENGTH, with each element being INIT.
+Return a new list of length LENGTH, with each element being OBJECT.
*/
- (length, init))
+ (length, object))
{
CHECK_NATNUM (length);
size_t size = XINT (length);
while (size--)
- val = Fcons (init, val);
+ val = Fcons (object, val);
return val;
}
}
if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f))
xzero (*f);
- set_lheader_implementation (&(f->lheader), &lrecord_float);
+ set_lheader_implementation (&f->lheader, &lrecord_float);
float_data (f) = float_value;
XSETFLOAT (val, f);
return val;
static size_t
size_vector (const void *lheader)
{
- return offsetof (Lisp_Vector, contents[((Lisp_Vector *) lheader)->size]);
+ return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents,
+ ((Lisp_Vector *) lheader)->size);
}
static int
make_vector_internal (size_t sizei)
{
/* no vector_next */
- size_t sizem = offsetof (Lisp_Vector, contents[sizei]);
+ size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object,
+ contents, sizei);
Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
p->size = sizei;
}
Lisp_Object
-make_vector (size_t length, Lisp_Object init)
+make_vector (size_t length, Lisp_Object object)
{
Lisp_Vector *vecp = make_vector_internal (length);
Lisp_Object *p = vector_data (vecp);
while (length--)
- *p++ = init;
+ *p++ = object;
{
Lisp_Object vector;
}
DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
-Return a new vector of length LENGTH, with each element being INIT.
+Return a new vector of length LENGTH, with each element being OBJECT.
See also the function `vector'.
*/
- (length, init))
+ (length, object))
{
CONCHECK_NATNUM (length);
- return make_vector (XINT (length), init);
+ return make_vector (XINT (length), object);
}
DEFUN ("vector", Fvector, 0, MANY, 0, /*
make_bit_vector_internal (size_t sizei)
{
size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
- size_t sizem = offsetof (Lisp_Bit_Vector, bits[num_longs]);
+ size_t sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
+ bits, num_longs);
Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) allocate_lisp_storage (sizem);
- set_lheader_implementation (&(p->lheader), &lrecord_bit_vector);
+ set_lheader_implementation (&p->lheader, &lrecord_bit_vector);
INCREMENT_CONS_COUNTER (sizem, "bit-vector");
}
Lisp_Object
-make_bit_vector (size_t length, Lisp_Object init)
+make_bit_vector (size_t length, Lisp_Object bit)
{
Lisp_Bit_Vector *p = make_bit_vector_internal (length);
size_t num_longs = BIT_VECTOR_LONG_STORAGE (length);
- CHECK_BIT (init);
+ CHECK_BIT (bit);
- if (ZEROP (init))
+ if (ZEROP (bit))
memset (p->bits, 0, num_longs * sizeof (long));
else
{
Lisp_Object
make_bit_vector_from_byte_vector (unsigned char *bytevec, size_t length)
{
- int i;
+ size_t i;
Lisp_Bit_Vector *p = make_bit_vector_internal (length);
for (i = 0; i < length; i++)
}
DEFUN ("make-bit-vector", Fmake_bit_vector, 2, 2, 0, /*
-Return a new bit vector of length LENGTH. with each bit being INIT.
-Each element is set to INIT. See also the function `bit-vector'.
+Return a new bit vector of length LENGTH. with each bit set to BIT.
+BIT must be one of the integers 0 or 1. See also the function `bit-vector'.
*/
- (length, init))
+ (length, bit))
{
CONCHECK_NATNUM (length);
- return make_bit_vector (XINT (length), init);
+ return make_bit_vector (XINT (length), bit);
}
DEFUN ("bit-vector", Fbit_vector, 0, MANY, 0, /*
Return a newly created bit vector with specified arguments as elements.
Any number of arguments, even zero arguments, are allowed.
+Each argument must be one of the integers 0 or 1.
*/
(int nargs, Lisp_Object *args))
{
Lisp_Object fun;
ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
- set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
+ set_lheader_implementation (&f->lheader, &lrecord_compiled_function);
f->stack_depth = 0;
f->specpdl_depth = 0;
/* Check for valid formal parameter list now, to allow us to use
SPECBIND_FAST_UNSAFE() later in funcall_compiled_function(). */
{
- Lisp_Object symbol, tail;
EXTERNAL_LIST_LOOP_3 (symbol, arglist, tail)
{
CHECK_SYMBOL (symbol);
f->constants = constants;
CHECK_NATNUM (stack_depth);
- f->stack_depth = XINT (stack_depth);
+ f->stack_depth = (unsigned short) XINT (stack_depth);
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
if (!NILP (Vcurrent_compiled_function_annotation))
CHECK_STRING (name);
ALLOCATE_FIXED_TYPE (symbol, Lisp_Symbol, p);
- set_lheader_implementation (&(p->lheader), &lrecord_symbol);
+ set_lheader_implementation (&p->lheader, &lrecord_symbol);
p->name = XSTRING (name);
p->plist = Qnil;
p->value = Qunbound;
struct extent *e;
ALLOCATE_FIXED_TYPE (extent, struct extent, e);
- set_lheader_implementation (&(e->lheader), &lrecord_extent);
+ set_lheader_implementation (&e->lheader, &lrecord_extent);
extent_object (e) = Qnil;
set_extent_start (e, -1);
set_extent_end (e, -1);
Lisp_Event *e;
ALLOCATE_FIXED_TYPE (event, Lisp_Event, e);
- set_lheader_implementation (&(e->lheader), &lrecord_event);
+ set_lheader_implementation (&e->lheader, &lrecord_event);
XSETEVENT (val, e);
return val;
Lisp_Marker *p;
ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
- set_lheader_implementation (&(p->lheader), &lrecord_marker);
+ set_lheader_implementation (&p->lheader, &lrecord_marker);
p->buffer = 0;
p->memind = 0;
marker_next (p) = 0;
Lisp_Marker *p;
NOSEEUM_ALLOCATE_FIXED_TYPE (marker, Lisp_Marker, p);
- set_lheader_implementation (&(p->lheader), &lrecord_marker);
+ set_lheader_implementation (&p->lheader, &lrecord_marker);
p->buffer = 0;
p->memind = 0;
marker_next (p) = 0;
#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))
+
struct string_chars
{
Lisp_String *string;
/* Allocate the string header */
ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
- set_lheader_implementation (&(s->lheader), &lrecord_string);
+ set_lheader_implementation (&s->lheader, &lrecord_string);
set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize)
? xnew_array (Bufbyte, length + 1)
/* Sanity check to make sure we aren't hosed by strange
alignment/padding. */
assert (old_s_chars->string == s);
- MARK_STRUCT_AS_FREE (old_s_chars);
+ MARK_STRING_CHARS_AS_FREE (old_s_chars);
((struct unused_string_chars *) old_s_chars)->fullsize =
oldfullsize;
}
#endif /* MULE */
DEFUN ("make-string", Fmake_string, 2, 2, 0, /*
-Return a new string of length LENGTH, with each character being INIT.
-LENGTH must be an integer and INIT must be a character.
+Return a new string consisting of LENGTH copies of CHARACTER.
+LENGTH must be a non-negative integer.
*/
- (length, init))
+ (length, character))
{
CHECK_NATNUM (length);
- CHECK_CHAR_COERCE_INT (init);
+ CHECK_CHAR_COERCE_INT (character);
{
Bufbyte init_str[MAX_EMCHAR_LEN];
- int len = set_charptr_emchar (init_str, XCHAR (init));
+ int len = set_charptr_emchar (init_str, XCHAR (character));
Lisp_Object val = make_uninit_string (len * XINT (length));
if (len == 1)
/* Optimize the single-byte case */
- memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
+ memset (XSTRING_DATA (val), XCHAR (character), XSTRING_LENGTH (val));
else
{
size_t i;
Bufbyte *init_ptr = init_str;
switch (len)
{
+#ifdef UTF2000
+ case 6: *ptr++ = *init_ptr++;
+ case 5: *ptr++ = *init_ptr++;
+#endif
case 4: *ptr++ = *init_ptr++;
case 3: *ptr++ = *init_ptr++;
case 2: *ptr++ = *init_ptr++;
/* Allocate the string header */
ALLOCATE_FIXED_TYPE (string, Lisp_String, s);
- set_lheader_implementation (&(s->lheader), &lrecord_string);
+ set_lheader_implementation (&s->lheader, &lrecord_string);
SET_C_READONLY_RECORD_HEADER (&s->lheader);
s->plist = Qnil;
set_string_data (s, (Bufbyte *)contents);
struct free_lcrecord_header *free_header =
(struct free_lcrecord_header *) lheader;
-#ifdef ERROR_CHECK_GC
- const struct lrecord_implementation *implementation
- = LHEADER_IMPLEMENTATION(lheader);
-
- /* There should be no other pointers to the free list. */
- assert (!MARKED_RECORD_HEADER_P (lheader));
- /* Only lcrecords should be here. */
- assert (!implementation->basic_p);
- /* Only free lcrecords should be here. */
- assert (free_header->lcheader.free);
- /* 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 /* ERROR_CHECK_GC */
+ gc_checking_assert
+ (/* There should be no other pointers to the free list. */
+ ! MARKED_RECORD_HEADER_P (lheader)
+ &&
+ /* Only lcrecords should be here. */
+ ! LHEADER_IMPLEMENTATION (lheader)->basic_p
+ &&
+ /* Only free lcrecords should be here. */
+ free_header->lcheader.free
+ &&
+ /* The type of the lcrecord must be right. */
+ LHEADER_IMPLEMENTATION (lheader) == list->implementation
+ &&
+ /* So must the size. */
+ (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
+ LHEADER_IMPLEMENTATION (lheader)->static_size == list->size)
+ );
MARK_RECORD_HEADER (lheader);
chain = free_header->chain;
(struct free_lcrecord_header *) XPNTR (val);
#ifdef ERROR_CHECK_GC
- struct lrecord_header *lheader =
- (struct lrecord_header *) free_header;
- const struct lrecord_implementation *implementation
- = LHEADER_IMPLEMENTATION (lheader);
+ struct lrecord_header *lheader = &free_header->lcheader.lheader;
/* There should be no other pointers to the free list. */
- assert (!MARKED_RECORD_HEADER_P (lheader));
+ assert (! MARKED_RECORD_HEADER_P (lheader));
/* Only lcrecords should be here. */
- assert (!implementation->basic_p);
+ assert (! LHEADER_IMPLEMENTATION (lheader)->basic_p);
/* Only free lcrecords should be here. */
assert (free_header->lcheader.free);
/* The type of the lcrecord must be right. */
- assert (implementation == list->implementation);
+ assert (LHEADER_IMPLEMENTATION (lheader) == list->implementation);
/* So must the size. */
- assert (implementation->static_size == 0
- || implementation->static_size == list->size);
+ assert (LHEADER_IMPLEMENTATION (lheader)->static_size == 0 ||
+ LHEADER_IMPLEMENTATION (lheader)->static_size == list->size);
#endif /* ERROR_CHECK_GC */
+
list->free = free_header->chain;
free_header->lcheader.free = 0;
return val;
{
Lisp_Object val;
- XSETOBJ (val, Lisp_Type_Record,
- alloc_lcrecord (list->size, list->implementation));
+ XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
return val;
}
}
struct lcrecord_list *list = XLCRECORD_LIST (lcrecord_list);
struct free_lcrecord_header *free_header =
(struct free_lcrecord_header *) XPNTR (lcrecord);
- struct lrecord_header *lheader =
- (struct lrecord_header *) free_header;
+ struct lrecord_header *lheader = &free_header->lcheader.lheader;
const struct lrecord_implementation *implementation
= LHEADER_IMPLEMENTATION (lheader);
-#ifdef ERROR_CHECK_GC
/* Make sure the size is correct. This will catch, for example,
putting a window configuration on the wrong free list. */
- if (implementation->size_in_bytes_method)
- assert (implementation->size_in_bytes_method (lheader) == list->size);
- else
- assert (implementation->static_size == list->size);
-#endif /* ERROR_CHECK_GC */
+ gc_checking_assert ((implementation->size_in_bytes_method ?
+ implementation->size_in_bytes_method (lheader) :
+ implementation->static_size)
+ == list->size);
if (implementation->finalizer)
implementation->finalizer (lheader, 0);
Recursively copies contents of vectors and cons cells.
Does not copy symbols.
*/
- (obj))
+ (object))
{
- return obj;
+ return object;
}
-
\f
/************************************************************************/
/* Garbage Collection */
/************************************************************************/
-/* This will be used more extensively In The Future */
-static int last_lrecord_type_index_assigned;
-
-const struct lrecord_implementation *lrecord_implementations_table[128];
-#define max_lrecord_type (countof (lrecord_implementations_table) - 1)
+/* All the built-in lisp object types are enumerated in `enum lrecord_type'.
+ Additional ones may be defined by a module (none yet). We leave some
+ room in `lrecord_implementations_table' for such new lisp object types. */
+const struct lrecord_implementation *lrecord_implementations_table[(unsigned int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT];
+unsigned int lrecord_type_count = (unsigned int)lrecord_type_last_built_in_type;
+/* Object marker functions are in the lrecord_implementation structure.
+ But copying them to a parallel array is much more cache-friendly.
+ This hack speeds up (garbage-collect) by about 5%. */
+Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object);
struct gcpro *gcprolist;
-/* 415 used Mly 29-Jun-93 */
-/* 1327 used slb 28-Feb-98 */
-/* 1328 used og 03-Oct-99 (moving slowly, heh?) */
-#ifdef HAVE_SHLIB
-#define NSTATICS 4000
-#else
-#define NSTATICS 2000
-#endif
-/* Not "static" because of linker lossage on some systems */
-Lisp_Object *staticvec[NSTATICS]
- /* Force it into data space! */
- = {0};
-static int staticidx;
-
-/* Put an entry in staticvec, pointing at the variable whose address is given
- */
-void
-staticpro (Lisp_Object *varaddress)
-{
- if (staticidx >= countof (staticvec))
- /* #### This is now a dubious abort() since this routine may be called */
- /* by Lisp attempting to load a DLL. */
- abort ();
- staticvec[staticidx++] = varaddress;
-}
+/* We want the staticpros relocated, but not the pointers found therein.
+ Hence we use a trivial description, as for pointerless objects. */
+static const struct lrecord_description staticpro_description_1[] = {
+ { XD_END }
+};
-/* Not "static" because of linker lossage on some systems */
-Lisp_Object *staticvec_nodump[200]
- /* Force it into data space! */
- = {0};
-static int staticidx_nodump;
+static const struct struct_description staticpro_description = {
+ sizeof (Lisp_Object *),
+ staticpro_description_1
+};
-/* Put an entry in staticvec_nodump, pointing at the variable whose address is given
- */
-void
-staticpro_nodump (Lisp_Object *varaddress)
-{
- if (staticidx_nodump >= countof (staticvec_nodump))
- /* #### This is now a dubious abort() since this routine may be called */
- /* by Lisp attempting to load a DLL. */
- abort ();
- staticvec_nodump[staticidx_nodump++] = varaddress;
-}
+static const struct lrecord_description staticpros_description_1[] = {
+ XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
+ { XD_END }
+};
-/* Not "static" because of linker lossage on some systems */
-struct
-{
- void *data;
- const struct struct_description *desc;
-} dumpstructvec[200];
+static const struct struct_description staticpros_description = {
+ sizeof (Lisp_Object_ptr_dynarr),
+ staticpros_description_1
+};
-static int dumpstructidx;
+Lisp_Object_ptr_dynarr *staticpros;
-/* Put an entry in dumpstructvec, pointing at the variable whose address is given
- */
+/* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
+ garbage collection, and for dumping. */
void
-dumpstruct (void *varaddress, const struct struct_description *desc)
+staticpro (Lisp_Object *varaddress)
{
- if (dumpstructidx >= countof (dumpstructvec))
- abort ();
- dumpstructvec[dumpstructidx].data = varaddress;
- dumpstructvec[dumpstructidx].desc = desc;
- dumpstructidx++;
+ Dynarr_add (staticpros, varaddress);
+ dump_add_root_object (varaddress);
}
-/* Not "static" because of linker lossage on some systems */
-struct dumpopaque_info
-{
- void *data;
- size_t size;
-} dumpopaquevec[200];
-
-static int dumpopaqueidx;
-
-/* Put an entry in dumpopaquevec, pointing at the variable whose address is given
- */
-void
-dumpopaque (void *varaddress, size_t size)
-{
- if (dumpopaqueidx >= countof (dumpopaquevec))
- abort ();
- dumpopaquevec[dumpopaqueidx].data = varaddress;
- dumpopaquevec[dumpopaqueidx].size = size;
- dumpopaqueidx++;
-}
-Lisp_Object *pdump_wirevec[50];
-static int pdump_wireidx;
+Lisp_Object_ptr_dynarr *staticpros_nodump;
-/* Put an entry in pdump_wirevec, pointing at the variable whose address is given
- */
+/* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
+ garbage collection, but not for dumping. */
void
-pdump_wire (Lisp_Object *varaddress)
+staticpro_nodump (Lisp_Object *varaddress)
{
- if (pdump_wireidx >= countof (pdump_wirevec))
- abort ();
- pdump_wirevec[pdump_wireidx++] = varaddress;
+ Dynarr_add (staticpros_nodump, varaddress);
}
-
-Lisp_Object *pdump_wirevec_list[50];
-static int pdump_wireidx_list;
-
-/* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
- */
-void
-pdump_wire_list (Lisp_Object *varaddress)
-{
- if (pdump_wireidx_list >= countof (pdump_wirevec_list))
- abort ();
- pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
-}
+#ifdef ERROR_CHECK_GC
+#define GC_CHECK_LHEADER_INVARIANTS(lheader) do { \
+ struct lrecord_header * GCLI_lh = (lheader); \
+ assert (GCLI_lh != 0); \
+ assert (GCLI_lh->type < 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)
+#else
+#define GC_CHECK_LHEADER_INVARIANTS(lheader)
+#endif
\f
/* Mark reference to a Lisp_Object. If the object referred to has not been
{
tail_recurse:
-#ifdef ERROR_CHECK_GC
- assert (! (EQ (obj, Qnull_pointer)));
-#endif
/* Checks we used to perform */
/* if (EQ (obj, Qnull_pointer)) return; */
/* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
if (XTYPE (obj) == Lisp_Type_Record)
{
struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-#if defined (ERROR_CHECK_GC)
- assert (lheader->type <= last_lrecord_type_index_assigned);
-#endif
- if (C_READONLY_RECORD_HEADER_P (lheader))
- return;
- if (! MARKED_RECORD_HEADER_P (lheader) &&
- ! UNMARKABLE_RECORD_HEADER_P (lheader))
+ GC_CHECK_LHEADER_INVARIANTS (lheader);
+
+ gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p ||
+ ! ((struct lcrecord_header *) lheader)->free);
+
+ /* 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))
{
- const struct lrecord_implementation *implementation =
- LHEADER_IMPLEMENTATION (lheader);
MARK_RECORD_HEADER (lheader);
-#ifdef ERROR_CHECK_GC
- if (!implementation->basic_p)
- assert (! ((struct lcrecord_header *) lheader)->free);
-#endif
- if (implementation->marker)
+
+ if (RECORD_MARKER (lheader))
{
- obj = implementation->marker (obj);
+ obj = RECORD_MARKER (lheader) (obj);
if (!NILP (obj)) goto tail_recurse;
}
}
/* static int gc_count_total_records_used, gc_count_records_total_size; */
\f
-int
-lrecord_type_index (const struct lrecord_implementation *implementation)
-{
- int type_index = *(implementation->lrecord_type_index);
- /* Have to do this circuitous validation test because of problems
- dumping out initialized variables (ie can't set xxx_type_index to -1
- because that would make xxx_type_index read-only in a dumped emacs. */
- if (type_index < 0 || type_index > max_lrecord_type
- || lrecord_implementations_table[type_index] != implementation)
- {
- assert (last_lrecord_type_index_assigned < max_lrecord_type);
- type_index = ++last_lrecord_type_index_assigned;
- lrecord_implementations_table[type_index] = implementation;
- *(implementation->lrecord_type_index) = type_index;
- }
- return type_index;
-}
-
/* stats on lcrecords in use - kinda kludgy */
static struct
int instances_freed;
int bytes_freed;
int instances_on_free_list;
-} lcrecord_stats [countof (lrecord_implementations_table)];
+} lcrecord_stats [countof (lrecord_implementations_table)
+ + MODULE_DEFINABLE_TYPE_COUNT];
static void
tick_lcrecord_stats (const struct lrecord_header *h, int free_p)
{
- const struct lrecord_implementation *implementation =
- LHEADER_IMPLEMENTATION (h);
- int type_index = lrecord_type_index (implementation);
+ unsigned int type_index = h->type;
if (((struct lcrecord_header *) h)->free)
{
- assert (!free_p);
+ gc_checking_assert (!free_p);
lcrecord_stats[type_index].instances_on_free_list++;
}
else
{
- size_t sz = (implementation->size_in_bytes_method
- ? implementation->size_in_bytes_method (h)
- : implementation->static_size);
+ const struct lrecord_implementation *implementation =
+ LHEADER_IMPLEMENTATION (h);
+ size_t sz = (implementation->size_in_bytes_method ?
+ implementation->size_in_bytes_method (h) :
+ implementation->static_size);
if (free_p)
{
lcrecord_stats[type_index].instances_freed++;
for (header = *prev; header; header = header->next)
{
struct lrecord_header *h = &(header->lheader);
- if (!C_READONLY_RECORD_HEADER_P(h)
- && !MARKED_RECORD_HEADER_P (h)
- && ! (header->free))
+
+ GC_CHECK_LHEADER_INVARIANTS (h);
+
+ if (! MARKED_RECORD_HEADER_P (h) && ! header->free)
{
if (LHEADER_IMPLEMENTATION (h)->finalizer)
LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
for (header = *prev; header; )
{
struct lrecord_header *h = &(header->lheader);
- if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
+ if (MARKED_RECORD_HEADER_P (h))
{
- if (MARKED_RECORD_HEADER_P (h))
+ if (! C_READONLY_RECORD_HEADER_P (h))
UNMARK_RECORD_HEADER (h);
num_used++;
/* total_size += n->implementation->size_in_bytes (h);*/
{
Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
int len = v->size;
- if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector))
+ if (MARKED_RECORD_P (bit_vector))
{
- if (MARKED_RECORD_P (bit_vector))
+ if (! C_READONLY_RECORD_HEADER_P(&(v->lheader)))
UNMARK_RECORD_HEADER (&(v->lheader));
total_size += len;
total_storage +=
MALLOC_OVERHEAD +
- offsetof (Lisp_Bit_Vector, bits[BIT_VECTOR_LONG_STORAGE (len)]);
+ FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long,
+ bits, BIT_VECTOR_LONG_STORAGE (len));
num_used++;
/* #### May modify next on a C_READONLY bitvector */
prev = &(bit_vector_next (v));
#define SWEEP_FIXED_TYPE_BLOCK(typename, obj_type) \
do { \
struct typename##_block *SFTB_current; \
- struct typename##_block **SFTB_prev; \
int SFTB_limit; \
int num_free = 0, num_used = 0; \
\
- for (SFTB_prev = ¤t_##typename##_block, \
- SFTB_current = current_##typename##_block, \
+ for (SFTB_current = current_##typename##_block, \
SFTB_limit = current_##typename##_block_index; \
SFTB_current; \
) \
{ \
obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
\
- if (FREE_STRUCT_P (SFTB_victim)) \
+ if (LRECORD_FREE_P (SFTB_victim)) \
{ \
num_free++; \
} \
{ \
num_used++; \
} \
- else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
+ else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
{ \
num_free++; \
FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
UNMARK_##typename (SFTB_victim); \
} \
} \
- SFTB_prev = &(SFTB_current->prev); \
SFTB_current = SFTB_current->prev; \
SFTB_limit = countof (current_##typename##_block->block); \
} \
{ \
int SFTB_iii; \
int SFTB_empty = 1; \
- obj_type *SFTB_old_free_list = typename##_free_list; \
+ Lisp_Free *SFTB_old_free_list = typename##_free_list; \
\
for (SFTB_iii = 0; SFTB_iii < SFTB_limit; SFTB_iii++) \
{ \
obj_type *SFTB_victim = &(SFTB_current->block[SFTB_iii]); \
\
- if (FREE_STRUCT_P (SFTB_victim)) \
+ if (LRECORD_FREE_P (SFTB_victim)) \
{ \
num_free++; \
PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
SFTB_empty = 0; \
num_used++; \
} \
- else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
+ else if (! MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
{ \
num_free++; \
FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
void
free_marker (Lisp_Marker *ptr)
{
-#ifdef ERROR_CHECK_GC
/* Perhaps this will catch freeing an already-freed marker. */
- Lisp_Object temmy;
- XSETMARKER (temmy, ptr);
- assert (MARKERP (temmy));
-#endif /* ERROR_CHECK_GC */
+ gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
#ifndef ALLOC_NO_POOLS
FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
int size;
int fullsize;
- /* If the string_chars struct is marked as free (i.e. the STRING
- pointer is 0xFFFFFFFF) then this is an unused chunk of string
- storage. (See below.) */
+ /* If the string_chars struct is marked as free (i.e. the
+ STRING pointer is NULL) then this is an unused chunk of
+ string storage. (See below.) */
- if (FREE_STRUCT_P (s_chars))
+ if (STRING_CHARS_FREE_P (s_chars))
{
fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
pos += fullsize;
int size;
int fullsize;
- /* If the string_chars struct is marked as free (i.e. the STRING
- pointer is 0xFFFFFFFF) then this is an unused chunk of string
- storage. This happens under Mule when a string's size changes
- in such a way that its fullsize changes. (Strings can change
- size because a different-length character can be substituted
- for another character.) In this case, after the bogus string
- pointer is the "fullsize" of this entry, i.e. how many bytes
- to skip. */
+ /* If the string_chars struct is marked as free (i.e. the
+ STRING pointer is NULL) then this is an unused chunk of
+ string storage. This happens under Mule when a string's
+ size changes in such a way that its fullsize changes.
+ (Strings can change size because a different-length
+ character can be substituted for another character.)
+ In this case, after the bogus string pointer is the
+ "fullsize" of this entry, i.e. how many bytes to skip. */
- if (FREE_STRUCT_P (from_s_chars))
+ if (STRING_CHARS_FREE_P (from_s_chars))
{
fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
from_pos += fullsize;
}
string = from_s_chars->string;
- assert (!(FREE_STRUCT_P (string)));
+ assert (!(LRECORD_FREE_P (string)));
size = string_length (string);
fullsize = STRING_FULLSIZE (size);
- if (BIG_STRING_FULLSIZE_P (fullsize))
- abort ();
+ gc_checking_assert (! BIG_STRING_FULLSIZE_P (fullsize));
/* Just skip it if it isn't marked. */
if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
{
Charcount i;
Charcount s = string_char_length (p);
- putc ('\"', stderr);
+ stderr_out ("\"");
for (i = 0; i < s; i++)
{
Emchar ch = string_char (p, i);
UNMARK_RECORD_HEADER (&(p->lheader)); \
num_bytes += size; \
if (!BIG_STRING_SIZE_P (size)) \
- { num_small_bytes += size; \
- num_small_used++; \
+ { \
+ num_small_bytes += size; \
+ num_small_used++; \
} \
if (debug) \
debug_string_purity_print (p); \
int
marked_p (Lisp_Object obj)
{
-#ifdef ERROR_CHECK_GC
- assert (! (EQ (obj, Qnull_pointer)));
-#endif
/* Checks we used to perform. */
/* if (EQ (obj, Qnull_pointer)) return 1; */
/* if (!POINTER_TYPE_P (XGCTYPE (obj))) return 1; */
if (XTYPE (obj) == Lisp_Type_Record)
{
struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-#if defined (ERROR_CHECK_GC)
- assert (lheader->type <= last_lrecord_type_index_assigned);
-#endif
- return C_READONLY_RECORD_HEADER_P (lheader) || MARKED_RECORD_HEADER_P (lheader);
+
+ GC_CHECK_LHEADER_INVARIANTS (lheader);
+
+ return MARKED_RECORD_HEADER_P (lheader);
}
return 1;
}
sweep_events ();
#ifdef PDUMP
- /* Unmark all dumped objects */
- {
- int i;
- char *p = pdump_rt_list;
- if (p)
- for (;;)
- {
- pdump_reloc_table *rt = (pdump_reloc_table *)p;
- p += sizeof (pdump_reloc_table);
- if (rt->desc)
- {
- for (i=0; i<rt->count; i++)
- {
- UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p));
- p += sizeof (EMACS_INT);
- }
- } else
- break;
- }
- }
+ pdump_objects_unmark ();
#endif
}
\f
/* 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);
+ }
+}
+
\f
void
garbage_collect_1 (void)
/***** Now we actually start the garbage collection. */
gc_in_progress = 1;
+ inhibit_non_essential_printing_operations = 1;
gc_generation_number[0]++;
/* Mark all the special slots that serve as the roots of accessibility. */
{ /* staticpro() */
- int i;
- for (i = 0; i < staticidx; i++)
- mark_object (*(staticvec[i]));
- for (i = 0; i < staticidx_nodump; i++)
- mark_object (*(staticvec_nodump[i]));
+ Lisp_Object **p = Dynarr_begin (staticpros);
+ size_t count;
+ for (count = Dynarr_length (staticpros); count; count--)
+ mark_object (**p++);
+ }
+
+ { /* staticpro_nodump() */
+ Lisp_Object **p = Dynarr_begin (staticpros_nodump);
+ size_t count;
+ for (count = Dynarr_length (staticpros_nodump); count; count--)
+ mark_object (**p++);
}
{ /* GCPRO() */
int i;
mark_object (*backlist->function);
- if (nargs == UNEVALLED || nargs == MANY)
+ if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
mark_object (backlist->args[0]);
else
for (i = 0; i < nargs; i++)
gc_cons_threshold = 10000;
#endif
+ inhibit_non_essential_printing_operations = 0;
gc_in_progress = 0;
+ run_post_gc_actions ();
+
/******* End of garbage collection ********/
run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
())
{
Lisp_Object pl = Qnil;
- int i;
+ unsigned int i;
int gc_count_vector_total_size = 0;
garbage_collect_1 ();
- for (i = 0; i <= last_lrecord_type_index_assigned; i++)
+ for (i = 0; i < lrecord_type_count; i++)
{
if (lcrecord_stats[i].bytes_in_use != 0
|| lcrecord_stats[i].bytes_freed != 0
const char *name = lrecord_implementations_table[i]->name;
int len = strlen (name);
/* save this for the FSFmacs-compatible part of the summary */
- if (i == *lrecord_vector.lrecord_type_index)
+ if (i == lrecord_type_vector)
gc_count_vector_total_size =
lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
}
#if 0
-DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
+DEFUN ("memory-limit", Fmemory_limit, 0, 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.
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
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 */
+#if 1 /* Moved to emacs.c */
+ mallopt (M_MMAP_MAX, 0); /* max. number of mmap'ed areas */
#endif
#endif
init_string_alloc ();
ignore_malloc_warnings = 0;
- staticidx_nodump = 0;
- dumpstructidx = 0;
- pdump_wireidx = 0;
+ if (staticpros_nodump)
+ Dynarr_free (staticpros_nodump);
+ staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
+ Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
consing_since_gc = 0;
#if 1
#else
gc_cons_threshold = 15000; /* debugging */
#endif
-#ifdef VIRT_ADDR_VARIES
- malloc_sbrk_unused = 1<<22; /* A large number */
- malloc_sbrk_used = 100000; /* as reasonable as any number */
-#endif /* VIRT_ADDR_VARIES */
lrecord_uid_counter = 259;
debug_string_purity = 0;
gcprolist = 0;
void
init_alloc_once_early (void)
{
- int iii;
-
reinit_alloc_once_early ();
- last_lrecord_type_index_assigned = -1;
- for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
- {
- lrecord_implementations_table[iii] = 0;
- }
+ {
+ int i;
+ for (i = 0; i < countof (lrecord_implementations_table); i++)
+ lrecord_implementations_table[i] = 0;
+ }
- /*
- * All the staticly
- * defined subr lrecords were initialized with lheader->type == 0.
- * See subr_lheader_initializer in lisp.h. Force type index 0 to be
- * assigned to lrecord_subr so that those predefined indexes match
- * reality.
- */
- lrecord_type_index (&lrecord_subr);
- assert (*(lrecord_subr.lrecord_type_index) == 0);
- /*
- * The same is true for symbol_value_forward objects, except the
- * type is 1.
- */
- lrecord_type_index (&lrecord_symbol_value_forward);
- assert (*(lrecord_symbol_value_forward.lrecord_type_index) == 1);
+ INIT_LRECORD_IMPLEMENTATION (cons);
+ INIT_LRECORD_IMPLEMENTATION (vector);
+ INIT_LRECORD_IMPLEMENTATION (string);
+ INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
- staticidx = 0;
+ staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
+ Dynarr_resize (staticpros, 1410); /* merely a small optimization */
+ dump_add_root_struct_ptr (&staticpros, &staticpros_description);
}
-int pure_bytes_used = 0;
-
void
reinit_alloc (void)
{
void
syms_of_alloc (void)
{
- defsymbol (&Qpre_gc_hook, "pre-gc-hook");
- defsymbol (&Qpost_gc_hook, "post-gc-hook");
- defsymbol (&Qgarbage_collecting, "garbage-collecting");
+ DEFSYMBOL (Qpre_gc_hook);
+ DEFSYMBOL (Qpost_gc_hook);
+ DEFSYMBOL (Qgarbage_collecting);
DEFSUBR (Fcons);
DEFSUBR (Flist);
See also `consing-since-gc'.
*/ );
- DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
-Number of bytes of sharable Lisp data allocated so far.
-*/ );
-
-#if 0
- DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
-Number of bytes of unshared memory allocated in this session.
-*/ );
-
- DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
-Number of bytes of unshared memory remaining available in this session.
-*/ );
-#endif
-
#ifdef DEBUG_XEMACS
DEFVAR_INT ("debug-allocation", &debug_allocation /*
If non-zero, print out information to stderr about all objects allocated.
{
Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
}
-
-
-#ifdef PDUMP
-
-/* The structure of the file
- *
- * 0 - header
- * 256 - dumped objects
- * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec
- * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro
- * - nb_structdmp*pair(void *, adr) for pointers to structures
- * - lrecord_implementations_table[]
- * - relocation table
- * - wired variable address/value couples with the count preceding the list
- */
-typedef struct
-{
- char signature[8];
- EMACS_UINT stab_offset;
- EMACS_UINT reloc_address;
- int nb_staticpro;
- int nb_structdmp;
- int nb_opaquedmp;
- int last_type;
-} dump_header;
-
-char *pdump_start, *pdump_end;
-
-static const unsigned char align_table[256] =
-{
- 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0,
- 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
-};
-
-typedef struct pdump_entry_list_elmt
-{
- struct pdump_entry_list_elmt *next;
- const void *obj;
- size_t size;
- int count;
- int is_lrecord;
- EMACS_INT save_offset;
-} pdump_entry_list_elmt;
-
-typedef struct
-{
- pdump_entry_list_elmt *first;
- int align;
- int count;
-} pdump_entry_list;
-
-typedef struct pdump_struct_list_elmt
-{
- pdump_entry_list list;
- const struct struct_description *sdesc;
-} pdump_struct_list_elmt;
-
-typedef struct
-{
- pdump_struct_list_elmt *list;
- int count;
- int size;
-} pdump_struct_list;
-
-static pdump_entry_list pdump_object_table[256];
-static pdump_entry_list pdump_opaque_data_list;
-static pdump_struct_list pdump_struct_table;
-static pdump_entry_list_elmt *pdump_qnil;
-
-static int pdump_alert_undump_object[256];
-
-static unsigned long cur_offset;
-static size_t max_size;
-static int pdump_fd;
-static void *pdump_buf;
-
-#define PDUMP_HASHSIZE 200001
-
-static pdump_entry_list_elmt **pdump_hash;
-
-/* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */
-static int
-pdump_make_hash (const void *obj)
-{
- return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
-}
-
-static pdump_entry_list_elmt *
-pdump_get_entry (const void *obj)
-{
- int pos = pdump_make_hash (obj);
- pdump_entry_list_elmt *e;
-
- assert (obj != 0);
-
- while ((e = pdump_hash[pos]) != 0)
- {
- if (e->obj == obj)
- return e;
-
- pos++;
- if (pos == PDUMP_HASHSIZE)
- pos = 0;
- }
- return 0;
-}
-
-static void
-pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
-{
- pdump_entry_list_elmt *e;
- int align;
- int pos = pdump_make_hash (obj);
-
- while ((e = pdump_hash[pos]) != 0)
- {
- if (e->obj == obj)
- return;
-
- pos++;
- if (pos == PDUMP_HASHSIZE)
- pos = 0;
- }
-
- e = xnew (pdump_entry_list_elmt);
-
- e->next = list->first;
- e->obj = obj;
- e->size = size;
- e->count = count;
- e->is_lrecord = is_lrecord;
- list->first = e;
-
- list->count += count;
- pdump_hash[pos] = e;
-
- align = align_table[size & 255];
- if (align < 2 && is_lrecord)
- align = 2;
-
- if (align < list->align)
- list->align = align;
-}
-
-static pdump_entry_list *
-pdump_get_entry_list (const struct struct_description *sdesc)
-{
- int i;
- for (i=0; i<pdump_struct_table.count; i++)
- if (pdump_struct_table.list[i].sdesc == sdesc)
- return &pdump_struct_table.list[i].list;
-
- if (pdump_struct_table.size <= pdump_struct_table.count)
- {
- if (pdump_struct_table.size == -1)
- pdump_struct_table.size = 10;
- else
- pdump_struct_table.size = pdump_struct_table.size * 2;
- pdump_struct_table.list = (pdump_struct_list_elmt *)
- xrealloc (pdump_struct_table.list,
- pdump_struct_table.size * sizeof (pdump_struct_list_elmt));
- }
- pdump_struct_table.list[pdump_struct_table.count].list.first = 0;
- pdump_struct_table.list[pdump_struct_table.count].list.align = 8;
- pdump_struct_table.list[pdump_struct_table.count].list.count = 0;
- pdump_struct_table.list[pdump_struct_table.count].sdesc = sdesc;
-
- return &pdump_struct_table.list[pdump_struct_table.count++].list;
-}
-
-static struct
-{
- struct lrecord_header *obj;
- int position;
- int offset;
-} backtrace[65536];
-
-static int depth;
-
-static void pdump_backtrace (void)
-{
- int i;
- fprintf (stderr, "pdump backtrace :\n");
- for (i=0;i<depth;i++)
- {
- if (!backtrace[i].obj)
- fprintf (stderr, " - ind. (%d, %d)\n", backtrace[i].position, backtrace[i].offset);
- else
- {
- fprintf (stderr, " - %s (%d, %d)\n",
- LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
- backtrace[i].position,
- backtrace[i].offset);
- }
- }
-}
-
-static void pdump_register_object (Lisp_Object obj);
-static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count);
-
-static EMACS_INT
-pdump_get_indirect_count (EMACS_INT code, const struct lrecord_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) + idesc[line].offset;
- switch (idesc[line].type)
- {
- case XD_SIZE_T:
- count = *(size_t *)irdata;
- break;
- case XD_INT:
- count = *(int *)irdata;
- break;
- case XD_LONG:
- count = *(long *)irdata;
- break;
- case XD_BYTECOUNT:
- count = *(Bytecount *)irdata;
- break;
- default:
- fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code);
- pdump_backtrace ();
- abort ();
- }
- count += delta;
- return count;
-}
-
-static void
-pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
-{
- int pos;
-
- restart:
- for (pos = 0; desc[pos].type != XD_END; pos++)
- {
- const void *rdata = (const char *)data + desc[pos].offset;
-
- backtrace[me].position = pos;
- backtrace[me].offset = desc[pos].offset;
-
- switch (desc[pos].type)
- {
- case XD_SPECIFIER_END:
- pos = 0;
- desc = ((const Lisp_Specifier *)data)->methods->extra_description;
- goto restart;
- case XD_SIZE_T:
- case XD_INT:
- case XD_LONG:
- case XD_BYTECOUNT:
- case XD_LO_RESET_NIL:
- case XD_INT_RESET:
- case XD_LO_LINK:
- break;
- case XD_OPAQUE_DATA_PTR:
- {
- EMACS_INT count = desc[pos].data1;
- if (XD_IS_INDIRECT (count))
- count = pdump_get_indirect_count (count, desc, data);
-
- pdump_add_entry (&pdump_opaque_data_list,
- *(void **)rdata,
- count,
- 1,
- 0);
- break;
- }
- case XD_C_STRING:
- {
- const char *str = *(const char **)rdata;
- if (str)
- pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
- break;
- }
- case XD_DOC_STRING:
- {
- const char *str = *(const char **)rdata;
- if ((EMACS_INT)str > 0)
- pdump_add_entry (&pdump_opaque_data_list, str, strlen (str)+1, 1, 0);
- break;
- }
- case XD_LISP_OBJECT:
- {
- const Lisp_Object *pobj = (const Lisp_Object *)rdata;
-
- assert (desc[pos].data1 == 0);
-
- backtrace[me].offset = (const char *)pobj - (const char *)data;
- pdump_register_object (*pobj);
- break;
- }
- case XD_LISP_OBJECT_ARRAY:
- {
- int i;
- EMACS_INT count = desc[pos].data1;
- if (XD_IS_INDIRECT (count))
- count = pdump_get_indirect_count (count, desc, data);
-
- for (i = 0; i < count; i++)
- {
- const Lisp_Object *pobj = ((const Lisp_Object *)rdata) + i;
- Lisp_Object dobj = *pobj;
-
- backtrace[me].offset = (const char *)pobj - (const char *)data;
- pdump_register_object (dobj);
- }
- break;
- }
- case XD_STRUCT_PTR:
- {
- EMACS_INT count = desc[pos].data1;
- const struct struct_description *sdesc = desc[pos].data2;
- const char *dobj = *(const char **)rdata;
- if (dobj)
- {
- if (XD_IS_INDIRECT (count))
- count = pdump_get_indirect_count (count, desc, data);
-
- pdump_register_struct (dobj, sdesc, count);
- }
- break;
- }
- default:
- fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
- pdump_backtrace ();
- abort ();
- };
- }
-}
-
-static void
-pdump_register_object (Lisp_Object obj)
-{
- struct lrecord_header *objh;
-
- if (!POINTER_TYPE_P (XTYPE (obj)))
- return;
-
- objh = XRECORD_LHEADER (obj);
- if (!objh)
- return;
-
- if (pdump_get_entry (objh))
- return;
-
- if (LHEADER_IMPLEMENTATION (objh)->description)
- {
- int me = depth++;
- if (me>65536)
- {
- fprintf (stderr, "Backtrace overflow, loop ?\n");
- abort ();
- }
- backtrace[me].obj = objh;
- backtrace[me].position = 0;
- backtrace[me].offset = 0;
-
- pdump_add_entry (pdump_object_table + objh->type,
- objh,
- LHEADER_IMPLEMENTATION (objh)->static_size ?
- LHEADER_IMPLEMENTATION (objh)->static_size :
- LHEADER_IMPLEMENTATION (objh)->size_in_bytes_method (objh),
- 1,
- 1);
- pdump_register_sub (objh,
- LHEADER_IMPLEMENTATION (objh)->description,
- me);
- --depth;
- }
- else
- {
- pdump_alert_undump_object[objh->type]++;
- fprintf (stderr, "Undumpable object type : %s\n", LHEADER_IMPLEMENTATION (objh)->name);
- pdump_backtrace ();
- }
-}
-
-static void
-pdump_register_struct (const void *data, const struct struct_description *sdesc, int count)
-{
- if (data && !pdump_get_entry (data))
- {
- int me = depth++;
- int i;
- if (me>65536)
- {
- fprintf (stderr, "Backtrace overflow, loop ?\n");
- abort ();
- }
- backtrace[me].obj = 0;
- backtrace[me].position = 0;
- backtrace[me].offset = 0;
-
- pdump_add_entry (pdump_get_entry_list (sdesc),
- data,
- sdesc->size,
- count,
- 0);
- for (i=0; i<count; i++)
- {
- pdump_register_sub (((char *)data) + sdesc->size*i,
- sdesc->description,
- me);
- }
- --depth;
- }
-}
-
-static void
-pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
-{
- size_t size = elmt->size;
- int count = elmt->count;
- if (desc)
- {
- int pos, i;
- memcpy (pdump_buf, elmt->obj, size*count);
-
- for (i=0; i<count; i++)
- {
- char *cur = ((char *)pdump_buf) + i*size;
- restart:
- for (pos = 0; desc[pos].type != XD_END; pos++)
- {
- void *rdata = cur + desc[pos].offset;
- switch (desc[pos].type)
- {
- case XD_SPECIFIER_END:
- desc = ((const Lisp_Specifier *)(elmt->obj))->methods->extra_description;
- goto restart;
- case XD_SIZE_T:
- case XD_INT:
- case XD_LONG:
- case XD_BYTECOUNT:
- break;
- case XD_LO_RESET_NIL:
- {
- EMACS_INT count = desc[pos].data1;
- int i;
- if (XD_IS_INDIRECT (count))
- count = pdump_get_indirect_count (count, desc, elmt->obj);
- for (i=0; i<count; i++)
- ((EMACS_INT *)rdata)[i] = pdump_qnil->save_offset;
- break;
- }
- case XD_INT_RESET:
- {
- EMACS_INT val = desc[pos].data1;
- if (XD_IS_INDIRECT (val))
- val = pdump_get_indirect_count (val, desc, elmt->obj);
- *(int *)rdata = val;
- break;
- }
- case XD_OPAQUE_DATA_PTR:
- case XD_C_STRING:
- case XD_STRUCT_PTR:
- {
- void *ptr = *(void **)rdata;
- if (ptr)
- *(EMACS_INT *)rdata = pdump_get_entry (ptr)->save_offset;
- break;
- }
- case XD_LO_LINK:
- {
- Lisp_Object obj = *(Lisp_Object *)rdata;
- pdump_entry_list_elmt *elmt1;
- for (;;)
- {
- elmt1 = pdump_get_entry (XRECORD_LHEADER (obj));
- if (elmt1)
- break;
- obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
- }
- *(EMACS_INT *)rdata = elmt1->save_offset;
- break;
- }
- case XD_LISP_OBJECT:
- {
- Lisp_Object *pobj = (Lisp_Object *) rdata;
-
- assert (desc[pos].data1 == 0);
-
- if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
- *(EMACS_INT *)pobj =
- pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
- break;
- }
- case XD_LISP_OBJECT_ARRAY:
- {
- EMACS_INT count = desc[pos].data1;
- int i;
- if (XD_IS_INDIRECT (count))
- count = pdump_get_indirect_count (count, desc, elmt->obj);
-
- for (i=0; i<count; i++)
- {
- Lisp_Object *pobj = ((Lisp_Object *)rdata) + i;
- if (POINTER_TYPE_P (XTYPE (*pobj)) && XRECORD_LHEADER (*pobj))
- *(EMACS_INT *)pobj =
- pdump_get_entry (XRECORD_LHEADER (*pobj))->save_offset;
- }
- break;
- }
- case XD_DOC_STRING:
- {
- EMACS_INT str = *(EMACS_INT *)rdata;
- if (str > 0)
- *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset;
- break;
- }
- default:
- fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
- abort ();
- };
- }
- }
- }
- write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count);
- if (elmt->is_lrecord && ((size*count) & 3))
- write (pdump_fd, "\0\0\0", 4-((size*count) & 3));
-}
-
-static void
-pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
-{
- int pos;
-
- restart:
- for (pos = 0; desc[pos].type != XD_END; pos++)
- {
- void *rdata = (char *)data + desc[pos].offset;
- switch (desc[pos].type)
- {
- case XD_SPECIFIER_END:
- pos = 0;
- desc = ((const Lisp_Specifier *)data)->methods->extra_description;
- goto restart;
- case XD_SIZE_T:
- case XD_INT:
- case XD_LONG:
- case XD_BYTECOUNT:
- case XD_INT_RESET:
- break;
- case XD_OPAQUE_DATA_PTR:
- case XD_C_STRING:
- case XD_STRUCT_PTR:
- case XD_LO_LINK:
- {
- EMACS_INT ptr = *(EMACS_INT *)rdata;
- if (ptr)
- *(EMACS_INT *)rdata = ptr+delta;
- break;
- }
- case XD_LISP_OBJECT:
- {
- Lisp_Object *pobj = (Lisp_Object *) rdata;
-
- assert (desc[pos].data1 == 0);
-
- if (POINTER_TYPE_P (XTYPE (*pobj))
- && ! EQ (*pobj, Qnull_pointer))
- XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
-
- break;
- }
- case XD_LISP_OBJECT_ARRAY:
- case XD_LO_RESET_NIL:
- {
- EMACS_INT count = desc[pos].data1;
- int i;
- if (XD_IS_INDIRECT (count))
- count = pdump_get_indirect_count (count, desc, data);
-
- for (i=0; i<count; i++)
- {
- Lisp_Object *pobj = (Lisp_Object *) rdata + i;
-
- if (POINTER_TYPE_P (XTYPE (*pobj))
- && ! EQ (*pobj, Qnull_pointer))
- XSETOBJ (*pobj, XTYPE (*pobj), (char *) XPNTR (*pobj) + delta);
- }
- break;
- }
- case XD_DOC_STRING:
- {
- EMACS_INT str = *(EMACS_INT *)rdata;
- if (str > 0)
- *(EMACS_INT *)rdata = str + delta;
- break;
- }
- default:
- fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type);
- abort ();
- };
- }
-}
-
-static void
-pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc)
-{
- size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count;
- elmt->save_offset = cur_offset;
- if (size>max_size)
- max_size = size;
- cur_offset += size;
-}
-
-static void
-pdump_scan_by_alignment (void (*f)(pdump_entry_list_elmt *, const struct lrecord_description *))
-{
- int align, i;
- const struct lrecord_description *idesc;
- pdump_entry_list_elmt *elmt;
- for (align=8; align>=0; align--)
- {
- for (i=0; i<=last_lrecord_type_index_assigned; i++)
- if (pdump_object_table[i].align == align)
- {
- elmt = pdump_object_table[i].first;
- if (!elmt)
- continue;
- idesc = lrecord_implementations_table[i]->description;
- while (elmt)
- {
- f (elmt, idesc);
- elmt = elmt->next;
- }
- }
-
- for (i=0; i<pdump_struct_table.count; i++)
- if (pdump_struct_table.list[i].list.align == align)
- {
- elmt = pdump_struct_table.list[i].list.first;
- idesc = pdump_struct_table.list[i].sdesc->description;
- while (elmt)
- {
- f (elmt, idesc);
- elmt = elmt->next;
- }
- }
-
- elmt = pdump_opaque_data_list.first;
- while (elmt)
- {
- if (align_table[elmt->size & 255] == align)
- f (elmt, 0);
- elmt = elmt->next;
- }
- }
-}
-
-static void
-pdump_dump_staticvec (void)
-{
- EMACS_INT *reloc = xnew_array (EMACS_INT, staticidx);
- int i;
- write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
-
- for (i=0; i<staticidx; i++)
- {
- Lisp_Object obj = *staticvec[i];
- if (POINTER_TYPE_P (XTYPE (obj)))
- reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
- else
- reloc[i] = *(EMACS_INT *)(staticvec[i]);
- }
- write (pdump_fd, reloc, staticidx*sizeof (Lisp_Object));
- free (reloc);
-}
-
-static void
-pdump_dump_structvec (void)
-{
- int i;
- for (i=0; i<dumpstructidx; i++)
- {
- EMACS_INT adr;
- write (pdump_fd, &(dumpstructvec[i].data), sizeof (void *));
- adr = pdump_get_entry (*(void **)(dumpstructvec[i].data))->save_offset;
- write (pdump_fd, &adr, sizeof (adr));
- }
-}
-
-static void
-pdump_dump_opaquevec (void)
-{
- int i;
- for (i=0; i<dumpopaqueidx; i++)
- {
- write (pdump_fd, &(dumpopaquevec[i]), sizeof (dumpopaquevec[i]));
- write (pdump_fd, dumpopaquevec[i].data, dumpopaquevec[i].size);
- }
-}
-
-static void
-pdump_dump_itable (void)
-{
- write (pdump_fd, lrecord_implementations_table, sizeof (lrecord_implementations_table));
-}
-
-static void
-pdump_dump_rtables (void)
-{
- int i, j;
- pdump_entry_list_elmt *elmt;
- pdump_reloc_table rt;
-
- for (i=0; i<=last_lrecord_type_index_assigned; i++)
- {
- elmt = pdump_object_table[i].first;
- if (!elmt)
- continue;
- rt.desc = lrecord_implementations_table[i]->description;
- rt.count = pdump_object_table[i].count;
- write (pdump_fd, &rt, sizeof (rt));
- while (elmt)
- {
- EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
- write (pdump_fd, &rdata, sizeof (rdata));
- elmt = elmt->next;
- }
- }
-
- rt.desc = 0;
- rt.count = 0;
- write (pdump_fd, &rt, sizeof (rt));
-
- for (i=0; i<pdump_struct_table.count; i++)
- {
- elmt = pdump_struct_table.list[i].list.first;
- rt.desc = pdump_struct_table.list[i].sdesc->description;
- rt.count = pdump_struct_table.list[i].list.count;
- write (pdump_fd, &rt, sizeof (rt));
- while (elmt)
- {
- EMACS_INT rdata = pdump_get_entry (elmt->obj)->save_offset;
- for (j=0; j<elmt->count; j++)
- {
- write (pdump_fd, &rdata, sizeof (rdata));
- rdata += elmt->size;
- }
- elmt = elmt->next;
- }
- }
- rt.desc = 0;
- rt.count = 0;
- write (pdump_fd, &rt, sizeof (rt));
-}
-
-static void
-pdump_dump_wired (void)
-{
- EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
- int i;
-
- write (pdump_fd, &count, sizeof (count));
-
- for (i=0; i<pdump_wireidx; i++)
- {
- EMACS_INT obj = pdump_get_entry (XRECORD_LHEADER (*(pdump_wirevec[i])))->save_offset;
- write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i]));
- write (pdump_fd, &obj, sizeof (obj));
- }
-
- for (i=0; i<pdump_wireidx_list; i++)
- {
- Lisp_Object obj = *(pdump_wirevec_list[i]);
- pdump_entry_list_elmt *elmt;
- EMACS_INT res;
-
- for (;;)
- {
- const struct lrecord_description *desc;
- int pos;
- elmt = pdump_get_entry (XRECORD_LHEADER (obj));
- if (elmt)
- break;
- desc = XRECORD_LHEADER_IMPLEMENTATION (obj)->description;
- for (pos = 0; desc[pos].type != XD_LO_LINK; pos++)
- if (desc[pos].type == XD_END)
- abort ();
-
- obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj)));
- }
- res = elmt->save_offset;
-
- write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i]));
- write (pdump_fd, &res, sizeof (res));
- }
-}
-
-void
-pdump (void)
-{
- int i;
- Lisp_Object t_console, t_device, t_frame;
- int none;
- dump_header hd;
-
- /* These appear in a DEFVAR_LISP, which does a staticpro() */
- t_console = Vterminal_console;
- t_frame = Vterminal_frame;
- t_device = Vterminal_device;
-
- Vterminal_console = Qnil;
- Vterminal_frame = Qnil;
- Vterminal_device = Qnil;
-
- pdump_hash = xnew_array_and_zero (pdump_entry_list_elmt *, PDUMP_HASHSIZE);
-
- for (i=0; i<=last_lrecord_type_index_assigned; i++)
- {
- pdump_object_table[i].first = 0;
- pdump_object_table[i].align = 8;
- pdump_object_table[i].count = 0;
- pdump_alert_undump_object[i] = 0;
- }
- pdump_struct_table.count = 0;
- pdump_struct_table.size = -1;
-
- pdump_opaque_data_list.first = 0;
- pdump_opaque_data_list.align = 8;
- pdump_opaque_data_list.count = 0;
- depth = 0;
-
- for (i=0; i<staticidx; i++)
- pdump_register_object (*staticvec[i]);
- for (i=0; i<pdump_wireidx; i++)
- pdump_register_object (*pdump_wirevec[i]);
-
- none = 1;
- for (i=0; i<=last_lrecord_type_index_assigned; i++)
- if (pdump_alert_undump_object[i])
- {
- if (none)
- printf ("Undumpable types list :\n");
- none = 0;
- printf (" - %s (%d)\n", lrecord_implementations_table[i]->name, pdump_alert_undump_object[i]);
- }
- if (!none)
- return;
-
- for (i=0; i<dumpstructidx; i++)
- pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
-
- memcpy (hd.signature, "XEmacsDP", 8);
- hd.reloc_address = 0;
- hd.nb_staticpro = staticidx;
- hd.nb_structdmp = dumpstructidx;
- hd.nb_opaquedmp = dumpopaqueidx;
- hd.last_type = last_lrecord_type_index_assigned;
-
- cur_offset = 256;
- max_size = 0;
-
- pdump_scan_by_alignment (pdump_allocate_offset);
- pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
-
- pdump_buf = xmalloc (max_size);
- /* Avoid use of the `open' macro. We want the real function. */
-#undef open
- pdump_fd = open ("xemacs.dmp",
- O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, 0666);
- hd.stab_offset = (cur_offset + 3) & ~3;
-
- write (pdump_fd, &hd, sizeof (hd));
- lseek (pdump_fd, 256, SEEK_SET);
-
- pdump_scan_by_alignment (pdump_dump_data);
-
- lseek (pdump_fd, hd.stab_offset, SEEK_SET);
-
- pdump_dump_staticvec ();
- pdump_dump_structvec ();
- pdump_dump_opaquevec ();
- pdump_dump_itable ();
- pdump_dump_rtables ();
- pdump_dump_wired ();
-
- close (pdump_fd);
- free (pdump_buf);
-
- free (pdump_hash);
-
- Vterminal_console = t_console;
- Vterminal_frame = t_frame;
- Vterminal_device = t_device;
-}
-
-int
-pdump_load (void)
-{
- size_t length;
- int i;
- char *p;
- EMACS_INT delta;
- EMACS_INT count;
-
-#define PDUMP_READ(p, type) (p = (char*) (((type *) p) + 1), *((type *) p - 1))
-
- pdump_start = pdump_end = 0;
-
- pdump_fd = open ("xemacs.dmp", O_RDONLY | OPEN_BINARY);
- if (pdump_fd<0)
- return 0;
-
- length = lseek (pdump_fd, 0, SEEK_END);
- lseek (pdump_fd, 0, SEEK_SET);
-
-#ifdef HAVE_MMAP
- pdump_start = (char *) mmap (0, length, PROT_READ|PROT_WRITE, MAP_PRIVATE, pdump_fd, 0);
- if (pdump_start == MAP_FAILED)
- pdump_start = 0;
-#endif
-
- if (!pdump_start)
- {
- pdump_start = (char *)((((unsigned long)(xmalloc(length+255))) + 255) & ~255);
- read (pdump_fd, pdump_start, length);
- }
-
- close (pdump_fd);
-
- pdump_end = pdump_start + length;
-
- staticidx = ((dump_header *)(pdump_start))->nb_staticpro;
- last_lrecord_type_index_assigned = ((dump_header *)pdump_start)->last_type;
- delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address;
- p = pdump_start + ((dump_header *)pdump_start)->stab_offset;
-
- /* Put back the staticvec in place */
- memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *));
- p += staticidx*sizeof (Lisp_Object *);
- for (i=0; i<staticidx; i++)
- {
- Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
- if (POINTER_TYPE_P (XTYPE (obj)))
- XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
- *staticvec[i] = obj;
- }
-
- /* Put back the dumpstructs */
- for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
- {
- void **adr = PDUMP_READ (p, void **);
- *adr = (void *) (PDUMP_READ (p, char *) + delta);
- }
-
- /* Put back the opaques */
- for (i=0; i<((dump_header *)pdump_start)->nb_opaquedmp; i++)
- {
- struct dumpopaque_info di = PDUMP_READ (p, struct dumpopaque_info);
- memcpy (di.data, p, di.size);
- p += di.size;
- }
-
- /* Put back the lrecord_implementations_table */
- memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
- p += sizeof (lrecord_implementations_table);
-
- /* Give back their numbers to the lrecord implementations */
- for (i = 0; i < countof (lrecord_implementations_table); i++)
- if (lrecord_implementations_table[i])
- {
- *(lrecord_implementations_table[i]->lrecord_type_index) = i;
- last_lrecord_type_index_assigned = i;
- }
-
- /* Do the relocations */
- pdump_rt_list = p;
- count = 2;
- for (;;)
- {
- pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
- if (rt.desc)
- {
- for (i=0; i < rt.count; i++)
- {
- char *adr = delta + *(char **)p;
- *(char **)p = adr;
- pdump_reloc_one (adr, delta, rt.desc);
- p += sizeof (char *);
- }
- } else
- if (!(--count))
- break;
- }
-
- /* Put the pdump_wire variables in place */
- count = PDUMP_READ (p, EMACS_INT);
-
- for (i=0; i<count; i++)
- {
- Lisp_Object *var = PDUMP_READ (p, Lisp_Object *);
- Lisp_Object obj = PDUMP_READ (p, Lisp_Object);
-
- if (POINTER_TYPE_P (XTYPE (obj)))
- XSETOBJ (obj, XTYPE (obj), (char *) XPNTR (obj) + delta);
-
- *var = obj;
- }
-
- /* Final cleanups */
- /* reorganize hash tables */
- p = pdump_rt_list;
- for (;;)
- {
- pdump_reloc_table rt = PDUMP_READ (p, pdump_reloc_table);
- if (!rt.desc)
- break;
- if (rt.desc == hash_table_description)
- {
- for (i=0; i < rt.count; i++)
- pdump_reorganize_hash_table (PDUMP_READ (p, Lisp_Object));
- break;
- } else
- p += sizeof (Lisp_Object) * rt.count;
- }
-
- /* Put back noninteractive1 to its real value */
- noninteractive1 = noninteractive;
-
- return 1;
-}
-
-#endif /* PDUMP */
projects / chise / xemacs-chise.git.1 / blobdiff