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);
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;
After doing the mark phase, GC will walk this linked list
and free any lcrecord which hasn't been marked. */
static struct lcrecord_header *all_lcrecords;
+#ifdef UTF2000
+static struct lcrecord_header *all_older_lcrecords;
+#endif
void *
alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
(! (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++;
return lcheader;
}
+#ifdef UTF2000
+void *
+alloc_older_lcrecord (size_t size,
+ const struct lrecord_implementation *implementation)
+{
+ struct lcrecord_header *lcheader;
+
+ 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_older_implementation (&lcheader->lheader, implementation);
+ lcheader->next = all_older_lcrecords;
+#if 1 /* mly prefers to see small ID numbers */
+ lcheader->uid = lrecord_uid_counter++;
+#else /* jwz prefers to see real addrs */
+ lcheader->uid = (int) &lcheader;
+#endif
+ lcheader->free = 0;
+ all_older_lcrecords = lcheader;
+ INCREMENT_CONS_COUNTER (size, implementation->name);
+ return lcheader;
+}
+#endif
+
#if 0 /* Presently unused */
/* Very, very poor man's EGC?
* This may be slow and thrash pages all over the place.
!header->free)
LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
}
+#ifdef UTF2000
+ for (header = all_older_lcrecords; header; header = header->next)
+ {
+ if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
+ !header->free)
+ LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
+ }
+#endif
}
\f
about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
to see how this is used. */
-EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
-EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
+const EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
+const EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
#ifdef USE_UNION_TYPE
-unsigned char dbg_USE_UNION_TYPE = 1;
+const unsigned char dbg_USE_UNION_TYPE = 1;
#else
-unsigned char dbg_USE_UNION_TYPE = 0;
+const unsigned char dbg_USE_UNION_TYPE = 0;
#endif
-unsigned char dbg_valbits = VALBITS;
-unsigned char dbg_gctypebits = GCTYPEBITS;
+const unsigned char dbg_valbits = VALBITS;
+const unsigned char dbg_gctypebits = GCTYPEBITS;
/* Macros turned into functions for ease of debugging.
Debuggers don't know about macros! */
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);
You have some weird system and need to supply a reasonable value here.
#endif
+/* The construct (* (void **) (ptr)) would cause aliasing problems
+ with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
+ But `char *' can legally alias any pointer. Hence this union trick...
+
+ It turned out that the union trick was not good enough for xlC -O3;
+ and it is questionable whether it really complies with the C standard.
+ so we use memset instead, which should be safe from optimizations. */
+typedef union { char c; void *p; } *aliasing_voidpp;
+#define ALIASING_VOIDPP_DEREFERENCE(ptr) \
+ (((aliasing_voidpp) (ptr))->p)
#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)
+ (ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
+#define MARK_STRUCT_AS_FREE(ptr) memset (ptr, 0xff, sizeof (void *))
+#define MARK_STRUCT_AS_NOT_FREE(ptr) memset (ptr, 0x00, sizeof (void *))
#ifdef ERROR_CHECK_GC
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, 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, 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;
}
}
+#ifdef HAVE_GGC
+Lisp_Object
+make_older_vector (size_t length, Lisp_Object init)
+{
+ struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
+ Lisp_Object obj;
+
+ all_lcrecords = all_older_lcrecords;
+ obj = make_vector (length, init);
+ all_older_lcrecords = all_lcrecords;
+ all_lcrecords = orig_all_lcrecords;
+ return obj;
+}
+
+void make_vector_newer_1 (Lisp_Object v);
+void
+make_vector_newer_1 (Lisp_Object v)
+{
+ struct lcrecord_header* lcrecords = all_older_lcrecords;
+
+ if (lcrecords != NULL)
+ {
+ if (lcrecords == XPNTR (v))
+ {
+ lcrecords->lheader.older = 0;
+ all_older_lcrecords = all_older_lcrecords->next;
+ lcrecords->next = all_lcrecords;
+ all_lcrecords = lcrecords;
+ return;
+ }
+ else
+ {
+ struct lcrecord_header* plcrecords = lcrecords;
+
+ lcrecords = lcrecords->next;
+ while (lcrecords != NULL)
+ {
+ if (lcrecords == XPNTR (v))
+ {
+ lcrecords->lheader.older = 0;
+ plcrecords->next = lcrecords->next;
+ lcrecords->next = all_lcrecords;
+ all_lcrecords = lcrecords;
+ return;
+ }
+ plcrecords = lcrecords;
+ lcrecords = lcrecords->next;
+ }
+ }
+ }
+}
+
+void
+make_vector_newer (Lisp_Object v)
+{
+ int i;
+
+ for (i = 0; i < XVECTOR_LENGTH (v); i++)
+ {
+ Lisp_Object obj = XVECTOR_DATA (v)[i];
+
+ if (VECTORP (obj) && !EQ (obj, v))
+ make_vector_newer (obj);
+ }
+ make_vector_newer_1 (v);
+}
+#endif
+
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, 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
{
}
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;
/* 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)
#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);
{
Lisp_Object val;
- XSETOBJ (val, Lisp_Type_Record,
- alloc_lcrecord (list->size, list->implementation));
+ XSETOBJ (val, alloc_lcrecord (list->size, list->implementation));
return val;
}
}
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;
-
/* 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. */
-#define MODULE_DEFINABLE_TYPE_COUNT 32
-const struct lrecord_implementation *lrecord_implementations_table[lrecord_type_count + MODULE_DEFINABLE_TYPE_COUNT];
-
+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%. */
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;
-}
-
-/* Not "static" because of linker lossage on some systems */
-Lisp_Object *staticvec_nodump[200]
- /* Force it into data space! */
- = {0};
-static int staticidx_nodump;
-
-/* 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;
-}
-
-/* Not "static" because of linker lossage on some systems */
-struct
-{
- void *data;
- const struct struct_description *desc;
-} dumpstructvec[200];
-
-static int dumpstructidx;
-
-/* Put an entry in dumpstructvec, pointing at the variable whose address is given
- */
-void
-dumpstruct (void *varaddress, const struct struct_description *desc)
-{
- if (dumpstructidx >= countof (dumpstructvec))
- abort ();
- dumpstructvec[dumpstructidx].data = varaddress;
- dumpstructvec[dumpstructidx].desc = desc;
- dumpstructidx++;
-}
+/* 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 */
-struct dumpopaque_info
-{
- void *data;
- size_t size;
-} dumpopaquevec[200];
+static const struct struct_description staticpro_description = {
+ sizeof (Lisp_Object *),
+ staticpro_description_1
+};
-static int dumpopaqueidx;
+static const struct lrecord_description staticpros_description_1[] = {
+ XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
+ { XD_END }
+};
-/* 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++;
-}
+static const struct struct_description staticpros_description = {
+ sizeof (Lisp_Object_ptr_dynarr),
+ staticpros_description_1
+};
-Lisp_Object *pdump_wirevec[50];
-static int pdump_wireidx;
+Lisp_Object_ptr_dynarr *staticpros;
-/* 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, and for dumping. */
void
-pdump_wire (Lisp_Object *varaddress)
+staticpro (Lisp_Object *varaddress)
{
- if (pdump_wireidx >= countof (pdump_wirevec))
- abort ();
- pdump_wirevec[pdump_wireidx++] = varaddress;
+ Dynarr_add (staticpros, varaddress);
+ dump_add_root_object (varaddress);
}
-Lisp_Object *pdump_wirevec_list[50];
-static int pdump_wireidx_list;
+Lisp_Object_ptr_dynarr *staticpros_nodump;
-/* Put an entry in pdump_wirevec_list, 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_list (Lisp_Object *varaddress)
+staticpro_nodump (Lisp_Object *varaddress)
{
- if (pdump_wireidx_list >= countof (pdump_wirevec_list))
- abort ();
- pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
+ Dynarr_add (staticpros_nodump, 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 <= last_lrecord_type_index_assigned); \
+ 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))); \
/* 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))
+ if ( (!MARKED_RECORD_HEADER_P (lheader))
+#ifdef UTF2000
+ && (!OLDER_RECORD_HEADER_P (lheader))
+#endif
+ )
{
MARK_RECORD_HEADER (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, 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; \
) \
UNMARK_##typename (SFTB_victim); \
} \
} \
- SFTB_prev = &(SFTB_current->prev); \
SFTB_current = SFTB_current->prev; \
SFTB_limit = countof (current_##typename##_block->block); \
} \
free_marker (Lisp_Marker *ptr)
{
/* Perhaps this will catch freeing an already-freed marker. */
- gc_checking_assert (ptr->lheader.type = lrecord_type_marker);
+ gc_checking_assert (ptr->lheader.type == lrecord_type_marker);
#ifndef ALLOC_NO_POOLS
FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, Lisp_Marker, ptr);
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); \
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++)
- {
- struct lrecord_header *lh = * (struct lrecord_header **) p;
- if (! C_READONLY_RECORD_HEADER_P (lh))
- UNMARK_RECORD_HEADER (lh);
- p += sizeof (EMACS_INT);
- }
- } else
- break;
- }
- }
+ pdump_objects_unmark ();
#endif
}
\f
/* 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++)
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
}
#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.
XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
XSETINT (Vgc_message, 0);
all_lcrecords = 0;
+#ifdef UTF2000
+ all_older_lcrecords = 0;
+#endif
ignore_malloc_warnings = 1;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
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;
{
reinit_alloc_once_early ();
- last_lrecord_type_index_assigned = lrecord_type_count - 1;
-
{
int i;
for (i = 0; i < countof (lrecord_implementations_table); i++)
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);
-
- /* Reinitialize lrecord_markers from lrecord_implementations_table */
- for (i=0; i < countof (lrecord_implementations_table); i++)
- if (lrecord_implementations_table[i])
- lrecord_markers[i] = lrecord_implementations_table[i]->marker;
-
- /* 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- / blobdiff