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.
*/
#include <config.h>
#include "specifier.h"
#include "sysfile.h"
#include "window.h"
-
-#include <stddef.h>
+#include "console-stream.h"
#ifdef DOUG_LEA_MALLOC
#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;
+#endif
+
EXFUN (Fgarbage_collect, 0);
/* Return the true size of a struct with a variable-length array field. */
#endif
#endif
-/* Define this to see where all that space is going... */
-/* But the length of the printout is obnoxious, so limit it to testers */
-#ifdef MEMORY_USAGE_STATS
-#define PURESTAT
-#endif
-
/* Define this to use malloc/free with no freelist for all datatypes,
the hope being that some debugging tools may help detect
freed memory references */
#define ALLOC_NO_POOLS
#endif
-#include "puresize.h"
-
#ifdef DEBUG_XEMACS
static int debug_allocation;
static int debug_allocation_backtrace_length;
#endif /* VIRT_ADDR_VARIES */
EMACS_INT malloc_sbrk_unused;
-/* Non-zero means defun should do purecopy on the function definition */
+/* Non-zero means we're in the process of doing the dump */
int purify_flag;
-#ifdef HEAP_IN_DATA
-extern void sheap_adjust_h();
-#endif
-
-/* Force linker to put it into data space! */
-EMACS_INT pure[PURESIZE / sizeof (EMACS_INT)] = { (EMACS_INT) 0};
-
-#define PUREBEG ((char *) pure)
-
-#if 0 /* This is breathing_space in XEmacs */
-/* Points to memory space allocated as "spare",
- to be freed if we run out of memory. */
-static char *spare_memory;
-
-/* Amount of spare memory to keep in reserve. */
-#define SPARE_MEMORY (1 << 14)
-#endif
-
-/* Index in pure at which next pure object will be allocated. */
-static size_t pure_bytes_used;
-
-#define PURIFIED(ptr) \
-((char *) (ptr) >= PUREBEG && \
- (char *) (ptr) < PUREBEG + get_PURESIZE())
-
-/* Non-zero if pure_bytes_used > get_PURESIZE();
- accounts for excess purespace needs. */
-static size_t pure_lossage;
-
#ifdef ERROR_CHECK_TYPECHECK
Error_behavior ERROR_ME, ERROR_ME_NOT, ERROR_ME_WARN;
#endif
int
-purified (Lisp_Object obj)
-{
- return POINTER_TYPE_P (XGCTYPE (obj)) && PURIFIED (XPNTR (obj));
-}
-
-size_t
-purespace_usage (void)
-{
- return pure_bytes_used;
-}
-
-static int
-check_purespace (size_t size)
-{
- if (pure_lossage)
- {
- pure_lossage += size;
- return 0;
- }
- else if (pure_bytes_used + size > get_PURESIZE())
- {
- /* This can cause recursive bad behavior, we'll yell at the end */
- /* when we're done. */
- /* message ("\nERROR: Pure Lisp storage exhausted!\n"); */
- pure_lossage = size;
- return 0;
- }
- else
- return 1;
-}
-
-
-\f
-#ifndef PURESTAT
-
-#define bump_purestat(p,b) DO_NOTHING
-
-#else /* PURESTAT */
-
-static int purecopying_function_constants;
-
-static size_t pure_sizeof (Lisp_Object);
-
-/* Keep statistics on how much of what is in purespace */
-static struct purestat
-{
- int nobjects;
- int nbytes;
- CONST char *name;
-}
- purestat_cons = {0, 0, "cons cells"},
- purestat_float = {0, 0, "float objects"},
- purestat_string_pname = {0, 0, "symbol-name strings"},
- purestat_function = {0, 0, "compiled-function objects"},
- purestat_opaque_instructions = {0, 0, "compiled-function instructions"},
- purestat_vector_constants = {0, 0, "compiled-function constants vectors"},
- purestat_string_interactive = {0, 0, "interactive strings"},
-#ifdef I18N3
- purestat_string_domain = {0, 0, "domain strings"},
-#endif
- purestat_string_documentation = {0, 0, "documentation strings"},
- purestat_string_other_function = {0, 0, "other function strings"},
- purestat_vector_other = {0, 0, "other vectors"},
- purestat_string_other = {0, 0, "other strings"},
- purestat_string_all = {0, 0, "all strings"},
- purestat_vector_all = {0, 0, "all vectors"};
-
-static void
-bump_purestat (struct purestat *purestat, size_t nbytes)
+c_readonly (Lisp_Object obj)
{
- if (pure_lossage) return;
- purestat->nobjects += 1;
- purestat->nbytes += nbytes;
+ return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj);
}
-static void
-print_purestat (struct purestat *purestat)
+int
+lisp_readonly (Lisp_Object obj)
{
- char buf [100];
- sprintf(buf, "%s:", purestat->name);
- message (" %-36s %5d %7d %2d%%",
- buf,
- purestat->nobjects,
- purestat->nbytes,
- (int) (purestat->nbytes / (pure_bytes_used / 100.0) + 0.5));
+ return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj);
}
-#endif /* PURESTAT */
\f
/* Maximum amount of C stack to save when a GC happens. */
void *val = xmalloc (len);
if (val == 0) return 0;
- memcpy (val, str, len);
- return (char *) val;
+ return (char *) memcpy (val, str, len);
}
#ifdef NEED_STRDUP
static void *
allocate_lisp_storage (size_t size)
{
- void *p = xmalloc (size);
-#ifndef USE_MINIMAL_TAGBITS
- char *lim = ((char *) p) + size;
- Lisp_Object val;
-
- XSETOBJ (val, Lisp_Type_Record, lim);
- if ((char *) XPNTR (val) != lim)
- {
- xfree (p);
- memory_full ();
- }
-#endif /* ! USE_MINIMAL_TAGBITS */
- return p;
+ return xmalloc (size);
}
}
}
-
-/* This must not be called -- it just serves as for EQ test
- * If lheader->implementation->finalizer is this_marks_a_marked_record,
- * then lrecord has been marked by the GC sweeper
- * header->implementation is put back to its correct value by
- * sweep_records */
-void
-this_marks_a_marked_record (void *dummy0, int dummy1)
-{
- abort ();
-}
-
/* 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, void (*markobj) (Lisp_Object))
+this_one_is_unmarkable (Lisp_Object obj)
{
abort ();
return Qnil;
}
-/* XGCTYPE for records */
-int
-gc_record_type_p (Lisp_Object frob, CONST struct lrecord_implementation *type)
-{
- CONST struct lrecord_implementation *imp;
-
- if (XGCTYPE (frob) != Lisp_Type_Record)
- return 0;
-
- imp = XRECORD_LHEADER_IMPLEMENTATION (frob);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- return imp == type;
-#else
- return imp == type || imp == type + 1;
-#endif
-}
-
\f
/************************************************************************/
/* Debugger support */
about expressions in src/gdbinit. See src/gdbinit or src/dbxrc to
see how this is used. */
-#ifdef USE_MINIMAL_TAGBITS
EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
-unsigned char dbg_USE_MINIMAL_TAGBITS = 1;
-unsigned char Lisp_Type_Int = 100;
-#else
-EMACS_UINT dbg_valmask = (1UL << VALBITS) - 1;
-EMACS_UINT dbg_typemask = ((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS);
-unsigned char dbg_USE_MINIMAL_TAGBITS = 0;
-#endif
#ifdef USE_UNION_TYPE
unsigned char dbg_USE_UNION_TYPE = 1;
unsigned char dbg_USE_UNION_TYPE = 0;
#endif
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
-unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1;
-#else
-unsigned char dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0;
-#endif
-
-#ifdef LRECORD_CONS
+unsigned char Lisp_Type_Int = 100;
unsigned char Lisp_Type_Cons = 101;
-#else
-unsigned char lrecord_cons;
-#endif
-
-#ifdef LRECORD_STRING
unsigned char Lisp_Type_String = 102;
-#else
-unsigned char lrecord_string;
-#endif
-
-#ifdef LRECORD_VECTOR
unsigned char Lisp_Type_Vector = 103;
-#else
-unsigned char lrecord_vector;
-#endif
-
-#ifdef LRECORD_SYMBOL
unsigned char Lisp_Type_Symbol = 104;
-#else
-unsigned char lrecord_symbol;
-#endif
#ifndef MULE
unsigned char lrecord_char_table_entry;
/* #define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 20000 */
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_cons 2000
-#ifdef LRECORD_CONS
static Lisp_Object
-mark_cons (Lisp_Object obj, void (*markobj) (Lisp_Object))
+mark_cons (Lisp_Object obj)
{
- if (GC_NILP (XCDR (obj)))
+ if (NILP (XCDR (obj)))
return XCAR (obj);
- markobj (XCAR (obj));
+ mark_object (XCAR (obj));
return XCDR (obj);
}
return 0;
}
+static const struct lrecord_description cons_description[] = {
+ { XD_LISP_OBJECT, offsetof(struct Lisp_Cons, car), 2 },
+ { XD_END }
+};
+
DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons,
mark_cons, print_cons, 0,
cons_equal,
* handle conses.
*/
0,
+ cons_description,
struct Lisp_Cons);
-#endif /* LRECORD_CONS */
DEFUN ("cons", Fcons, 2, 2, 0, /*
Create a new cons, give it CAR and CDR as components, and return it.
struct Lisp_Cons *c;
ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
-#ifdef LRECORD_CONS
- set_lheader_implementation (&(c->lheader), lrecord_cons);
-#endif
+ set_lheader_implementation (&(c->lheader), &lrecord_cons);
XSETCONS (val, c);
c->car = car;
c->cdr = cdr;
struct Lisp_Cons *c;
NOSEEUM_ALLOCATE_FIXED_TYPE (cons, struct Lisp_Cons, c);
-#ifdef LRECORD_CONS
- set_lheader_implementation (&(c->lheader), lrecord_cons);
-#endif
+ set_lheader_implementation (&(c->lheader), &lrecord_cons);
XSETCONS (val, c);
XCAR (val) = car;
XCDR (val) = cdr;
{
Lisp_Object val = Qnil;
- int size = XINT (length);
+ size_t size = XINT (length);
- while (size-- > 0)
+ while (size--)
val = Fcons (init, val);
return val;
}
struct Lisp_Float *f;
ALLOCATE_FIXED_TYPE (float, struct Lisp_Float, 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;
/* Vector allocation */
/************************************************************************/
-#ifdef LRECORD_VECTOR
static Lisp_Object
-mark_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
+mark_vector (Lisp_Object obj)
{
Lisp_Vector *ptr = XVECTOR (obj);
int len = vector_length (ptr);
int i;
for (i = 0; i < len - 1; i++)
- markobj (ptr->contents[i]);
+ mark_object (ptr->contents[i]);
return (len > 0) ? ptr->contents[len - 1] : Qnil;
}
return 1;
}
+static const struct lrecord_description vector_description[] = {
+ { XD_LONG, offsetof(struct Lisp_Vector, size) },
+ { XD_LISP_OBJECT, offsetof(struct Lisp_Vector, contents), XD_INDIRECT(0, 0) },
+ { XD_END }
+};
+
DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector,
mark_vector, print_vector, 0,
vector_equal,
* knows how to handle vectors.
*/
0,
+ vector_description,
size_vector, Lisp_Vector);
/* #### should allocate `small' vectors from a frob-block */
{
/* no vector_next */
size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei);
- Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, lrecord_vector);
+ Lisp_Vector *p = (Lisp_Vector *) alloc_lcrecord (sizem, &lrecord_vector);
p->size = sizei;
return p;
}
-#else /* ! LRECORD_VECTOR */
-
-static Lisp_Object all_vectors;
-
-/* #### should allocate `small' vectors from a frob-block */
-static Lisp_Vector *
-make_vector_internal (size_t sizei)
-{
- /* + 1 to account for vector_next */
- size_t sizem = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, sizei+1);
- Lisp_Vector *p = (Lisp_Vector *) allocate_lisp_storage (sizem);
-
- INCREMENT_CONS_COUNTER (sizem, "vector");
-
- p->size = sizei;
- vector_next (p) = all_vectors;
- XSETVECTOR (all_vectors, p);
- return p;
-}
-
-#endif /* ! LRECORD_VECTOR */
-
Lisp_Object
make_vector (size_t length, Lisp_Object init)
{
size_t num_longs = BIT_VECTOR_LONG_STORAGE (sizei);
size_t sizem = STRETCHY_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");
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_compiled_function 1000
static Lisp_Object
-make_compiled_function (int make_pure)
+make_compiled_function (void)
{
Lisp_Compiled_Function *f;
Lisp_Object fun;
- size_t size = sizeof (Lisp_Compiled_Function);
- if (make_pure && check_purespace (size))
- {
- f = (Lisp_Compiled_Function *) (PUREBEG + pure_bytes_used);
- set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- f->lheader.pure = 1;
-#endif
- pure_bytes_used += size;
- bump_purestat (&purestat_function, size);
- }
- else
- {
- ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
- set_lheader_implementation (&(f->lheader), lrecord_compiled_function);
- }
+ ALLOCATE_FIXED_TYPE (compiled_function, Lisp_Compiled_Function, f);
+ set_lheader_implementation (&(f->lheader), &lrecord_compiled_function);
+
f->stack_depth = 0;
f->specpdl_depth = 0;
f->flags.documentationp = 0;
/* In a non-insane world this function would have this arglist...
(arglist instructions constants stack_depth &optional doc_string interactive)
*/
- Lisp_Object fun = make_compiled_function (purify_flag);
+ Lisp_Object fun = make_compiled_function ();
Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (fun);
Lisp_Object arglist = args[0];
Lisp_Object doc_string = (nargs > 4) ? args[4] : Qnil;
Lisp_Object interactive = (nargs > 5) ? args[5] : Qunbound;
- /* Don't purecopy the doc references in instructions because it's
- wasteful; they will get fixed up later.
-
- #### If something goes wrong and they don't get fixed up,
- we're screwed, because pure stuff isn't marked and thus the
- cons references won't be marked and will get reused.
-
- Note: there will be a window after the byte code is created and
- before the doc references are fixed up in which there will be
- impure objects inside a pure object, which apparently won't
- get marked, leading to trouble. But during that entire window,
- the objects are sitting on Vload_force_doc_string_list, which
- is staticpro'd, so we're OK. */
- Lisp_Object (*cons) (Lisp_Object, Lisp_Object)
- = purify_flag ? pure_cons : Fcons;
-
if (nargs < 4 || nargs > 6)
return Fsignal (Qwrong_number_of_arguments,
list2 (intern ("make-byte-code"), make_int (nargs)));
f->constants = constants;
CHECK_NATNUM (stack_depth);
- f->stack_depth = XINT (stack_depth);
+ f->stack_depth = XINT (stack_depth);
#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
if (!NILP (Vcurrent_compiled_function_annotation))
- f->annotated = Fpurecopy (Vcurrent_compiled_function_annotation);
+ f->annotated = Fcopy (Vcurrent_compiled_function_annotation);
else if (!NILP (Vload_file_name_internal_the_purecopy))
f->annotated = Vload_file_name_internal_the_purecopy;
else if (!NILP (Vload_file_name_internal))
struct gcpro gcpro1;
GCPRO1 (fun); /* don't let fun get reaped */
Vload_file_name_internal_the_purecopy =
- Fpurecopy (Ffile_name_nondirectory (Vload_file_name_internal));
+ Ffile_name_nondirectory (Vload_file_name_internal);
f->annotated = Vload_file_name_internal_the_purecopy;
UNGCPRO;
}
#endif
if ((f->flags.interactivep = !UNBOUNDP (interactive)) != 0)
{
- if (purify_flag)
- {
- interactive = Fpurecopy (interactive);
- if (STRINGP (interactive))
- bump_purestat (&purestat_string_interactive,
- pure_sizeof (interactive));
- }
f->doc_and_interactive
= (UNBOUNDP (f->doc_and_interactive) ? interactive :
- cons (interactive, f->doc_and_interactive));
+ Fcons (interactive, f->doc_and_interactive));
}
if ((f->flags.documentationp = !NILP (doc_string)) != 0)
{
- if (purify_flag)
- {
- doc_string = Fpurecopy (doc_string);
- if (STRINGP (doc_string))
- /* These should have been snagged by make-docfile... */
- bump_purestat (&purestat_string_documentation,
- pure_sizeof (doc_string));
- }
f->doc_and_interactive
= (UNBOUNDP (f->doc_and_interactive) ? doc_string :
- cons (doc_string, f->doc_and_interactive));
+ Fcons (doc_string, f->doc_and_interactive));
}
if (UNBOUNDP (f->doc_and_interactive))
f->doc_and_interactive = Qnil;
- if (purify_flag)
- {
-
- if (!purified (f->arglist))
- f->arglist = Fpurecopy (f->arglist);
-
- /* Statistics are kept differently for the constants */
- if (!purified (f->constants))
- {
-#ifdef PURESTAT
- int old = purecopying_function_constants;
- purecopying_function_constants = 1;
- f->constants = Fpurecopy (f->constants);
- bump_purestat (&purestat_vector_constants,
- pure_sizeof (f->constants));
- purecopying_function_constants = old;
-#else
- f->constants = Fpurecopy (f->constants);
-#endif /* PURESTAT */
- }
-
- optimize_compiled_function (fun);
-
- bump_purestat (&purestat_opaque_instructions,
- pure_sizeof (f->instructions));
- }
-
return fun;
}
CHECK_STRING (name);
ALLOCATE_FIXED_TYPE (symbol, struct Lisp_Symbol, p);
-#ifdef LRECORD_SYMBOL
- set_lheader_implementation (&(p->lheader), lrecord_symbol);
-#endif
+ set_lheader_implementation (&(p->lheader), &lrecord_symbol);
p->name = XSTRING (name);
p->plist = Qnil;
p->value = Qunbound;
p->function = Qunbound;
- p->obarray = Qnil;
symbol_next (p) = 0;
XSETSYMBOL (val, p);
return val;
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);
struct Lisp_Event *e;
ALLOCATE_FIXED_TYPE (event, struct Lisp_Event, e);
- set_lheader_implementation (&(e->lheader), lrecord_event);
+ set_lheader_implementation (&(e->lheader), &lrecord_event);
XSETEVENT (val, e);
return val;
struct Lisp_Marker *p;
ALLOCATE_FIXED_TYPE (marker, struct 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;
struct Lisp_Marker *p;
NOSEEUM_ALLOCATE_FIXED_TYPE (marker, struct 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 MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 10000 */
#define MINIMUM_ALLOWED_FIXED_TYPE_CELLS_string 1000
-#ifdef LRECORD_STRING
static Lisp_Object
-mark_string (Lisp_Object obj, void (*markobj) (Lisp_Object))
+mark_string (Lisp_Object obj)
{
struct Lisp_String *ptr = XSTRING (obj);
- if (GC_CONSP (ptr->plist) && GC_EXTENT_INFOP (XCAR (ptr->plist)))
+ if (CONSP (ptr->plist) && EXTENT_INFOP (XCAR (ptr->plist)))
flush_cached_extent_info (XCAR (ptr->plist));
return ptr->plist;
}
!memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
}
+static const struct lrecord_description string_description[] = {
+ { XD_BYTECOUNT, offsetof(Lisp_String, size) },
+ { XD_OPAQUE_DATA_PTR, offsetof(Lisp_String, data), XD_INDIRECT(0, 1) },
+ { XD_LISP_OBJECT, offsetof(Lisp_String, plist), 1 },
+ { XD_END }
+};
+
DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string,
mark_string, print_string,
/*
* SWEEP_FIXED_TYPE_BLOCK().
*/
0, string_equal, 0,
+ string_description,
struct Lisp_String);
-#endif /* LRECORD_STRING */
/* String blocks contain this many useful bytes. */
#define STRING_CHARS_BLOCK_SIZE \
unsigned char string_chars[STRING_CHARS_BLOCK_SIZE];
};
-struct string_chars_block *first_string_chars_block;
-struct string_chars_block *current_string_chars_block;
+static struct string_chars_block *first_string_chars_block;
+static struct string_chars_block *current_string_chars_block;
/* If SIZE is the length of a string, this returns how many bytes
* the string occupies in string_chars_block->string_chars
/* Allocate the string header */
ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
-#ifdef LRECORD_STRING
- set_lheader_implementation (&(s->lheader), lrecord_string);
-#endif
+ set_lheader_implementation (&(s->lheader), &lrecord_string);
s_chars = allocate_string_chars_struct (s, fullsize);
memset (XSTRING_DATA (val), XCHAR (init), XSTRING_LENGTH (val));
else
{
- int i;
+ size_t i;
Bufbyte *ptr = XSTRING_DATA (val);
for (i = XINT (length); i; i--)
return make_string (storage, p - storage);
}
+
/* Take some raw memory, which MUST already be in internal format,
and package it up into a Lisp string. */
Lisp_Object
return build_string (GETTEXT (str));
}
+Lisp_Object
+make_string_nocopy (CONST Bufbyte *contents, Bytecount length)
+{
+ struct Lisp_String *s;
+ Lisp_Object val;
+
+ /* Make sure we find out about bad make_string_nocopy's when they happen */
+#if defined (ERROR_CHECK_BUFPOS) && defined (MULE)
+ bytecount_to_charcount (contents, length); /* Just for the assertions */
+#endif
+
+ /* Allocate the string header */
+ ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s);
+ set_lheader_implementation (&(s->lheader), &lrecord_string);
+ SET_C_READONLY_RECORD_HEADER (&s->lheader);
+ s->plist = Qnil;
+ set_string_data (s, (Bufbyte *)contents);
+ set_string_length (s, length);
+
+ XSETSTRING (val, s);
+ return val;
+}
+
\f
/************************************************************************/
/* lcrecord lists */
It works like this:
1) Create an lcrecord-list object using make_lcrecord_list().
- This is often done at initialization. Remember to staticpro
+ This is often done at initialization. Remember to staticpro_nodump
this object! The arguments to make_lcrecord_list() are the
same as would be passed to alloc_lcrecord().
2) Instead of calling alloc_lcrecord(), call allocate_managed_lcrecord()
*/
static Lisp_Object
-mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
+mark_lcrecord_list (Lisp_Object obj)
{
struct lcrecord_list *list = XLCRECORD_LIST (obj);
Lisp_Object chain = list->free;
DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list,
mark_lcrecord_list, internal_object_printer,
- 0, 0, 0, struct lcrecord_list);
+ 0, 0, 0, 0, struct lcrecord_list);
Lisp_Object
make_lcrecord_list (size_t size,
CONST struct lrecord_implementation *implementation)
{
struct lcrecord_list *p = alloc_lcrecord_type (struct lcrecord_list,
- lrecord_lcrecord_list);
+ &lrecord_lcrecord_list);
Lisp_Object val;
p->implementation = implementation;
}
\f
-/************************************************************************/
-/* Purity of essence, peace on earth */
-/************************************************************************/
-
-static int symbols_initialized;
-Lisp_Object
-make_pure_string (CONST Bufbyte *data, Bytecount length,
- Lisp_Object plist, int no_need_to_copy_data)
+\f
+DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
+Kept for compatibility, returns its argument.
+Old:
+Make a copy of OBJECT in pure storage.
+Recursively copies contents of vectors and cons cells.
+Does not copy symbols.
+*/
+ (obj))
{
- Lisp_String *s;
- size_t size = sizeof (Lisp_String) +
- (no_need_to_copy_data ? 0 : (length + 1)); /* + 1 for terminating 0 */
- size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
+ return obj;
+}
- if (symbols_initialized && !pure_lossage)
- {
- /* Try to share some names. Saves a few kbytes. */
- Lisp_Object tem = oblookup (Vobarray, data, length);
- if (SYMBOLP (tem))
- {
- s = XSYMBOL (tem)->name;
- if (!PURIFIED (s)) abort ();
- {
- Lisp_Object string;
- XSETSTRING (string, s);
- return string;
- }
- }
- }
+\f
+/************************************************************************/
+/* Garbage Collection */
+/************************************************************************/
- if (!check_purespace (size))
- return make_string (data, length);
+/* This will be used more extensively In The Future */
+static int last_lrecord_type_index_assigned;
- s = (Lisp_String *) (PUREBEG + pure_bytes_used);
-#ifdef LRECORD_STRING
- set_lheader_implementation (&(s->lheader), lrecord_string);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- s->lheader.pure = 1;
-#endif
-#endif
- set_string_length (s, length);
- if (no_need_to_copy_data)
- {
- set_string_data (s, (Bufbyte *) data);
- }
- else
- {
- set_string_data (s, (Bufbyte *) s + sizeof (Lisp_String));
- memcpy (string_data (s), data, length);
- set_string_byte (s, length, 0);
- }
- s->plist = Qnil;
- pure_bytes_used += size;
+CONST struct lrecord_implementation *lrecord_implementations_table[128];
+#define max_lrecord_type (countof (lrecord_implementations_table) - 1)
-#ifdef PURESTAT
- bump_purestat (&purestat_string_all, size);
- if (purecopying_function_constants)
- bump_purestat (&purestat_string_other_function, size);
-#endif /* PURESTAT */
+struct gcpro *gcprolist;
- /* Do this after the official "completion" of the purecopying. */
- s->plist = Fpurecopy (plist);
+/* 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;
- {
- Lisp_Object string;
- XSETSTRING (string, s);
- return string;
- }
+/* 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;
-Lisp_Object
-make_pure_pname (CONST Bufbyte *data, Bytecount length,
- int no_need_to_copy_data)
+/* Put an entry in staticvec_nodump, pointing at the variable whose address is given
+ */
+void
+staticpro_nodump (Lisp_Object *varaddress)
{
- Lisp_Object name = make_pure_string (data, length, Qnil,
- no_need_to_copy_data);
- bump_purestat (&purestat_string_pname, pure_sizeof (name));
+ 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];
- /* We've made (at least) Qnil now, and Vobarray will soon be set up. */
- symbols_initialized = 1;
+static int dumpstructidx;
- return name;
+/* 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++;
}
+Lisp_Object *pdump_wirevec[50];
+static int pdump_wireidx;
-Lisp_Object
-pure_cons (Lisp_Object car, Lisp_Object cdr)
+/* Put an entry in pdump_wirevec, pointing at the variable whose address is given
+ */
+void
+pdump_wire (Lisp_Object *varaddress)
{
- Lisp_Cons *c;
-
- if (!check_purespace (sizeof (Lisp_Cons)))
- return Fcons (Fpurecopy (car), Fpurecopy (cdr));
+ if (pdump_wireidx >= countof (pdump_wirevec))
+ abort ();
+ pdump_wirevec[pdump_wireidx++] = varaddress;
+}
- c = (Lisp_Cons *) (PUREBEG + pure_bytes_used);
-#ifdef LRECORD_CONS
- set_lheader_implementation (&(c->lheader), lrecord_cons);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- c->lheader.pure = 1;
-#endif
-#endif
- pure_bytes_used += sizeof (Lisp_Cons);
- bump_purestat (&purestat_cons, sizeof (Lisp_Cons));
- c->car = Fpurecopy (car);
- c->cdr = Fpurecopy (cdr);
+Lisp_Object *pdump_wirevec_list[50];
+static int pdump_wireidx_list;
- {
- Lisp_Object cons;
- XSETCONS (cons, c);
- return cons;
- }
+/* 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;
}
-Lisp_Object
-pure_list (int nargs, Lisp_Object *args)
+\f
+/* Mark reference to a Lisp_Object. If the object referred to has not been
+ seen yet, recursively mark all the references contained in it. */
+
+void
+mark_object (Lisp_Object obj)
{
- Lisp_Object val = Qnil;
+ tail_recurse:
- for (--nargs; nargs >= 0; nargs--)
- val = pure_cons (args[nargs], val);
-
- return val;
-}
-
-#ifdef LISP_FLOAT_TYPE
-
-static Lisp_Object
-make_pure_float (double num)
-{
- struct Lisp_Float *f;
- Lisp_Object val;
-
- /* Make sure that PUREBEG + pure_bytes_used is aligned on at least a sizeof
- (double) boundary. Some architectures (like the sparc) require
- this, and I suspect that floats are rare enough that it's no
- tragedy for those that don't. */
- {
-#if defined (__GNUC__) && (__GNUC__ >= 2)
- /* In gcc, we can directly ask what the alignment constraints of a
- structure are, but in general, that's not possible... Arrgh!!
- */
- int alignment = __alignof (struct Lisp_Float);
-#else /* !GNUC */
- /* Best guess is to make the `double' slot be aligned to the size
- of double (which is probably 8 bytes). This assumes that it's
- ok to align the beginning of the structure to the same boundary
- that the `double' slot in it is supposed to be aligned to; this
- should be ok because presumably there is padding in the layout
- of the struct to account for this.
- */
- int alignment = sizeof (float_data (f));
-#endif /* !GNUC */
- char *p = ((char *) PUREBEG + pure_bytes_used);
-
- p = (char *) (((EMACS_UINT) p + alignment - 1) & - alignment);
- pure_bytes_used = p - (char *) PUREBEG;
- }
-
- if (!check_purespace (sizeof (struct Lisp_Float)))
- return make_float (num);
+#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 (PURIFIED (XPNTR (obj))) return; */
- f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used);
- set_lheader_implementation (&(f->lheader), lrecord_float);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- f->lheader.pure = 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
- pure_bytes_used += sizeof (struct Lisp_Float);
- bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
+ if (C_READONLY_RECORD_HEADER_P (lheader))
+ return;
- float_data (f) = num;
- XSETFLOAT (val, f);
- return val;
+ if (! MARKED_RECORD_HEADER_P (lheader) &&
+ ! UNMARKABLE_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)
+ {
+ obj = implementation->marker (obj);
+ if (!NILP (obj)) goto tail_recurse;
+ }
+ }
+ }
}
-#endif /* LISP_FLOAT_TYPE */
+/* mark all of the conses in a list and mark the final cdr; but
+ DO NOT mark the cars.
-Lisp_Object
-make_pure_vector (size_t len, Lisp_Object init)
+ Use only for internal lists! There should never be other pointers
+ to the cons cells, because if so, the cars will remain unmarked
+ even when they maybe should be marked. */
+void
+mark_conses_in_list (Lisp_Object obj)
{
- Lisp_Vector *v;
- size_t size = STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len);
-
- init = Fpurecopy (init);
-
- if (!check_purespace (size))
- return make_vector (len, init);
-
- v = (Lisp_Vector *) (PUREBEG + pure_bytes_used);
-#ifdef LRECORD_VECTOR
- set_lheader_implementation (&(v->header.lheader), lrecord_vector);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- v->header.lheader.pure = 1;
-#endif
-#endif
- pure_bytes_used += size;
- bump_purestat (&purestat_vector_all, size);
-
- v->size = len;
+ Lisp_Object rest;
- for (size = 0; size < len; size++)
- v->contents[size] = init;
+ for (rest = obj; CONSP (rest); rest = XCDR (rest))
+ {
+ if (CONS_MARKED_P (XCONS (rest)))
+ return;
+ MARK_CONS (XCONS (rest));
+ }
- {
- Lisp_Object vector;
- XSETVECTOR (vector, v);
- return vector;
- }
+ mark_object (rest);
}
-#if 0
-/* Presently unused */
-void *
-alloc_pure_lrecord (int size, struct lrecord_implementation *implementation)
-{
- struct lrecord_header *header = (void *) (PUREBEG + pure_bytes_used);
-
- if (pure_bytes_used + size > get_PURESIZE())
- pure_storage_exhausted ();
+\f
+/* Find all structures not marked, and free them. */
- set_lheader_implementation (header, implementation);
- header->next = 0;
- return header;
-}
-#endif /* unused */
+static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
+static int gc_count_bit_vector_storage;
+static int gc_count_num_short_string_in_use;
+static int gc_count_string_total_size;
+static int gc_count_short_string_total_size;
+/* static int gc_count_total_records_used, gc_count_records_total_size; */
\f
-DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
-Make a copy of OBJECT in pure storage.
-Recursively copies contents of vectors and cons cells.
-Does not copy symbols.
-*/
- (obj))
+int
+lrecord_type_index (CONST struct lrecord_implementation *implementation)
{
- if (!purify_flag)
- {
- return obj;
- }
- else if (!POINTER_TYPE_P (XTYPE (obj))
- || PURIFIED (XPNTR (obj))
- /* happens when bootstrapping Qnil */
- || EQ (obj, Qnull_pointer))
- {
- return obj;
- }
- /* Order of subsequent tests determined via profiling. */
- else if (SYMBOLP (obj))
- {
- /* Symbols can't be made pure (and thus read-only), because
- assigning to their function, value or plist slots would
- produced a SEGV in the dumped XEmacs. So we previously would
- just return the symbol unchanged.
-
- But purified aggregate objects like lists and vectors can
- contain uninterned symbols. If there are no other non-pure
- references to the symbol, then the symbol is not protected
- from garbage collection because the collector does not mark
- the contents of purified objects. So to protect the symbols,
- an impure reference has to be kept for each uninterned symbol
- that is referenced by a pure object. All such symbols are
- stored in the hash table pointed to by
- Vpure_uninterned_symbol_table, which is itself
- staticpro'd. */
- if (NILP (XSYMBOL (obj)->obarray))
- Fputhash (obj, Qnil, Vpure_uninterned_symbol_table);
- return obj;
- }
- else if (CONSP (obj))
- {
- return pure_cons (XCAR (obj), XCDR (obj));
- }
- else if (STRINGP (obj))
- {
- return make_pure_string (XSTRING_DATA (obj),
- XSTRING_LENGTH (obj),
- XSTRING (obj)->plist,
- 0);
- }
- else if (VECTORP (obj))
- {
- int i;
- Lisp_Vector *o = XVECTOR (obj);
- Lisp_Object pure_obj = make_pure_vector (vector_length (o), Qnil);
- for (i = 0; i < vector_length (o); i++)
- XVECTOR_DATA (pure_obj)[i] = Fpurecopy (o->contents[i]);
- return pure_obj;
- }
-#ifdef LISP_FLOAT_TYPE
- else if (FLOATP (obj))
- {
- return make_pure_float (XFLOAT_DATA (obj));
- }
-#endif
- else if (COMPILED_FUNCTIONP (obj))
+ 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)
{
- Lisp_Object pure_obj = make_compiled_function (1);
- Lisp_Compiled_Function *o = XCOMPILED_FUNCTION (obj);
- Lisp_Compiled_Function *n = XCOMPILED_FUNCTION (pure_obj);
- n->flags = o->flags;
- n->instructions = o->instructions;
- n->constants = Fpurecopy (o->constants);
- n->arglist = Fpurecopy (o->arglist);
- n->doc_and_interactive = Fpurecopy (o->doc_and_interactive);
- n->stack_depth = o->stack_depth;
- optimize_compiled_function (pure_obj);
- return pure_obj;
+ 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;
}
- else if (OPAQUEP (obj))
- {
- Lisp_Object pure_obj;
- Lisp_Opaque *old_opaque = XOPAQUE (obj);
- Lisp_Opaque *new_opaque = (Lisp_Opaque *) (PUREBEG + pure_bytes_used);
- struct lrecord_header *lheader = XRECORD_LHEADER (obj);
- CONST struct lrecord_implementation *implementation
- = LHEADER_IMPLEMENTATION (lheader);
- size_t size = implementation->size_in_bytes_method (lheader);
- size_t pure_size = ALIGN_SIZE (size, ALIGNOF (Lisp_Object));
- if (!check_purespace (pure_size))
- return obj;
- pure_bytes_used += pure_size;
-
- memcpy (new_opaque, old_opaque, size);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- lheader->pure = 1;
-#endif
- new_opaque->header.next = 0;
+ return type_index;
+}
+
+/* stats on lcrecords in use - kinda kludgy */
+
+static struct
+{
+ int instances_in_use;
+ int bytes_in_use;
+ int instances_freed;
+ int bytes_freed;
+ int instances_on_free_list;
+} lcrecord_stats [countof (lrecord_implementations_table)];
+
+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);
- XSETOPAQUE (pure_obj, new_opaque);
- return pure_obj;
+ if (((struct lcrecord_header *) h)->free)
+ {
+ assert (!free_p);
+ lcrecord_stats[type_index].instances_on_free_list++;
}
else
{
- signal_simple_error ("Can't purecopy %S", obj);
+ 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++;
+ lcrecord_stats[type_index].bytes_freed += sz;
+ }
+ else
+ {
+ lcrecord_stats[type_index].instances_in_use++;
+ lcrecord_stats[type_index].bytes_in_use += sz;
+ }
}
- return obj; /* Unreached */
}
-
\f
+/* Free all unmarked records */
static void
-puresize_adjust_h (size_t puresize)
+sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
{
- FILE *stream = fopen ("puresize-adjust.h", "w");
-
- if (stream == NULL)
- report_file_error ("Opening puresize adjustment file",
- Fcons (build_string ("puresize-adjust.h"), Qnil));
+ struct lcrecord_header *header;
+ int num_used = 0;
+ /* int total_size = 0; */
- fprintf (stream,
- "/*\tDo not edit this file!\n"
- "\tAutomatically generated by XEmacs */\n"
- "# define PURESIZE_ADJUSTMENT (%ld)\n",
- (long) (puresize - RAW_PURESIZE));
- fclose (stream);
-}
+ xzero (lcrecord_stats); /* Reset all statistics to 0. */
-void
-report_pure_usage (int report_impurities,
- int die_if_pure_storage_exceeded)
-{
- int rc = 0;
+ /* First go through and call all the finalize methods.
+ Then go through and free the objects. There used to
+ be only one loop here, with the call to the finalizer
+ occurring directly before the xfree() below. That
+ is marginally faster but much less safe -- if the
+ finalize method for an object needs to reference any
+ other objects contained within it (and many do),
+ we could easily be screwed by having already freed that
+ other object. */
- if (pure_lossage)
+ for (header = *prev; header; header = header->next)
{
- message ("\n****\tPure Lisp storage exhausted!\n"
- "\tPurespace usage: %ld of %ld\n"
- "****",
- (long) get_PURESIZE() + pure_lossage,
- (long) get_PURESIZE());
- if (die_if_pure_storage_exceeded)
+ struct lrecord_header *h = &(header->lheader);
+ if (!C_READONLY_RECORD_HEADER_P(h)
+ && !MARKED_RECORD_HEADER_P (h)
+ && ! (header->free))
{
- puresize_adjust_h (get_PURESIZE() + pure_lossage);
-#ifdef HEAP_IN_DATA
- sheap_adjust_h();
-#endif
- rc = -1;
+ if (LHEADER_IMPLEMENTATION (h)->finalizer)
+ LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
}
}
- else
+
+ for (header = *prev; header; )
{
- size_t lost = (get_PURESIZE() - pure_bytes_used) / 1024;
- char buf[200];
- /* extern Lisp_Object Vemacs_beta_version; */
- /* This used to be NILP(Vemacs_beta_version) ? 512 : 4; */
-#ifndef PURESIZE_SLOP
-#define PURESIZE_SLOP 0
-#endif
- size_t slop = PURESIZE_SLOP;
-
- sprintf (buf, "Purespace usage: %ld of %ld (%d%%",
- (long) pure_bytes_used,
- (long) get_PURESIZE(),
- (int) (pure_bytes_used / (get_PURESIZE() / 100.0) + 0.5));
- if (lost > ((slop ? slop : 1) / 1024)) {
- sprintf (buf + strlen (buf), " -- %ldk wasted", (long)lost);
- if (die_if_pure_storage_exceeded) {
- puresize_adjust_h (pure_bytes_used + slop);
-#ifdef HEAP_IN_DATA
- sheap_adjust_h();
-#endif
- rc = -1;
+ struct lrecord_header *h = &(header->lheader);
+ if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h))
+ {
+ if (MARKED_RECORD_HEADER_P (h))
+ UNMARK_RECORD_HEADER (h);
+ num_used++;
+ /* total_size += n->implementation->size_in_bytes (h);*/
+ /* ### May modify header->next on a C_READONLY lcrecord */
+ prev = &(header->next);
+ header = *prev;
+ tick_lcrecord_stats (h, 0);
+ }
+ else
+ {
+ struct lcrecord_header *next = header->next;
+ *prev = next;
+ tick_lcrecord_stats (h, 1);
+ /* used to call finalizer right here. */
+ xfree (header);
+ header = next;
}
- }
-
- strcat (buf, ").");
- message ("%s", buf);
}
+ *used = num_used;
+ /* *total = total_size; */
+}
-#ifdef PURESTAT
-
- purestat_vector_other.nbytes =
- purestat_vector_all.nbytes -
- purestat_vector_constants.nbytes;
- purestat_vector_other.nobjects =
- purestat_vector_all.nobjects -
- purestat_vector_constants.nobjects;
-
- purestat_string_other.nbytes =
- purestat_string_all.nbytes -
- (purestat_string_pname.nbytes +
- purestat_string_interactive.nbytes +
- purestat_string_documentation.nbytes +
-#ifdef I18N3
- purestat_string_domain.nbytes +
-#endif
- purestat_string_other_function.nbytes);
-
- purestat_string_other.nobjects =
- purestat_string_all.nobjects -
- (purestat_string_pname.nobjects +
- purestat_string_interactive.nobjects +
- purestat_string_documentation.nobjects +
-#ifdef I18N3
- purestat_string_domain.nobjects +
-#endif
- purestat_string_other_function.nobjects);
-
- message (" %-34s Objects Bytes", "");
-
- print_purestat (&purestat_cons);
- print_purestat (&purestat_float);
- print_purestat (&purestat_string_pname);
- print_purestat (&purestat_function);
- print_purestat (&purestat_opaque_instructions);
- print_purestat (&purestat_vector_constants);
- print_purestat (&purestat_string_interactive);
-#ifdef I18N3
- print_purestat (&purestat_string_domain);
-#endif
- print_purestat (&purestat_string_documentation);
- print_purestat (&purestat_string_other_function);
- print_purestat (&purestat_vector_other);
- print_purestat (&purestat_string_other);
- print_purestat (&purestat_string_all);
- print_purestat (&purestat_vector_all);
-
-#endif /* PURESTAT */
+static void
+sweep_bit_vectors_1 (Lisp_Object *prev,
+ int *used, int *total, int *storage)
+{
+ Lisp_Object bit_vector;
+ int num_used = 0;
+ int total_size = 0;
+ int total_storage = 0;
- if (report_impurities)
+ /* BIT_VECTORP fails because the objects are marked, which changes
+ their implementation */
+ for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
{
- Lisp_Object plist;
- struct gcpro gcpro1;
- plist = XCAR (XCDR (XCDR (XCDR (XCDR (XCDR (Fgarbage_collect()))))));
- GCPRO1 (plist);
- message ("\nImpurities:");
- for (; CONSP (plist); plist = XCDR (XCDR (plist)))
+ 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))
{
- Lisp_Object symbol = XCAR (plist);
- int size = XINT (XCAR (XCDR (plist)));
- if (size > 0)
- {
- char buf [100];
- char *s = buf;
- memcpy (buf,
- string_data (XSYMBOL (symbol)->name),
- string_length (XSYMBOL (symbol)->name) + 1);
- while (*s++) if (*s == '-') *s = ' ';
- *(s-1) = ':'; *s = 0;
- message (" %-34s %6d", buf, size);
- }
+ if (MARKED_RECORD_P (bit_vector))
+ UNMARK_RECORD_HEADER (&(v->lheader));
+ total_size += len;
+ total_storage +=
+ MALLOC_OVERHEAD +
+ STRETCHY_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));
+ bit_vector = *prev;
+ }
+ else
+ {
+ Lisp_Object next = bit_vector_next (v);
+ *prev = next;
+ xfree (v);
+ bit_vector = next;
}
- UNGCPRO;
- garbage_collect_1 (); /* collect Fgarbage_collect()'s garbage */
}
- clear_message ();
-
- if (rc < 0) {
- unlink("SATISFIED");
- fatal ("Pure size adjusted, Don't Panic! I will restart the `make'");
- } else if (pure_lossage && die_if_pure_storage_exceeded) {
- fatal ("Pure storage exhausted");
- }
+ *used = num_used;
+ *total = total_size;
+ *storage = total_storage;
}
-\f
-/************************************************************************/
-/* Garbage Collection */
-/************************************************************************/
+/* And the Lord said: Thou shalt use the `c-backslash-region' command
+ to make macros prettier. */
-/* This will be used more extensively In The Future */
-static int last_lrecord_type_index_assigned;
+#ifdef ERROR_CHECK_GC
-CONST struct lrecord_implementation *lrecord_implementations_table[128];
-#define max_lrecord_type (countof (lrecord_implementations_table) - 1)
+#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, \
+ SFTB_limit = current_##typename##_block_index; \
+ SFTB_current; \
+ ) \
+ { \
+ int SFTB_iii; \
+ \
+ 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)) \
+ { \
+ num_free++; \
+ } \
+ else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
+ { \
+ num_used++; \
+ } \
+ else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
+ { \
+ num_free++; \
+ FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
+ } \
+ else \
+ { \
+ num_used++; \
+ UNMARK_##typename (SFTB_victim); \
+ } \
+ } \
+ SFTB_prev = &(SFTB_current->prev); \
+ SFTB_current = SFTB_current->prev; \
+ SFTB_limit = countof (current_##typename##_block->block); \
+ } \
+ \
+ gc_count_num_##typename##_in_use = num_used; \
+ gc_count_num_##typename##_freelist = num_free; \
+} while (0)
-struct gcpro *gcprolist;
+#else /* !ERROR_CHECK_GC */
-/* 415 used Mly 29-Jun-93 */
-/* 1327 used slb 28-Feb-98 */
-#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;
+#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; \
+ \
+ typename##_free_list = 0; \
+ \
+ for (SFTB_prev = ¤t_##typename##_block, \
+ SFTB_current = current_##typename##_block, \
+ SFTB_limit = current_##typename##_block_index; \
+ SFTB_current; \
+ ) \
+ { \
+ int SFTB_iii; \
+ int SFTB_empty = 1; \
+ obj_type *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)) \
+ { \
+ num_free++; \
+ PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
+ } \
+ else if (C_READONLY_RECORD_HEADER_P (&SFTB_victim->lheader)) \
+ { \
+ SFTB_empty = 0; \
+ num_used++; \
+ } \
+ else if (!MARKED_RECORD_HEADER_P (&SFTB_victim->lheader)) \
+ { \
+ num_free++; \
+ FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
+ } \
+ else \
+ { \
+ SFTB_empty = 0; \
+ num_used++; \
+ UNMARK_##typename (SFTB_victim); \
+ } \
+ } \
+ if (!SFTB_empty) \
+ { \
+ SFTB_prev = &(SFTB_current->prev); \
+ SFTB_current = SFTB_current->prev; \
+ } \
+ else if (SFTB_current == current_##typename##_block \
+ && !SFTB_current->prev) \
+ { \
+ /* No real point in freeing sole allocation block */ \
+ break; \
+ } \
+ else \
+ { \
+ struct typename##_block *SFTB_victim_block = SFTB_current; \
+ if (SFTB_victim_block == current_##typename##_block) \
+ current_##typename##_block_index \
+ = countof (current_##typename##_block->block); \
+ SFTB_current = SFTB_current->prev; \
+ { \
+ *SFTB_prev = SFTB_current; \
+ xfree (SFTB_victim_block); \
+ /* Restore free list to what it was before victim was swept */ \
+ typename##_free_list = SFTB_old_free_list; \
+ num_free -= SFTB_limit; \
+ } \
+ } \
+ SFTB_limit = countof (current_##typename##_block->block); \
+ } \
+ \
+ gc_count_num_##typename##_in_use = num_used; \
+ gc_count_num_##typename##_freelist = num_free; \
+} while (0)
-/* 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;
-}
+#endif /* !ERROR_CHECK_GC */
\f
-/* Mark reference to a Lisp_Object. If the object referred to has not been
- seen yet, recursively mark all the references contained in it. */
+
static void
-mark_object (Lisp_Object obj)
+sweep_conses (void)
{
- tail_recurse:
-
-#ifdef ERROR_CHECK_GC
- assert (! (GC_EQ (obj, Qnull_pointer)));
-#endif
- /* Checks we used to perform */
- /* if (EQ (obj, Qnull_pointer)) return; */
- /* if (!POINTER_TYPE_P (XGCTYPE (obj))) return; */
- /* if (PURIFIED (XPNTR (obj))) return; */
-
- switch (XGCTYPE (obj))
- {
-#ifndef LRECORD_CONS
- case Lisp_Type_Cons:
- {
- struct Lisp_Cons *ptr = XCONS (obj);
- if (PURIFIED (ptr))
- break;
- if (CONS_MARKED_P (ptr))
- break;
- MARK_CONS (ptr);
- /* If the cdr is nil, tail-recurse on the car. */
- if (GC_NILP (ptr->cdr))
- {
- obj = ptr->car;
- }
- else
- {
- mark_object (ptr->car);
- obj = ptr->cdr;
- }
- goto tail_recurse;
- }
-#endif
+#define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
+#define ADDITIONAL_FREE_cons(ptr)
- case Lisp_Type_Record:
- {
- struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
- assert (lheader->type <= last_lrecord_type_index_assigned);
-#endif
- if (PURIFIED (lheader))
- return;
+ SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
+}
- if (! MARKED_RECORD_HEADER_P (lheader) &&
- ! UNMARKABLE_RECORD_HEADER_P (lheader))
- {
- CONST struct lrecord_implementation *implementation =
- LHEADER_IMPLEMENTATION (lheader);
- MARK_RECORD_HEADER (lheader);
+/* Explicitly free a cons cell. */
+void
+free_cons (struct Lisp_Cons *ptr)
+{
#ifdef ERROR_CHECK_GC
- if (!implementation->basic_p)
- assert (! ((struct lcrecord_header *) lheader)->free);
-#endif
- if (implementation->marker)
- {
- obj = implementation->marker (obj, mark_object);
- if (!GC_NILP (obj)) goto tail_recurse;
- }
- }
- }
- break;
-
-#ifndef LRECORD_STRING
- case Lisp_Type_String:
- {
- struct Lisp_String *ptr = XSTRING (obj);
- if (PURIFIED (ptr))
- return;
-
- if (!XMARKBIT (ptr->plist))
- {
- if (CONSP (ptr->plist) &&
- EXTENT_INFOP (XCAR (ptr->plist)))
- flush_cached_extent_info (XCAR (ptr->plist));
- XMARK (ptr->plist);
- obj = ptr->plist;
- goto tail_recurse;
- }
- }
- break;
-#endif /* ! LRECORD_STRING */
-
-#ifndef LRECORD_VECTOR
- case Lisp_Type_Vector:
- {
- struct Lisp_Vector *ptr = XVECTOR (obj);
- int len, i;
-
- if (PURIFIED (ptr))
- return;
-
- len = vector_length (ptr);
-
- if (len < 0)
- break; /* Already marked */
- ptr->size = -1 - len; /* Else mark it */
- for (i = 0; i < len - 1; i++) /* and then mark its elements */
- mark_object (ptr->contents[i]);
- if (len > 0)
- {
- obj = ptr->contents[len - 1];
- goto tail_recurse;
- }
- }
- break;
-#endif /* !LRECORD_VECTOR */
-
-#ifndef LRECORD_SYMBOL
- case Lisp_Type_Symbol:
- {
- struct Lisp_Symbol *sym = XSYMBOL (obj);
-
- if (PURIFIED (sym))
- return;
+ /* If the CAR is not an int, then it will be a pointer, which will
+ always be four-byte aligned. If this cons cell has already been
+ placed on the free list, however, its car will probably contain
+ a chain pointer to the next cons on the list, which has cleverly
+ had all its 0's and 1's inverted. This allows for a quick
+ check to make sure we're not freeing something already freed. */
+ if (POINTER_TYPE_P (XTYPE (ptr->car)))
+ ASSERT_VALID_POINTER (XPNTR (ptr->car));
+#endif /* ERROR_CHECK_GC */
- while (!XMARKBIT (sym->plist))
- {
- XMARK (sym->plist);
- mark_object (sym->value);
- mark_object (sym->function);
- {
- /*
- * symbol->name is a struct Lisp_String *, not a
- * Lisp_Object. Fix it up and pass to mark_object.
- */
- Lisp_Object symname;
- XSETSTRING (symname, sym->name);
- mark_object (symname);
- }
- if (!symbol_next (sym))
- {
- obj = sym->plist;
- goto tail_recurse;
- }
- mark_object (sym->plist);
- /* Mark the rest of the symbols in the hash-chain */
- sym = symbol_next (sym);
- }
- }
- break;
-#endif /* !LRECORD_SYMBOL */
-
- /* Check for invalid Lisp_Object types */
-#if defined (ERROR_CHECK_GC) && ! defined (USE_MINIMAL_TAGBITS)
- case Lisp_Type_Int:
- case Lisp_Type_Char:
- break;
- default:
- abort();
- break;
-#endif /* ERROR_CHECK_GC && ! USE_MINIMAL_TAGBITS */
- }
+#ifndef ALLOC_NO_POOLS
+ FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
+#endif /* ALLOC_NO_POOLS */
}
-/* mark all of the conses in a list and mark the final cdr; but
- DO NOT mark the cars.
+/* explicitly free a list. You **must make sure** that you have
+ created all the cons cells that make up this list and that there
+ are no pointers to any of these cons cells anywhere else. If there
+ are, you will lose. */
- Use only for internal lists! There should never be other pointers
- to the cons cells, because if so, the cars will remain unmarked
- even when they maybe should be marked. */
void
-mark_conses_in_list (Lisp_Object obj)
+free_list (Lisp_Object list)
{
- Lisp_Object rest;
+ Lisp_Object rest, next;
- for (rest = obj; CONSP (rest); rest = XCDR (rest))
+ for (rest = list; !NILP (rest); rest = next)
{
- if (CONS_MARKED_P (XCONS (rest)))
- return;
- MARK_CONS (XCONS (rest));
+ next = XCDR (rest);
+ free_cons (XCONS (rest));
}
-
- mark_object (rest);
}
-\f
-#ifdef PURESTAT
-/* Simpler than mark-object, because pure structure can't
- have any circularities */
+/* explicitly free an alist. You **must make sure** that you have
+ created all the cons cells that make up this alist and that there
+ are no pointers to any of these cons cells anywhere else. If there
+ are, you will lose. */
-static size_t
-pure_string_sizeof (Lisp_Object obj)
+void
+free_alist (Lisp_Object alist)
{
- struct Lisp_String *ptr = XSTRING (obj);
+ Lisp_Object rest, next;
- if (string_data (ptr) != (Bufbyte *) ptr + sizeof (*ptr))
- {
- /* string-data not allocated contiguously.
- Probably (better be!!) a pointer constant "C" data. */
- return sizeof (*ptr);
- }
- else
+ for (rest = alist; !NILP (rest); rest = next)
{
- size_t size = sizeof (*ptr) + string_length (ptr) + 1;
- size = ALIGN_SIZE (size, sizeof (Lisp_Object));
- return size;
+ next = XCDR (rest);
+ free_cons (XCONS (XCAR (rest)));
+ free_cons (XCONS (rest));
}
}
-static size_t
-pure_sizeof (Lisp_Object obj)
+static void
+sweep_compiled_functions (void)
{
- if (!POINTER_TYPE_P (XTYPE (obj))
- || !PURIFIED (XPNTR (obj)))
- return 0;
- /* symbol sizes are accounted for separately */
- else if (SYMBOLP (obj))
- return 0;
- else if (STRINGP (obj))
- return pure_string_sizeof (obj);
- else if (LRECORDP (obj))
- {
- struct lrecord_header *lheader = XRECORD_LHEADER (obj);
- CONST struct lrecord_implementation *implementation
- = LHEADER_IMPLEMENTATION (lheader);
+#define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
+#define ADDITIONAL_FREE_compiled_function(ptr)
- return implementation->size_in_bytes_method
- ? implementation->size_in_bytes_method (lheader)
- : implementation->static_size;
- }
-#ifndef LRECORD_VECTOR
- else if (VECTORP (obj))
- return STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, XVECTOR_LENGTH (obj));
-#endif /* !LRECORD_VECTOR */
-
-#ifndef LRECORD_CONS
- else if (CONSP (obj))
- return sizeof (struct Lisp_Cons);
-#endif /* !LRECORD_CONS */
- else
- /* Others can't be purified */
- abort ();
- return 0; /* unreached */
+ SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
}
-#endif /* PURESTAT */
-
-\f
-/* Find all structures not marked, and free them. */
-
-#ifndef LRECORD_VECTOR
-static int gc_count_num_vector_used, gc_count_vector_total_size;
-static int gc_count_vector_storage;
-#endif
-static int gc_count_num_bit_vector_used, gc_count_bit_vector_total_size;
-static int gc_count_bit_vector_storage;
-static int gc_count_num_short_string_in_use;
-static int gc_count_string_total_size;
-static int gc_count_short_string_total_size;
+#ifdef LISP_FLOAT_TYPE
+static void
+sweep_floats (void)
+{
+#define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
+#define ADDITIONAL_FREE_float(ptr)
-/* static int gc_count_total_records_used, gc_count_records_total_size; */
+ SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
+}
+#endif /* LISP_FLOAT_TYPE */
-\f
-int
-lrecord_type_index (CONST struct lrecord_implementation *implementation)
+static void
+sweep_symbols (void)
{
- 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;
-}
+#define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
+#define ADDITIONAL_FREE_symbol(ptr)
-/* stats on lcrecords in use - kinda kludgy */
+ SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
+}
-static struct
+static void
+sweep_extents (void)
{
- int instances_in_use;
- int bytes_in_use;
- int instances_freed;
- int bytes_freed;
- int instances_on_free_list;
-} lcrecord_stats [countof (lrecord_implementations_table)];
+#define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
+#define ADDITIONAL_FREE_extent(ptr)
+
+ SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
+}
static void
-tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p)
+sweep_events (void)
{
- CONST struct lrecord_implementation *implementation =
- LHEADER_IMPLEMENTATION (h);
- int type_index = lrecord_type_index (implementation);
-
- if (((struct lcrecord_header *) h)->free)
- {
- 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);
+#define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
+#define ADDITIONAL_FREE_event(ptr)
- if (free_p)
- {
- lcrecord_stats[type_index].instances_freed++;
- lcrecord_stats[type_index].bytes_freed += sz;
- }
- else
- {
- lcrecord_stats[type_index].instances_in_use++;
- lcrecord_stats[type_index].bytes_in_use += sz;
- }
- }
+ SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
}
-\f
-/* Free all unmarked records */
static void
-sweep_lcrecords_1 (struct lcrecord_header **prev, int *used)
+sweep_markers (void)
{
- struct lcrecord_header *header;
- int num_used = 0;
- /* int total_size = 0; */
-
- xzero (lcrecord_stats); /* Reset all statistics to 0. */
+#define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
+#define ADDITIONAL_FREE_marker(ptr) \
+ do { Lisp_Object tem; \
+ XSETMARKER (tem, ptr); \
+ unchain_marker (tem); \
+ } while (0)
- /* First go through and call all the finalize methods.
- Then go through and free the objects. There used to
- be only one loop here, with the call to the finalizer
- occurring directly before the xfree() below. That
- is marginally faster but much less safe -- if the
- finalize method for an object needs to reference any
- other objects contained within it (and many do),
- we could easily be screwed by having already freed that
- other object. */
+ SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
+}
- for (header = *prev; header; header = header->next)
- {
- struct lrecord_header *h = &(header->lheader);
- if (!MARKED_RECORD_HEADER_P (h) && ! (header->free))
- {
- if (LHEADER_IMPLEMENTATION (h)->finalizer)
- LHEADER_IMPLEMENTATION (h)->finalizer (h, 0);
- }
- }
+/* Explicitly free a marker. */
+void
+free_marker (struct 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 */
- for (header = *prev; header; )
- {
- struct lrecord_header *h = &(header->lheader);
- if (MARKED_RECORD_HEADER_P (h))
- {
- UNMARK_RECORD_HEADER (h);
- num_used++;
- /* total_size += n->implementation->size_in_bytes (h);*/
- prev = &(header->next);
- header = *prev;
- tick_lcrecord_stats (h, 0);
- }
- else
- {
- struct lcrecord_header *next = header->next;
- *prev = next;
- tick_lcrecord_stats (h, 1);
- /* used to call finalizer right here. */
- xfree (header);
- header = next;
- }
- }
- *used = num_used;
- /* *total = total_size; */
+#ifndef ALLOC_NO_POOLS
+ FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
+#endif /* ALLOC_NO_POOLS */
}
+\f
-#ifndef LRECORD_VECTOR
+#if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
static void
-sweep_vectors_1 (Lisp_Object *prev,
- int *used, int *total, int *storage)
+verify_string_chars_integrity (void)
{
- Lisp_Object vector;
- int num_used = 0;
- int total_size = 0;
- int total_storage = 0;
+ struct string_chars_block *sb;
- for (vector = *prev; VECTORP (vector); )
+ /* Scan each existing string block sequentially, string by string. */
+ for (sb = first_string_chars_block; sb; sb = sb->next)
{
- Lisp_Vector *v = XVECTOR (vector);
- int len = v->size;
- if (len < 0) /* marked */
- {
- len = - (len + 1);
- v->size = len;
- total_size += len;
- total_storage +=
- MALLOC_OVERHEAD +
- STRETCHY_STRUCT_SIZEOF (Lisp_Vector, contents, len + 1);
- num_used++;
- prev = &(vector_next (v));
- vector = *prev;
- }
- else
- {
- Lisp_Object next = vector_next (v);
- *prev = next;
- xfree (v);
- vector = next;
- }
+ int pos = 0;
+ /* POS is the index of the next string in the block. */
+ while (pos < sb->pos)
+ {
+ struct string_chars *s_chars =
+ (struct string_chars *) &(sb->string_chars[pos]);
+ struct Lisp_String *string;
+ int size;
+ int fullsize;
+
+ /* 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 (FREE_STRUCT_P (s_chars))
+ {
+ fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
+ pos += fullsize;
+ continue;
+ }
+
+ string = s_chars->string;
+ /* Must be 32-bit aligned. */
+ assert ((((int) string) & 3) == 0);
+
+ size = string_length (string);
+ fullsize = STRING_FULLSIZE (size);
+
+ assert (!BIG_STRING_FULLSIZE_P (fullsize));
+ assert (string_data (string) == s_chars->chars);
+ pos += fullsize;
+ }
+ assert (pos == sb->pos);
}
- *used = num_used;
- *total = total_size;
- *storage = total_storage;
}
-#endif /* ! LRECORD_VECTOR */
+#endif /* MULE && ERROR_CHECK_GC */
+/* Compactify string chars, relocating the reference to each --
+ free any empty string_chars_block we see. */
static void
-sweep_bit_vectors_1 (Lisp_Object *prev,
- int *used, int *total, int *storage)
+compact_string_chars (void)
{
- Lisp_Object bit_vector;
- int num_used = 0;
- int total_size = 0;
- int total_storage = 0;
+ struct string_chars_block *to_sb = first_string_chars_block;
+ int to_pos = 0;
+ struct string_chars_block *from_sb;
- /* BIT_VECTORP fails because the objects are marked, which changes
- their implementation */
- for (bit_vector = *prev; !EQ (bit_vector, Qzero); )
- {
- Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector);
- int len = v->size;
- if (MARKED_RECORD_P (bit_vector))
- {
- UNMARK_RECORD_HEADER (&(v->lheader));
- total_size += len;
- total_storage +=
- MALLOC_OVERHEAD +
- STRETCHY_STRUCT_SIZEOF (Lisp_Bit_Vector, bits,
- BIT_VECTOR_LONG_STORAGE (len));
- num_used++;
- prev = &(bit_vector_next (v));
- bit_vector = *prev;
- }
- else
- {
- Lisp_Object next = bit_vector_next (v);
- *prev = next;
- xfree (v);
- bit_vector = next;
- }
- }
- *used = num_used;
- *total = total_size;
- *storage = total_storage;
-}
+ /* Scan each existing string block sequentially, string by string. */
+ for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
+ {
+ int from_pos = 0;
+ /* FROM_POS is the index of the next string in the block. */
+ while (from_pos < from_sb->pos)
+ {
+ struct string_chars *from_s_chars =
+ (struct string_chars *) &(from_sb->string_chars[from_pos]);
+ struct string_chars *to_s_chars;
+ struct Lisp_String *string;
+ int size;
+ int fullsize;
-/* And the Lord said: Thou shalt use the `c-backslash-region' command
- to make macros prettier. */
+ /* 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. */
-#ifdef ERROR_CHECK_GC
+ if (FREE_STRUCT_P (from_s_chars))
+ {
+ fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
+ from_pos += fullsize;
+ continue;
+ }
-#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, \
- SFTB_limit = current_##typename##_block_index; \
- SFTB_current; \
- ) \
- { \
- int SFTB_iii; \
- \
- 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)) \
- { \
- num_free++; \
- } \
- else if (!MARKED_##typename##_P (SFTB_victim)) \
- { \
- num_free++; \
- FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
- } \
- else \
- { \
- num_used++; \
- UNMARK_##typename (SFTB_victim); \
- } \
- } \
- SFTB_prev = &(SFTB_current->prev); \
- SFTB_current = SFTB_current->prev; \
- SFTB_limit = countof (current_##typename##_block->block); \
- } \
- \
- gc_count_num_##typename##_in_use = num_used; \
- gc_count_num_##typename##_freelist = num_free; \
-} while (0)
+ string = from_s_chars->string;
+ assert (!(FREE_STRUCT_P (string)));
-#else /* !ERROR_CHECK_GC */
+ size = string_length (string);
+ fullsize = STRING_FULLSIZE (size);
-#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; \
- \
- typename##_free_list = 0; \
- \
- for (SFTB_prev = ¤t_##typename##_block, \
- SFTB_current = current_##typename##_block, \
- SFTB_limit = current_##typename##_block_index; \
- SFTB_current; \
- ) \
- { \
- int SFTB_iii; \
- int SFTB_empty = 1; \
- obj_type *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)) \
- { \
- num_free++; \
- PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \
- } \
- else if (!MARKED_##typename##_P (SFTB_victim)) \
- { \
- num_free++; \
- FREE_FIXED_TYPE (typename, obj_type, SFTB_victim); \
- } \
- else \
- { \
- SFTB_empty = 0; \
- num_used++; \
- UNMARK_##typename (SFTB_victim); \
- } \
- } \
- if (!SFTB_empty) \
- { \
- SFTB_prev = &(SFTB_current->prev); \
- SFTB_current = SFTB_current->prev; \
- } \
- else if (SFTB_current == current_##typename##_block \
- && !SFTB_current->prev) \
- { \
- /* No real point in freeing sole allocation block */ \
- break; \
- } \
- else \
- { \
- struct typename##_block *SFTB_victim_block = SFTB_current; \
- if (SFTB_victim_block == current_##typename##_block) \
- current_##typename##_block_index \
- = countof (current_##typename##_block->block); \
- SFTB_current = SFTB_current->prev; \
- { \
- *SFTB_prev = SFTB_current; \
- xfree (SFTB_victim_block); \
- /* Restore free list to what it was before victim was swept */ \
- typename##_free_list = SFTB_old_free_list; \
- num_free -= SFTB_limit; \
- } \
- } \
- SFTB_limit = countof (current_##typename##_block->block); \
- } \
- \
- gc_count_num_##typename##_in_use = num_used; \
- gc_count_num_##typename##_freelist = num_free; \
-} while (0)
+ if (BIG_STRING_FULLSIZE_P (fullsize))
+ abort ();
-#endif /* !ERROR_CHECK_GC */
+ /* Just skip it if it isn't marked. */
+ if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
+ {
+ from_pos += fullsize;
+ continue;
+ }
-\f
+ /* If it won't fit in what's left of TO_SB, close TO_SB out
+ and go on to the next string_chars_block. We know that TO_SB
+ cannot advance past FROM_SB here since FROM_SB is large enough
+ to currently contain this string. */
+ if ((to_pos + fullsize) > countof (to_sb->string_chars))
+ {
+ to_sb->pos = to_pos;
+ to_sb = to_sb->next;
+ to_pos = 0;
+ }
+
+ /* Compute new address of this string
+ and update TO_POS for the space being used. */
+ to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
+ /* Copy the string_chars to the new place. */
+ if (from_s_chars != to_s_chars)
+ memmove (to_s_chars, from_s_chars, fullsize);
-static void
-sweep_conses (void)
-{
-#ifndef LRECORD_CONS
-# define MARKED_cons_P(ptr) XMARKBIT ((ptr)->car)
-# define UNMARK_cons(ptr) do { XUNMARK ((ptr)->car); } while (0)
-#else /* LRECORD_CONS */
-# define MARKED_cons_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-# define UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
-#endif /* LRECORD_CONS */
-#define ADDITIONAL_FREE_cons(ptr)
+ /* Relocate FROM_S_CHARS's reference */
+ set_string_data (string, &(to_s_chars->chars[0]));
- SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons);
+ from_pos += fullsize;
+ to_pos += fullsize;
+ }
+ }
+
+ /* Set current to the last string chars block still used and
+ free any that follow. */
+ {
+ struct string_chars_block *victim;
+
+ for (victim = to_sb->next; victim; )
+ {
+ struct string_chars_block *next = victim->next;
+ xfree (victim);
+ victim = next;
+ }
+
+ current_string_chars_block = to_sb;
+ current_string_chars_block->pos = to_pos;
+ current_string_chars_block->next = 0;
+ }
}
-/* Explicitly free a cons cell. */
-void
-free_cons (struct Lisp_Cons *ptr)
-{
-#ifdef ERROR_CHECK_GC
- /* If the CAR is not an int, then it will be a pointer, which will
- always be four-byte aligned. If this cons cell has already been
- placed on the free list, however, its car will probably contain
- a chain pointer to the next cons on the list, which has cleverly
- had all its 0's and 1's inverted. This allows for a quick
- check to make sure we're not freeing something already freed. */
- if (POINTER_TYPE_P (XTYPE (ptr->car)))
- ASSERT_VALID_POINTER (XPNTR (ptr->car));
-#endif /* ERROR_CHECK_GC */
+#if 1 /* Hack to debug missing purecopy's */
+static int debug_string_purity;
-#ifndef ALLOC_NO_POOLS
- FREE_FIXED_TYPE_WHEN_NOT_IN_GC (cons, struct Lisp_Cons, ptr);
-#endif /* ALLOC_NO_POOLS */
+static void
+debug_string_purity_print (struct Lisp_String *p)
+{
+ Charcount i;
+ Charcount s = string_char_length (p);
+ putc ('\"', stderr);
+ for (i = 0; i < s; i++)
+ {
+ Emchar ch = string_char (p, i);
+ if (ch < 32 || ch >= 126)
+ stderr_out ("\\%03o", ch);
+ else if (ch == '\\' || ch == '\"')
+ stderr_out ("\\%c", ch);
+ else
+ stderr_out ("%c", ch);
+ }
+ stderr_out ("\"\n");
}
+#endif /* 1 */
-/* explicitly free a list. You **must make sure** that you have
- created all the cons cells that make up this list and that there
- are no pointers to any of these cons cells anywhere else. If there
- are, you will lose. */
-void
-free_list (Lisp_Object list)
+static void
+sweep_strings (void)
{
- Lisp_Object rest, next;
+ int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
+ int debug = debug_string_purity;
- for (rest = list; !NILP (rest); rest = next)
- {
- next = XCDR (rest);
- free_cons (XCONS (rest));
- }
+#define UNMARK_string(ptr) \
+ do { struct Lisp_String *p = (ptr); \
+ int size = string_length (p); \
+ UNMARK_RECORD_HEADER (&(p->lheader)); \
+ num_bytes += size; \
+ if (!BIG_STRING_SIZE_P (size)) \
+ { num_small_bytes += size; \
+ num_small_used++; \
+ } \
+ if (debug) debug_string_purity_print (p); \
+ } while (0)
+#define ADDITIONAL_FREE_string(p) \
+ do { int size = string_length (p); \
+ if (BIG_STRING_SIZE_P (size)) \
+ xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
+ } while (0)
+
+ SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
+
+ gc_count_num_short_string_in_use = num_small_used;
+ gc_count_string_total_size = num_bytes;
+ gc_count_short_string_total_size = num_small_bytes;
}
-/* explicitly free an alist. You **must make sure** that you have
- created all the cons cells that make up this alist and that there
- are no pointers to any of these cons cells anywhere else. If there
- are, you will lose. */
-void
-free_alist (Lisp_Object alist)
+/* I hate duplicating all this crap! */
+int
+marked_p (Lisp_Object obj)
{
- Lisp_Object rest, next;
+#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 (PURIFIED (XPNTR (obj))) return 1; */
- for (rest = alist; !NILP (rest); rest = next)
+ if (XTYPE (obj) == Lisp_Type_Record)
{
- next = XCDR (rest);
- free_cons (XCONS (XCAR (rest)));
- free_cons (XCONS (rest));
+ 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);
}
+ return 1;
}
static void
-sweep_compiled_functions (void)
+gc_sweep (void)
{
-#define MARKED_compiled_function_P(ptr) \
- MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-#define UNMARK_compiled_function(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
-#define ADDITIONAL_FREE_compiled_function(ptr)
+ /* Free all unmarked records. Do this at the very beginning,
+ before anything else, so that the finalize methods can safely
+ examine items in the objects. sweep_lcrecords_1() makes
+ sure to call all the finalize methods *before* freeing anything,
+ to complete the safety. */
+ {
+ int ignored;
+ sweep_lcrecords_1 (&all_lcrecords, &ignored);
+ }
- SWEEP_FIXED_TYPE_BLOCK (compiled_function, Lisp_Compiled_Function);
-}
+ compact_string_chars ();
+ /* Finalize methods below (called through the ADDITIONAL_FREE_foo
+ macros) must be *extremely* careful to make sure they're not
+ referencing freed objects. The only two existing finalize
+ methods (for strings and markers) pass muster -- the string
+ finalizer doesn't look at anything but its own specially-
+ created block, and the marker finalizer only looks at live
+ buffers (which will never be freed) and at the markers before
+ and after it in the chain (which, by induction, will never be
+ freed because if so, they would have already removed themselves
+ from the chain). */
-#ifdef LISP_FLOAT_TYPE
-static void
-sweep_floats (void)
-{
-#define MARKED_float_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-#define UNMARK_float(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
-#define ADDITIONAL_FREE_float(ptr)
+ /* Put all unmarked strings on free list, free'ing the string chars
+ of large unmarked strings */
+ sweep_strings ();
- SWEEP_FIXED_TYPE_BLOCK (float, struct Lisp_Float);
-}
-#endif /* LISP_FLOAT_TYPE */
+ /* Put all unmarked conses on free list */
+ sweep_conses ();
-static void
-sweep_symbols (void)
-{
-#ifndef LRECORD_SYMBOL
-# define MARKED_symbol_P(ptr) XMARKBIT ((ptr)->plist)
-# define UNMARK_symbol(ptr) do { XUNMARK ((ptr)->plist); } while (0)
-#else
-# define MARKED_symbol_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-# define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
-#endif /* !LRECORD_SYMBOL */
-#define ADDITIONAL_FREE_symbol(ptr)
+ /* Free all unmarked bit vectors */
+ sweep_bit_vectors_1 (&all_bit_vectors,
+ &gc_count_num_bit_vector_used,
+ &gc_count_bit_vector_total_size,
+ &gc_count_bit_vector_storage);
- SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol);
-}
+ /* Free all unmarked compiled-function objects */
+ sweep_compiled_functions ();
-static void
-sweep_extents (void)
-{
-#define MARKED_extent_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-#define UNMARK_extent(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
-#define ADDITIONAL_FREE_extent(ptr)
+#ifdef LISP_FLOAT_TYPE
+ /* Put all unmarked floats on free list */
+ sweep_floats ();
+#endif
- SWEEP_FIXED_TYPE_BLOCK (extent, struct extent);
-}
+ /* Put all unmarked symbols on free list */
+ sweep_symbols ();
-static void
-sweep_events (void)
-{
-#define MARKED_event_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-#define UNMARK_event(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
-#define ADDITIONAL_FREE_event(ptr)
+ /* Put all unmarked extents on free list */
+ sweep_extents ();
- SWEEP_FIXED_TYPE_BLOCK (event, struct Lisp_Event);
-}
+ /* Put all unmarked markers on free list.
+ Dechain each one first from the buffer into which it points. */
+ sweep_markers ();
-static void
-sweep_markers (void)
-{
-#define MARKED_marker_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-#define UNMARK_marker(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader))
-#define ADDITIONAL_FREE_marker(ptr) \
- do { Lisp_Object tem; \
- XSETMARKER (tem, ptr); \
- unchain_marker (tem); \
- } while (0)
+ sweep_events ();
- SWEEP_FIXED_TYPE_BLOCK (marker, struct Lisp_Marker);
+#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;
+ }
+ }
+#endif
}
+\f
+/* Clearing for disksave. */
-/* Explicitly free a marker. */
void
-free_marker (struct Lisp_Marker *ptr)
+disksave_object_finalization (void)
{
-#ifdef ERROR_CHECK_GC
- /* Perhaps this will catch freeing an already-freed marker. */
- Lisp_Object temmy;
- XSETMARKER (temmy, ptr);
- assert (GC_MARKERP (temmy));
-#endif /* ERROR_CHECK_GC */
+ /* It's important that certain information from the environment not get
+ dumped with the executable (pathnames, environment variables, etc.).
+ To make it easier to tell when this has happened with strings(1) we
+ clear some known-to-be-garbage blocks of memory, so that leftover
+ results of old evaluation don't look like potential problems.
+ But first we set some notable variables to nil and do one more GC,
+ to turn those strings into garbage.
+ */
+
+ /* Yeah, this list is pretty ad-hoc... */
+ Vprocess_environment = Qnil;
+ Vexec_directory = Qnil;
+ Vdata_directory = Qnil;
+ Vsite_directory = Qnil;
+ Vdoc_directory = Qnil;
+ Vconfigure_info_directory = Qnil;
+ Vexec_path = Qnil;
+ Vload_path = Qnil;
+ /* Vdump_load_path = Qnil; */
+ /* Release hash tables for locate_file */
+ Flocate_file_clear_hashing (Qt);
+ uncache_home_directory();
+
+#if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
+ defined(LOADHIST_BUILTIN))
+ Vload_history = Qnil;
+#endif
+ Vshell_file_name = Qnil;
+
+ garbage_collect_1 ();
+
+ /* Run the disksave finalization methods of all live objects. */
+ disksave_object_finalization_1 ();
+
+ /* Zero out the uninitialized (really, unused) part of the containers
+ for the live strings. */
+ {
+ struct string_chars_block *scb;
+ for (scb = first_string_chars_block; scb; scb = scb->next)
+ {
+ int count = sizeof (scb->string_chars) - scb->pos;
+
+ assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
+ if (count != 0) {
+ /* from the block's fill ptr to the end */
+ memset ((scb->string_chars + scb->pos), 0, count);
+ }
+ }
+ }
+
+ /* There, that ought to be enough... */
-#ifndef ALLOC_NO_POOLS
- FREE_FIXED_TYPE_WHEN_NOT_IN_GC (marker, struct Lisp_Marker, ptr);
-#endif /* ALLOC_NO_POOLS */
}
+
\f
+Lisp_Object
+restore_gc_inhibit (Lisp_Object val)
+{
+ gc_currently_forbidden = XINT (val);
+ return val;
+}
-#if defined (MULE) && defined (VERIFY_STRING_CHARS_INTEGRITY)
+/* Maybe we want to use this when doing a "panic" gc after memory_full()? */
+static int gc_hooks_inhibited;
-static void
-verify_string_chars_integrity (void)
+\f
+void
+garbage_collect_1 (void)
{
- struct string_chars_block *sb;
-
- /* Scan each existing string block sequentially, string by string. */
- for (sb = first_string_chars_block; sb; sb = sb->next)
- {
- int pos = 0;
- /* POS is the index of the next string in the block. */
- while (pos < sb->pos)
- {
- struct string_chars *s_chars =
- (struct string_chars *) &(sb->string_chars[pos]);
- struct Lisp_String *string;
- int size;
- int fullsize;
+#if MAX_SAVE_STACK > 0
+ char stack_top_variable;
+ extern char *stack_bottom;
+#endif
+ struct frame *f;
+ int speccount;
+ int cursor_changed;
+ Lisp_Object pre_gc_cursor;
+ struct gcpro gcpro1;
- /* 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 (gc_in_progress
+ || gc_currently_forbidden
+ || in_display
+ || preparing_for_armageddon)
+ return;
- if (FREE_STRUCT_P (s_chars))
- {
- fullsize = ((struct unused_string_chars *) s_chars)->fullsize;
- pos += fullsize;
- continue;
- }
+ /* We used to call selected_frame() here.
- string = s_chars->string;
- /* Must be 32-bit aligned. */
- assert ((((int) string) & 3) == 0);
+ The following functions cannot be called inside GC
+ so we move to after the above tests. */
+ {
+ Lisp_Object frame;
+ Lisp_Object device = Fselected_device (Qnil);
+ if (NILP (device)) /* Could happen during startup, eg. if always_gc */
+ return;
+ frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
+ if (NILP (frame))
+ signal_simple_error ("No frames exist on device", device);
+ f = XFRAME (frame);
+ }
- size = string_length (string);
- fullsize = STRING_FULLSIZE (size);
+ pre_gc_cursor = Qnil;
+ cursor_changed = 0;
- assert (!BIG_STRING_FULLSIZE_P (fullsize));
- assert (string_data (string) == s_chars->chars);
- pos += fullsize;
- }
- assert (pos == sb->pos);
- }
-}
+ GCPRO1 (pre_gc_cursor);
-#endif /* MULE && ERROR_CHECK_GC */
+ /* Very important to prevent GC during any of the following
+ stuff that might run Lisp code; otherwise, we'll likely
+ have infinite GC recursion. */
+ speccount = specpdl_depth ();
+ record_unwind_protect (restore_gc_inhibit,
+ make_int (gc_currently_forbidden));
+ gc_currently_forbidden = 1;
-/* Compactify string chars, relocating the reference to each --
- free any empty string_chars_block we see. */
-static void
-compact_string_chars (void)
-{
- struct string_chars_block *to_sb = first_string_chars_block;
- int to_pos = 0;
- struct string_chars_block *from_sb;
+ if (!gc_hooks_inhibited)
+ run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
- /* Scan each existing string block sequentially, string by string. */
- for (from_sb = first_string_chars_block; from_sb; from_sb = from_sb->next)
+ /* Now show the GC cursor/message. */
+ if (!noninteractive)
{
- int from_pos = 0;
- /* FROM_POS is the index of the next string in the block. */
- while (from_pos < from_sb->pos)
- {
- struct string_chars *from_s_chars =
- (struct string_chars *) &(from_sb->string_chars[from_pos]);
- struct string_chars *to_s_chars;
- struct Lisp_String *string;
- int size;
- int fullsize;
+ if (FRAME_WIN_P (f))
+ {
+ Lisp_Object frame = make_frame (f);
+ Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
+ FRAME_SELECTED_WINDOW (f),
+ ERROR_ME_NOT, 1);
+ pre_gc_cursor = f->pointer;
+ if (POINTER_IMAGE_INSTANCEP (cursor)
+ /* don't change if we don't know how to change back. */
+ && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
+ {
+ cursor_changed = 1;
+ Fset_frame_pointer (frame, cursor);
+ }
+ }
- /* 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. */
+ /* Don't print messages to the stream device. */
+ if (!cursor_changed && !FRAME_STREAM_P (f))
+ {
+ char *msg = (STRINGP (Vgc_message)
+ ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
+ : 0);
+ Lisp_Object args[2], whole_msg;
+ args[0] = build_string (msg ? msg :
+ GETTEXT ((CONST char *) gc_default_message));
+ args[1] = build_string ("...");
+ whole_msg = Fconcat (2, args);
+ echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
+ Qgarbage_collecting);
+ }
+ }
- if (FREE_STRUCT_P (from_s_chars))
- {
- fullsize = ((struct unused_string_chars *) from_s_chars)->fullsize;
- from_pos += fullsize;
- continue;
- }
+ /***** Now we actually start the garbage collection. */
- string = from_s_chars->string;
- assert (!(FREE_STRUCT_P (string)));
+ gc_in_progress = 1;
- size = string_length (string);
- fullsize = STRING_FULLSIZE (size);
+ gc_generation_number[0]++;
- if (BIG_STRING_FULLSIZE_P (fullsize))
- abort ();
+#if MAX_SAVE_STACK > 0
- /* Just skip it if it isn't marked. */
-#ifdef LRECORD_STRING
- if (! MARKED_RECORD_HEADER_P (&(string->lheader)))
-#else
- if (!XMARKBIT (string->plist))
-#endif
- {
- from_pos += fullsize;
- continue;
- }
+ /* Save a copy of the contents of the stack, for debugging. */
+ if (!purify_flag)
+ {
+ /* Static buffer in which we save a copy of the C stack at each GC. */
+ static char *stack_copy;
+ static size_t stack_copy_size;
- /* If it won't fit in what's left of TO_SB, close TO_SB out
- and go on to the next string_chars_block. We know that TO_SB
- cannot advance past FROM_SB here since FROM_SB is large enough
- to currently contain this string. */
- if ((to_pos + fullsize) > countof (to_sb->string_chars))
- {
- to_sb->pos = to_pos;
- to_sb = to_sb->next;
- to_pos = 0;
- }
+ ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
+ size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
+ if (stack_size < MAX_SAVE_STACK)
+ {
+ if (stack_copy_size < stack_size)
+ {
+ stack_copy = (char *) xrealloc (stack_copy, stack_size);
+ stack_copy_size = stack_size;
+ }
- /* Compute new address of this string
- and update TO_POS for the space being used. */
- to_s_chars = (struct string_chars *) &(to_sb->string_chars[to_pos]);
+ memcpy (stack_copy,
+ stack_diff > 0 ? stack_bottom : &stack_top_variable,
+ stack_size);
+ }
+ }
+#endif /* MAX_SAVE_STACK > 0 */
- /* Copy the string_chars to the new place. */
- if (from_s_chars != to_s_chars)
- memmove (to_s_chars, from_s_chars, fullsize);
+ /* Do some totally ad-hoc resource clearing. */
+ /* #### generalize this? */
+ clear_event_resource ();
+ cleanup_specifiers ();
- /* Relocate FROM_S_CHARS's reference */
- set_string_data (string, &(to_s_chars->chars[0]));
+ /* Mark all the special slots that serve as the roots of accessibility. */
- from_pos += fullsize;
- to_pos += fullsize;
- }
- }
+ { /* 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]));
+ }
- /* Set current to the last string chars block still used and
- free any that follow. */
- {
- struct string_chars_block *victim;
+ { /* GCPRO() */
+ struct gcpro *tail;
+ int i;
+ for (tail = gcprolist; tail; tail = tail->next)
+ for (i = 0; i < tail->nvars; i++)
+ mark_object (tail->var[i]);
+ }
- for (victim = to_sb->next; victim; )
+ { /* specbind() */
+ struct specbinding *bind;
+ for (bind = specpdl; bind != specpdl_ptr; bind++)
{
- struct string_chars_block *next = victim->next;
- xfree (victim);
- victim = next;
+ mark_object (bind->symbol);
+ mark_object (bind->old_value);
}
-
- current_string_chars_block = to_sb;
- current_string_chars_block->pos = to_pos;
- current_string_chars_block->next = 0;
}
-}
-
-#if 1 /* Hack to debug missing purecopy's */
-static int debug_string_purity;
-static void
-debug_string_purity_print (struct Lisp_String *p)
-{
- Charcount i;
- Charcount s = string_char_length (p);
- putc ('\"', stderr);
- for (i = 0; i < s; i++)
{
- Emchar ch = string_char (p, i);
- if (ch < 32 || ch >= 126)
- stderr_out ("\\%03o", ch);
- else if (ch == '\\' || ch == '\"')
- stderr_out ("\\%c", ch);
- else
- stderr_out ("%c", ch);
+ struct catchtag *catch;
+ for (catch = catchlist; catch; catch = catch->next)
+ {
+ mark_object (catch->tag);
+ mark_object (catch->val);
+ }
}
- stderr_out ("\"\n");
-}
-#endif /* 1 */
+ {
+ struct backtrace *backlist;
+ for (backlist = backtrace_list; backlist; backlist = backlist->next)
+ {
+ int nargs = backlist->nargs;
+ int i;
-static void
-sweep_strings (void)
-{
- int num_small_used = 0, num_small_bytes = 0, num_bytes = 0;
- int debug = debug_string_purity;
+ mark_object (*backlist->function);
+ if (nargs == UNEVALLED || nargs == MANY)
+ mark_object (backlist->args[0]);
+ else
+ for (i = 0; i < nargs; i++)
+ mark_object (backlist->args[i]);
+ }
+ }
-#ifdef LRECORD_STRING
+ mark_redisplay ();
+ mark_profiling_info ();
-# define MARKED_string_P(ptr) MARKED_RECORD_HEADER_P (&((ptr)->lheader))
-# define UNMARK_string(ptr) \
- do { struct Lisp_String *p = (ptr); \
- int size = string_length (p); \
- UNMARK_RECORD_HEADER (&(p->lheader)); \
- num_bytes += size; \
- if (!BIG_STRING_SIZE_P (size)) \
- { num_small_bytes += size; \
- num_small_used++; \
- } \
- if (debug) debug_string_purity_print (p); \
- } while (0)
-# define ADDITIONAL_FREE_string(p) \
- do { int size = string_length (p); \
- if (BIG_STRING_SIZE_P (size)) \
- xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
- } while (0)
+ /* OK, now do the after-mark stuff. This is for things that
+ are only marked when something else is marked (e.g. weak hash tables).
+ There may be complex dependencies between such objects -- e.g.
+ a weak hash table might be unmarked, but after processing a later
+ weak hash table, the former one might get marked. So we have to
+ iterate until nothing more gets marked. */
-#else
+ while (finish_marking_weak_hash_tables () > 0 ||
+ finish_marking_weak_lists () > 0)
+ ;
-# define MARKED_string_P(ptr) XMARKBIT ((ptr)->plist)
-# define UNMARK_string(ptr) \
- do { struct Lisp_String *p = (ptr); \
- int size = string_length (p); \
- XUNMARK (p->plist); \
- num_bytes += size; \
- if (!BIG_STRING_SIZE_P (size)) \
- { num_small_bytes += size; \
- num_small_used++; \
- } \
- if (debug) debug_string_purity_print (p); \
- } while (0)
-# define ADDITIONAL_FREE_string(p) \
- do { int size = string_length (p); \
- if (BIG_STRING_SIZE_P (size)) \
- xfree_1 (CHARS_TO_STRING_CHAR (string_data (p))); \
- } while (0)
+ /* And prune (this needs to be called after everything else has been
+ marked and before we do any sweeping). */
+ /* #### this is somewhat ad-hoc and should probably be an object
+ method */
+ prune_weak_hash_tables ();
+ prune_weak_lists ();
+ prune_specifiers ();
+ prune_syntax_tables ();
-#endif /* ! LRECORD_STRING */
+ gc_sweep ();
- SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String);
+ consing_since_gc = 0;
+#ifndef DEBUG_XEMACS
+ /* Allow you to set it really fucking low if you really want ... */
+ if (gc_cons_threshold < 10000)
+ gc_cons_threshold = 10000;
+#endif
- gc_count_num_short_string_in_use = num_small_used;
- gc_count_string_total_size = num_bytes;
- gc_count_short_string_total_size = num_small_bytes;
-}
+ gc_in_progress = 0;
+ /******* End of garbage collection ********/
-/* I hate duplicating all this crap! */
-static int
-marked_p (Lisp_Object obj)
-{
-#ifdef ERROR_CHECK_GC
- assert (! (GC_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 (PURIFIED (XPNTR (obj))) return 1; */
+ run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
- switch (XGCTYPE (obj))
+ /* Now remove the GC cursor/message */
+ if (!noninteractive)
{
-#ifndef LRECORD_CONS
- case Lisp_Type_Cons:
- {
- struct Lisp_Cons *ptr = XCONS (obj);
- return PURIFIED (ptr) || XMARKBIT (ptr->car);
- }
-#endif
- case Lisp_Type_Record:
- {
- struct lrecord_header *lheader = XRECORD_LHEADER (obj);
-#if defined (ERROR_CHECK_GC) && defined (USE_INDEXED_LRECORD_IMPLEMENTATION)
- assert (lheader->type <= last_lrecord_type_index_assigned);
-#endif
- return PURIFIED (lheader) || MARKED_RECORD_HEADER_P (lheader);
- }
-#ifndef LRECORD_STRING
- case Lisp_Type_String:
- {
- struct Lisp_String *ptr = XSTRING (obj);
- return PURIFIED (ptr) || XMARKBIT (ptr->plist);
- }
-#endif /* ! LRECORD_STRING */
-#ifndef LRECORD_VECTOR
- case Lisp_Type_Vector:
- {
- struct Lisp_Vector *ptr = XVECTOR (obj);
- return PURIFIED (ptr) || vector_length (ptr) < 0;
- }
-#endif /* !LRECORD_VECTOR */
-#ifndef LRECORD_SYMBOL
- case Lisp_Type_Symbol:
- {
- struct Lisp_Symbol *ptr = XSYMBOL (obj);
- return PURIFIED (ptr) || XMARKBIT (ptr->plist);
- }
-#endif
+ if (cursor_changed)
+ Fset_frame_pointer (make_frame (f), pre_gc_cursor);
+ else if (!FRAME_STREAM_P (f))
+ {
+ char *msg = (STRINGP (Vgc_message)
+ ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
+ : 0);
- /* Ints and Chars don't need GC */
-#if defined (USE_MINIMAL_TAGBITS) || ! defined (ERROR_CHECK_GC)
- default:
- return 1;
-#else
- default:
- abort();
- case Lisp_Type_Int:
- case Lisp_Type_Char:
- return 1;
-#endif
+ /* Show "...done" only if the echo area would otherwise be empty. */
+ if (NILP (clear_echo_area (selected_frame (),
+ Qgarbage_collecting, 0)))
+ {
+ Lisp_Object args[2], whole_msg;
+ args[0] = build_string (msg ? msg :
+ GETTEXT ((CONST char *)
+ gc_default_message));
+ args[1] = build_string ("... done");
+ whole_msg = Fconcat (2, args);
+ echo_area_message (selected_frame (), (Bufbyte *) 0,
+ whole_msg, 0, -1,
+ Qgarbage_collecting);
+ }
+ }
}
-}
-static void
-gc_sweep (void)
-{
- /* Free all unmarked records. Do this at the very beginning,
- before anything else, so that the finalize methods can safely
- examine items in the objects. sweep_lcrecords_1() makes
- sure to call all the finalize methods *before* freeing anything,
- to complete the safety. */
- {
- int ignored;
- sweep_lcrecords_1 (&all_lcrecords, &ignored);
- }
+ /* now stop inhibiting GC */
+ unbind_to (speccount, Qnil);
- compact_string_chars ();
+ if (!breathing_space)
+ {
+ breathing_space = malloc (4096 - MALLOC_OVERHEAD);
+ }
- /* Finalize methods below (called through the ADDITIONAL_FREE_foo
- macros) must be *extremely* careful to make sure they're not
- referencing freed objects. The only two existing finalize
- methods (for strings and markers) pass muster -- the string
- finalizer doesn't look at anything but its own specially-
- created block, and the marker finalizer only looks at live
- buffers (which will never be freed) and at the markers before
- and after it in the chain (which, by induction, will never be
- freed because if so, they would have already removed themselves
- from the chain). */
+ UNGCPRO;
+ return;
+}
- /* Put all unmarked strings on free list, free'ing the string chars
- of large unmarked strings */
- sweep_strings ();
+/* Debugging aids. */
- /* Put all unmarked conses on free list */
- sweep_conses ();
+static Lisp_Object
+gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
+{
+ /* C doesn't have local functions (or closures, or GC, or readable syntax,
+ or portable numeric datatypes, or bit-vectors, or characters, or
+ arrays, or exceptions, or ...) */
+ return cons3 (intern (name), make_int (value), tail);
+}
-#ifndef LRECORD_VECTOR
- /* Free all unmarked vectors */
- sweep_vectors_1 (&all_vectors,
- &gc_count_num_vector_used, &gc_count_vector_total_size,
- &gc_count_vector_storage);
-#endif
+#define HACK_O_MATIC(type, name, pl) do { \
+ int s = 0; \
+ struct type##_block *x = current_##type##_block; \
+ while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
+ (pl) = gc_plist_hack ((name), s, (pl)); \
+} while (0)
- /* Free all unmarked bit vectors */
- sweep_bit_vectors_1 (&all_bit_vectors,
- &gc_count_num_bit_vector_used,
- &gc_count_bit_vector_total_size,
- &gc_count_bit_vector_storage);
+DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
+Reclaim storage for Lisp objects no longer needed.
+Return info on amount of space in use:
+ ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
+ (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
+ PLIST)
+ where `PLIST' is a list of alternating keyword/value pairs providing
+ more detailed information.
+Garbage collection happens automatically if you cons more than
+`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
+*/
+ ())
+{
+ Lisp_Object pl = Qnil;
+ int i;
+ int gc_count_vector_total_size = 0;
- /* Free all unmarked compiled-function objects */
- sweep_compiled_functions ();
+ garbage_collect_1 ();
+
+ for (i = 0; i <= last_lrecord_type_index_assigned; i++)
+ {
+ if (lcrecord_stats[i].bytes_in_use != 0
+ || lcrecord_stats[i].bytes_freed != 0
+ || lcrecord_stats[i].instances_on_free_list != 0)
+ {
+ char buf [255];
+ CONST char *name = lrecord_implementations_table[i]->name;
+ int len = strlen (name);
+ /* save this for the FSFmacs-compatible part of the summary */
+ if (i == *lrecord_vector.lrecord_type_index)
+ gc_count_vector_total_size =
+ lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
+
+ sprintf (buf, "%s-storage", name);
+ pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
+ /* Okay, simple pluralization check for `symbol-value-varalias' */
+ if (name[len-1] == 's')
+ sprintf (buf, "%ses-freed", name);
+ else
+ sprintf (buf, "%ss-freed", name);
+ if (lcrecord_stats[i].instances_freed != 0)
+ pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
+ if (name[len-1] == 's')
+ sprintf (buf, "%ses-on-free-list", name);
+ else
+ sprintf (buf, "%ss-on-free-list", name);
+ if (lcrecord_stats[i].instances_on_free_list != 0)
+ pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
+ pl);
+ if (name[len-1] == 's')
+ sprintf (buf, "%ses-used", name);
+ else
+ sprintf (buf, "%ss-used", name);
+ pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
+ }
+ }
+ HACK_O_MATIC (extent, "extent-storage", pl);
+ pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
+ pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
+ HACK_O_MATIC (event, "event-storage", pl);
+ pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
+ pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
+ HACK_O_MATIC (marker, "marker-storage", pl);
+ pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
+ pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
#ifdef LISP_FLOAT_TYPE
- /* Put all unmarked floats on free list */
- sweep_floats ();
-#endif
+ HACK_O_MATIC (float, "float-storage", pl);
+ pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
+ pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
+#endif /* LISP_FLOAT_TYPE */
+ HACK_O_MATIC (string, "string-header-storage", pl);
+ pl = gc_plist_hack ("long-strings-total-length",
+ gc_count_string_total_size
+ - gc_count_short_string_total_size, pl);
+ HACK_O_MATIC (string_chars, "short-string-storage", pl);
+ pl = gc_plist_hack ("short-strings-total-length",
+ gc_count_short_string_total_size, pl);
+ pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
+ pl = gc_plist_hack ("long-strings-used",
+ gc_count_num_string_in_use
+ - gc_count_num_short_string_in_use, pl);
+ pl = gc_plist_hack ("short-strings-used",
+ gc_count_num_short_string_in_use, pl);
- /* Put all unmarked symbols on free list */
- sweep_symbols ();
+ HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
+ pl = gc_plist_hack ("compiled-functions-free",
+ gc_count_num_compiled_function_freelist, pl);
+ pl = gc_plist_hack ("compiled-functions-used",
+ gc_count_num_compiled_function_in_use, pl);
- /* Put all unmarked extents on free list */
- sweep_extents ();
+ pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
+ pl = gc_plist_hack ("bit-vectors-total-length",
+ gc_count_bit_vector_total_size, pl);
+ pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
- /* Put all unmarked markers on free list.
- Dechain each one first from the buffer into which it points. */
- sweep_markers ();
+ HACK_O_MATIC (symbol, "symbol-storage", pl);
+ pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
+ pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
- sweep_events ();
+ HACK_O_MATIC (cons, "cons-storage", pl);
+ pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
+ pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
+ /* The things we do for backwards-compatibility */
+ return
+ list6 (Fcons (make_int (gc_count_num_cons_in_use),
+ make_int (gc_count_num_cons_freelist)),
+ Fcons (make_int (gc_count_num_symbol_in_use),
+ make_int (gc_count_num_symbol_freelist)),
+ Fcons (make_int (gc_count_num_marker_in_use),
+ make_int (gc_count_num_marker_freelist)),
+ make_int (gc_count_string_total_size),
+ make_int (gc_count_vector_total_size),
+ pl);
}
-\f
-/* Clearing for disksave. */
+#undef HACK_O_MATIC
-void
-disksave_object_finalization (void)
+DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
+Return the number of bytes consed since the last garbage collection.
+\"Consed\" is a misnomer in that this actually counts allocation
+of all different kinds of objects, not just conses.
+
+If this value exceeds `gc-cons-threshold', a garbage collection happens.
+*/
+ ())
{
- /* It's important that certain information from the environment not get
- dumped with the executable (pathnames, environment variables, etc.).
- To make it easier to tell when this has happened with strings(1) we
- clear some known-to-be-garbage blocks of memory, so that leftover
- results of old evaluation don't look like potential problems.
- But first we set some notable variables to nil and do one more GC,
- to turn those strings into garbage.
- */
+ return make_int (consing_since_gc);
+}
- /* Yeah, this list is pretty ad-hoc... */
- Vprocess_environment = Qnil;
- Vexec_directory = Qnil;
- Vdata_directory = Qnil;
- Vsite_directory = Qnil;
- Vdoc_directory = Qnil;
- Vconfigure_info_directory = Qnil;
- Vexec_path = Qnil;
- Vload_path = Qnil;
- /* Vdump_load_path = Qnil; */
- /* Release hash tables for locate_file */
- Fset (intern ("early-package-load-path"), Qnil);
- Fset (intern ("late-package-load-path"), Qnil);
- Fset (intern ("last-package-load-path"), Qnil);
- uncache_home_directory();
+DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
+Return the address of the last byte Emacs has allocated, divided by 1024.
+This may be helpful in debugging Emacs's memory usage.
+The value is divided by 1024 to make sure it will fit in a lisp integer.
+*/
+ ())
+{
+ return make_int ((EMACS_INT) sbrk (0) / 1024);
+}
-#if defined(LOADHIST) && !(defined(LOADHIST_DUMPED) || \
- defined(LOADHIST_BUILTIN))
- Vload_history = Qnil;
-#endif
- Vshell_file_name = Qnil;
- garbage_collect_1 ();
+\f
+int
+object_dead_p (Lisp_Object obj)
+{
+ return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
+ (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
+ (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
+ (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
+ (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
+ (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
+ (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
+}
- /* Run the disksave finalization methods of all live objects. */
- disksave_object_finalization_1 ();
+#ifdef MEMORY_USAGE_STATS
-#if 0 /* I don't see any point in this. The purespace starts out all 0's */
- /* Zero out the unused portion of purespace */
- if (!pure_lossage)
- memset ( (char *) (PUREBEG + pure_bytes_used), 0,
- (((char *) (PUREBEG + get_PURESIZE())) -
- ((char *) (PUREBEG + pure_bytes_used))));
-#endif
+/* Attempt to determine the actual amount of space that is used for
+ the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
- /* Zero out the uninitialized (really, unused) part of the containers
- for the live strings. */
- {
- struct string_chars_block *scb;
- for (scb = first_string_chars_block; scb; scb = scb->next)
- {
- int count = sizeof (scb->string_chars) - scb->pos;
+ It seems that the following holds:
- assert (count >= 0 && count < STRING_CHARS_BLOCK_SIZE);
- if (count != 0) {
- /* from the block's fill ptr to the end */
- memset ((scb->string_chars + scb->pos), 0, count);
- }
- }
- }
+ 1. When using the old allocator (malloc.c):
- /* There, that ought to be enough... */
+ -- blocks are always allocated in chunks of powers of two. For
+ each block, there is an overhead of 8 bytes if rcheck is not
+ defined, 20 bytes if it is defined. In other words, a
+ one-byte allocation needs 8 bytes of overhead for a total of
+ 9 bytes, and needs to have 16 bytes of memory chunked out for
+ it.
-}
+ 2. When using the new allocator (gmalloc.c):
-\f
-Lisp_Object
-restore_gc_inhibit (Lisp_Object val)
-{
- gc_currently_forbidden = XINT (val);
- return val;
-}
+ -- blocks are always allocated in chunks of powers of two up
+ to 4096 bytes. Larger blocks are allocated in chunks of
+ an integral multiple of 4096 bytes. The minimum block
+ size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
+ is defined. There is no per-block overhead, but there
+ is an overhead of 3*sizeof (size_t) for each 4096 bytes
+ allocated.
-/* Maybe we want to use this when doing a "panic" gc after memory_full()? */
-static int gc_hooks_inhibited;
+ 3. When using the system malloc, anything goes, but they are
+ generally slower and more space-efficient than the GNU
+ allocators. One possibly reasonable assumption to make
+ for want of better data is that sizeof (void *), or maybe
+ 2 * sizeof (void *), is required as overhead and that
+ blocks are allocated in the minimum required size except
+ that some minimum block size is imposed (e.g. 16 bytes). */
-\f
-void
-garbage_collect_1 (void)
+size_t
+malloced_storage_size (void *ptr, size_t claimed_size,
+ struct overhead_stats *stats)
{
-#if MAX_SAVE_STACK > 0
- char stack_top_variable;
- extern char *stack_bottom;
-#endif
- struct frame *f;
- int speccount;
- int cursor_changed;
- Lisp_Object pre_gc_cursor;
- struct gcpro gcpro1;
+ size_t orig_claimed_size = claimed_size;
- if (gc_in_progress
- || gc_currently_forbidden
- || in_display
- || preparing_for_armageddon)
- return;
+#ifdef GNU_MALLOC
- /* We used to call selected_frame() here.
+ if (claimed_size < 2 * sizeof (void *))
+ claimed_size = 2 * sizeof (void *);
+# ifdef SUNOS_LOCALTIME_BUG
+ if (claimed_size < 16)
+ claimed_size = 16;
+# endif
+ if (claimed_size < 4096)
+ {
+ int log = 1;
- The following functions cannot be called inside GC
- so we move to after the above tests. */
- {
- Lisp_Object frame;
- Lisp_Object device = Fselected_device (Qnil);
- if (NILP (device)) /* Could happen during startup, eg. if always_gc */
- return;
- frame = DEVICE_SELECTED_FRAME (XDEVICE (device));
- if (NILP (frame))
- signal_simple_error ("No frames exist on device", device);
- f = XFRAME (frame);
- }
+ /* compute the log base two, more or less, then use it to compute
+ the block size needed. */
+ claimed_size--;
+ /* It's big, it's heavy, it's wood! */
+ while ((claimed_size /= 2) != 0)
+ ++log;
+ claimed_size = 1;
+ /* It's better than bad, it's good! */
+ while (log > 0)
+ {
+ claimed_size *= 2;
+ log--;
+ }
+ /* We have to come up with some average about the amount of
+ blocks used. */
+ if ((size_t) (rand () & 4095) < claimed_size)
+ claimed_size += 3 * sizeof (void *);
+ }
+ else
+ {
+ claimed_size += 4095;
+ claimed_size &= ~4095;
+ claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
+ }
- pre_gc_cursor = Qnil;
- cursor_changed = 0;
+#elif defined (SYSTEM_MALLOC)
- GCPRO1 (pre_gc_cursor);
+ if (claimed_size < 16)
+ claimed_size = 16;
+ claimed_size += 2 * sizeof (void *);
- /* Very important to prevent GC during any of the following
- stuff that might run Lisp code; otherwise, we'll likely
- have infinite GC recursion. */
- speccount = specpdl_depth ();
- record_unwind_protect (restore_gc_inhibit,
- make_int (gc_currently_forbidden));
- gc_currently_forbidden = 1;
+#else /* old GNU allocator */
- if (!gc_hooks_inhibited)
- run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
+# ifdef rcheck /* #### may not be defined here */
+ claimed_size += 20;
+# else
+ claimed_size += 8;
+# endif
+ {
+ int log = 1;
- /* Now show the GC cursor/message. */
- if (!noninteractive)
+ /* compute the log base two, more or less, then use it to compute
+ the block size needed. */
+ claimed_size--;
+ /* It's big, it's heavy, it's wood! */
+ while ((claimed_size /= 2) != 0)
+ ++log;
+ claimed_size = 1;
+ /* It's better than bad, it's good! */
+ while (log > 0)
+ {
+ claimed_size *= 2;
+ log--;
+ }
+ }
+
+#endif /* old GNU allocator */
+
+ if (stats)
{
- if (FRAME_WIN_P (f))
- {
- Lisp_Object frame = make_frame (f);
- Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph,
- FRAME_SELECTED_WINDOW (f),
- ERROR_ME_NOT, 1);
- pre_gc_cursor = f->pointer;
- if (POINTER_IMAGE_INSTANCEP (cursor)
- /* don't change if we don't know how to change back. */
- && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
- {
- cursor_changed = 1;
- Fset_frame_pointer (frame, cursor);
- }
- }
+ stats->was_requested += orig_claimed_size;
+ stats->malloc_overhead += claimed_size - orig_claimed_size;
+ }
+ return claimed_size;
+}
- /* Don't print messages to the stream device. */
- if (!cursor_changed && !FRAME_STREAM_P (f))
- {
- char *msg = (STRINGP (Vgc_message)
- ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
- : 0);
- Lisp_Object args[2], whole_msg;
- args[0] = build_string (msg ? msg :
- GETTEXT ((CONST char *) gc_default_message));
- args[1] = build_string ("...");
- whole_msg = Fconcat (2, args);
- echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
- Qgarbage_collecting);
- }
+size_t
+fixed_type_block_overhead (size_t size)
+{
+ size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
+ size_t overhead = 0;
+ size_t storage_size = malloced_storage_size (0, per_block, 0);
+ while (size >= per_block)
+ {
+ size -= per_block;
+ overhead += sizeof (void *) + per_block - storage_size;
}
+ if (rand () % per_block < size)
+ overhead += sizeof (void *) + per_block - storage_size;
+ return overhead;
+}
- /***** Now we actually start the garbage collection. */
+#endif /* MEMORY_USAGE_STATS */
- gc_in_progress = 1;
+\f
+/* Initialization */
+void
+reinit_alloc_once_early (void)
+{
+ gc_generation_number[0] = 0;
+ /* purify_flag 1 is correct even if CANNOT_DUMP.
+ * loadup.el will set to nil at end. */
+ purify_flag = 1;
+ breathing_space = 0;
+ XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
+ XSETINT (Vgc_message, 0);
+ all_lcrecords = 0;
+ ignore_malloc_warnings = 1;
+#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 */
+#endif
+#endif
+ init_string_alloc ();
+ init_string_chars_alloc ();
+ init_cons_alloc ();
+ init_symbol_alloc ();
+ init_compiled_function_alloc ();
+#ifdef LISP_FLOAT_TYPE
+ init_float_alloc ();
+#endif /* LISP_FLOAT_TYPE */
+ init_marker_alloc ();
+ init_extent_alloc ();
+ init_event_alloc ();
- gc_generation_number[0]++;
+ ignore_malloc_warnings = 0;
-#if MAX_SAVE_STACK > 0
+ staticidx_nodump = 0;
+ dumpstructidx = 0;
+ pdump_wireidx = 0;
- /* Save a copy of the contents of the stack, for debugging. */
- if (!purify_flag)
- {
- /* Static buffer in which we save a copy of the C stack at each GC. */
- static char *stack_copy;
- static size_t stack_copy_size;
+ consing_since_gc = 0;
+#if 1
+ gc_cons_threshold = 500000; /* XEmacs change */
+#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;
- ptrdiff_t stack_diff = &stack_top_variable - stack_bottom;
- size_t stack_size = (stack_diff > 0 ? stack_diff : -stack_diff);
- if (stack_size < MAX_SAVE_STACK)
- {
- if (stack_copy_size < stack_size)
- {
- stack_copy = (char *) xrealloc (stack_copy, stack_size);
- stack_copy_size = stack_size;
- }
+ gc_currently_forbidden = 0;
+ gc_hooks_inhibited = 0;
- memcpy (stack_copy,
- stack_diff > 0 ? stack_bottom : &stack_top_variable,
- stack_size);
- }
- }
-#endif /* MAX_SAVE_STACK > 0 */
+#ifdef ERROR_CHECK_TYPECHECK
+ ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
+ 666;
+ ERROR_ME_NOT.
+ really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
+ ERROR_ME_WARN.
+ really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
+ 3333632;
+#endif /* ERROR_CHECK_TYPECHECK */
+}
- /* Do some totally ad-hoc resource clearing. */
- /* #### generalize this? */
- clear_event_resource ();
- cleanup_specifiers ();
+void
+init_alloc_once_early (void)
+{
+ int iii;
- /* Mark all the special slots that serve as the roots of accessibility. */
+ reinit_alloc_once_early ();
- { /* staticpro() */
- int i;
- for (i = 0; i < staticidx; i++)
- mark_object (*(staticvec[i]));
- }
+ last_lrecord_type_index_assigned = -1;
+ for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
+ {
+ lrecord_implementations_table[iii] = 0;
+ }
- { /* GCPRO() */
- struct gcpro *tail;
- int i;
- for (tail = gcprolist; tail; tail = tail->next)
- for (i = 0; i < tail->nvars; i++)
- mark_object (tail->var[i]);
- }
+ /*
+ * 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);
- { /* specbind() */
- struct specbinding *bind;
- for (bind = specpdl; bind != specpdl_ptr; bind++)
- {
- mark_object (bind->symbol);
- mark_object (bind->old_value);
- }
- }
+ staticidx = 0;
+}
- {
- struct catchtag *catch;
- for (catch = catchlist; catch; catch = catch->next)
- {
- mark_object (catch->tag);
- mark_object (catch->val);
- }
- }
+int pure_bytes_used = 0;
- {
- struct backtrace *backlist;
- for (backlist = backtrace_list; backlist; backlist = backlist->next)
- {
- int nargs = backlist->nargs;
- int i;
+void
+reinit_alloc (void)
+{
+ gcprolist = 0;
+}
- mark_object (*backlist->function);
- if (nargs == UNEVALLED || nargs == MANY)
- mark_object (backlist->args[0]);
- else
- for (i = 0; i < nargs; i++)
- mark_object (backlist->args[i]);
- }
- }
+void
+syms_of_alloc (void)
+{
+ defsymbol (&Qpre_gc_hook, "pre-gc-hook");
+ defsymbol (&Qpost_gc_hook, "post-gc-hook");
+ defsymbol (&Qgarbage_collecting, "garbage-collecting");
- mark_redisplay (mark_object);
- mark_profiling_info (mark_object);
+ DEFSUBR (Fcons);
+ DEFSUBR (Flist);
+ DEFSUBR (Fvector);
+ DEFSUBR (Fbit_vector);
+ DEFSUBR (Fmake_byte_code);
+ DEFSUBR (Fmake_list);
+ DEFSUBR (Fmake_vector);
+ DEFSUBR (Fmake_bit_vector);
+ DEFSUBR (Fmake_string);
+ DEFSUBR (Fstring);
+ DEFSUBR (Fmake_symbol);
+ DEFSUBR (Fmake_marker);
+ DEFSUBR (Fpurecopy);
+ DEFSUBR (Fgarbage_collect);
+ DEFSUBR (Fmemory_limit);
+ DEFSUBR (Fconsing_since_gc);
+}
- /* OK, now do the after-mark stuff. This is for things that
- are only marked when something else is marked (e.g. weak hash tables).
- There may be complex dependencies between such objects -- e.g.
- a weak hash table might be unmarked, but after processing a later
- weak hash table, the former one might get marked. So we have to
- iterate until nothing more gets marked. */
+void
+vars_of_alloc (void)
+{
+ DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
+*Number of bytes of consing between garbage collections.
+\"Consing\" is a misnomer in that this actually counts allocation
+of all different kinds of objects, not just conses.
+Garbage collection can happen automatically once this many bytes have been
+allocated since the last garbage collection. All data types count.
- while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 ||
- finish_marking_weak_lists (marked_p, mark_object) > 0)
- ;
+Garbage collection happens automatically when `eval' or `funcall' are
+called. (Note that `funcall' is called implicitly as part of evaluation.)
+By binding this temporarily to a large number, you can effectively
+prevent garbage collection during a part of the program.
- /* And prune (this needs to be called after everything else has been
- marked and before we do any sweeping). */
- /* #### this is somewhat ad-hoc and should probably be an object
- method */
- prune_weak_hash_tables (marked_p);
- prune_weak_lists (marked_p);
- prune_specifiers (marked_p);
- prune_syntax_tables (marked_p);
+See also `consing-since-gc'.
+*/ );
- gc_sweep ();
+ DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
+Number of bytes of sharable Lisp data allocated so far.
+*/ );
- consing_since_gc = 0;
-#ifndef DEBUG_XEMACS
- /* Allow you to set it really fucking low if you really want ... */
- if (gc_cons_threshold < 10000)
- gc_cons_threshold = 10000;
-#endif
+#if 0
+ DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
+Number of bytes of unshared memory allocated in this session.
+*/ );
- gc_in_progress = 0;
+ DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
+Number of bytes of unshared memory remaining available in this session.
+*/ );
+#endif
- /******* End of garbage collection ********/
+#ifdef DEBUG_XEMACS
+ DEFVAR_INT ("debug-allocation", &debug_allocation /*
+If non-zero, print out information to stderr about all objects allocated.
+See also `debug-allocation-backtrace-length'.
+*/ );
+ debug_allocation = 0;
- run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
+ DEFVAR_INT ("debug-allocation-backtrace-length",
+ &debug_allocation_backtrace_length /*
+Length (in stack frames) of short backtrace printed out by `debug-allocation'.
+*/ );
+ debug_allocation_backtrace_length = 2;
+#endif
- /* Now remove the GC cursor/message */
- if (!noninteractive)
- {
- if (cursor_changed)
- Fset_frame_pointer (make_frame (f), pre_gc_cursor);
- else if (!FRAME_STREAM_P (f))
- {
- char *msg = (STRINGP (Vgc_message)
- ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
- : 0);
+ DEFVAR_BOOL ("purify-flag", &purify_flag /*
+Non-nil means loading Lisp code in order to dump an executable.
+This means that certain objects should be allocated in readonly space.
+*/ );
- /* Show "...done" only if the echo area would otherwise be empty. */
- if (NILP (clear_echo_area (selected_frame (),
- Qgarbage_collecting, 0)))
- {
- Lisp_Object args[2], whole_msg;
- args[0] = build_string (msg ? msg :
- GETTEXT ((CONST char *)
- gc_default_message));
- args[1] = build_string ("... done");
- whole_msg = Fconcat (2, args);
- echo_area_message (selected_frame (), (Bufbyte *) 0,
- whole_msg, 0, -1,
- Qgarbage_collecting);
- }
- }
- }
+ DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
+Function or functions to be run just before each garbage collection.
+Interrupts, garbage collection, and errors are inhibited while this hook
+runs, so be extremely careful in what you add here. In particular, avoid
+consing, and do not interact with the user.
+*/ );
+ Vpre_gc_hook = Qnil;
- /* now stop inhibiting GC */
- unbind_to (speccount, Qnil);
+ DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
+Function or functions to be run just after each garbage collection.
+Interrupts, garbage collection, and errors are inhibited while this hook
+runs, so be extremely careful in what you add here. In particular, avoid
+consing, and do not interact with the user.
+*/ );
+ Vpost_gc_hook = Qnil;
- if (!breathing_space)
- {
- breathing_space = malloc (4096 - MALLOC_OVERHEAD);
- }
+ DEFVAR_LISP ("gc-message", &Vgc_message /*
+String to print to indicate that a garbage collection is in progress.
+This is printed in the echo area. If the selected frame is on a
+window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
+image instance) in the domain of the selected frame, the mouse pointer
+will change instead of this message being printed.
+*/ );
+ Vgc_message = build_string (gc_default_message);
- UNGCPRO;
- return;
+ DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
+Pointer glyph used to indicate that a garbage collection is in progress.
+If the selected window is on a window system and this glyph specifies a
+value (i.e. a pointer image instance) in the domain of the selected
+window, the pointer will be changed as specified during garbage collection.
+Otherwise, a message will be printed in the echo area, as controlled
+by `gc-message'.
+*/ );
}
-/* Debugging aids. */
-
-static Lisp_Object
-gc_plist_hack (CONST char *name, int value, Lisp_Object tail)
+void
+complex_vars_of_alloc (void)
{
- /* C doesn't have local functions (or closures, or GC, or readable syntax,
- or portable numeric datatypes, or bit-vectors, or characters, or
- arrays, or exceptions, or ...) */
- return cons3 (intern (name), make_int (value), tail);
+ Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
}
-#define HACK_O_MATIC(type, name, pl) do { \
- int s = 0; \
- struct type##_block *x = current_##type##_block; \
- while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \
- (pl) = gc_plist_hack ((name), s, (pl)); \
-} while (0)
-
-DEFUN ("garbage-collect", Fgarbage_collect, 0, 0, "", /*
-Reclaim storage for Lisp objects no longer needed.
-Return info on amount of space in use:
- ((USED-CONSES . FREE-CONSES) (USED-SYMS . FREE-SYMS)
- (USED-MARKERS . FREE-MARKERS) USED-STRING-CHARS USED-VECTOR-SLOTS
- PLIST)
- where `PLIST' is a list of alternating keyword/value pairs providing
- more detailed information.
-Garbage collection happens automatically if you cons more than
-`gc-cons-threshold' bytes of Lisp data since previous garbage collection.
-*/
- ())
-{
- Lisp_Object pl = Qnil;
- int i;
-#ifdef LRECORD_VECTOR
- int gc_count_vector_total_size = 0;
-#endif
-
- if (purify_flag && pure_lossage)
- return Qnil;
-
- garbage_collect_1 ();
- for (i = 0; i < last_lrecord_type_index_assigned; i++)
- {
- if (lcrecord_stats[i].bytes_in_use != 0
- || lcrecord_stats[i].bytes_freed != 0
- || lcrecord_stats[i].instances_on_free_list != 0)
- {
- char buf [255];
- CONST char *name = lrecord_implementations_table[i]->name;
- int len = strlen (name);
-#ifdef LRECORD_VECTOR
- /* save this for the FSFmacs-compatible part of the summary */
- if (i == *lrecord_vector[0].lrecord_type_index)
- gc_count_vector_total_size =
- lcrecord_stats[i].bytes_in_use + lcrecord_stats[i].bytes_freed;
-#endif
- sprintf (buf, "%s-storage", name);
- pl = gc_plist_hack (buf, lcrecord_stats[i].bytes_in_use, pl);
- /* Okay, simple pluralization check for `symbol-value-varalias' */
- if (name[len-1] == 's')
- sprintf (buf, "%ses-freed", name);
- else
- sprintf (buf, "%ss-freed", name);
- if (lcrecord_stats[i].instances_freed != 0)
- pl = gc_plist_hack (buf, lcrecord_stats[i].instances_freed, pl);
- if (name[len-1] == 's')
- sprintf (buf, "%ses-on-free-list", name);
- else
- sprintf (buf, "%ss-on-free-list", name);
- if (lcrecord_stats[i].instances_on_free_list != 0)
- pl = gc_plist_hack (buf, lcrecord_stats[i].instances_on_free_list,
- pl);
- if (name[len-1] == 's')
- sprintf (buf, "%ses-used", name);
- else
- sprintf (buf, "%ss-used", name);
- pl = gc_plist_hack (buf, lcrecord_stats[i].instances_in_use, pl);
- }
- }
+#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 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
+};
- HACK_O_MATIC (extent, "extent-storage", pl);
- pl = gc_plist_hack ("extents-free", gc_count_num_extent_freelist, pl);
- pl = gc_plist_hack ("extents-used", gc_count_num_extent_in_use, pl);
- HACK_O_MATIC (event, "event-storage", pl);
- pl = gc_plist_hack ("events-free", gc_count_num_event_freelist, pl);
- pl = gc_plist_hack ("events-used", gc_count_num_event_in_use, pl);
- HACK_O_MATIC (marker, "marker-storage", pl);
- pl = gc_plist_hack ("markers-free", gc_count_num_marker_freelist, pl);
- pl = gc_plist_hack ("markers-used", gc_count_num_marker_in_use, pl);
-#ifdef LISP_FLOAT_TYPE
- HACK_O_MATIC (float, "float-storage", pl);
- pl = gc_plist_hack ("floats-free", gc_count_num_float_freelist, pl);
- pl = gc_plist_hack ("floats-used", gc_count_num_float_in_use, pl);
-#endif /* LISP_FLOAT_TYPE */
- HACK_O_MATIC (string, "string-header-storage", pl);
- pl = gc_plist_hack ("long-strings-total-length",
- gc_count_string_total_size
- - gc_count_short_string_total_size, pl);
- HACK_O_MATIC (string_chars, "short-string-storage", pl);
- pl = gc_plist_hack ("short-strings-total-length",
- gc_count_short_string_total_size, pl);
- pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl);
- pl = gc_plist_hack ("long-strings-used",
- gc_count_num_string_in_use
- - gc_count_num_short_string_in_use, pl);
- pl = gc_plist_hack ("short-strings-used",
- gc_count_num_short_string_in_use, pl);
+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;
- HACK_O_MATIC (compiled_function, "compiled-function-storage", pl);
- pl = gc_plist_hack ("compiled-functions-free",
- gc_count_num_compiled_function_freelist, pl);
- pl = gc_plist_hack ("compiled-functions-used",
- gc_count_num_compiled_function_in_use, pl);
+typedef struct
+{
+ pdump_entry_list_elmt *first;
+ int align;
+ int count;
+} pdump_entry_list;
-#ifndef LRECORD_VECTOR
- pl = gc_plist_hack ("vector-storage", gc_count_vector_storage, pl);
- pl = gc_plist_hack ("vectors-total-length",
- gc_count_vector_total_size, pl);
- pl = gc_plist_hack ("vectors-used", gc_count_num_vector_used, pl);
-#endif
+typedef struct pdump_struct_list_elmt
+{
+ pdump_entry_list list;
+ const struct struct_description *sdesc;
+} pdump_struct_list_elmt;
- pl = gc_plist_hack ("bit-vector-storage", gc_count_bit_vector_storage, pl);
- pl = gc_plist_hack ("bit-vectors-total-length",
- gc_count_bit_vector_total_size, pl);
- pl = gc_plist_hack ("bit-vectors-used", gc_count_num_bit_vector_used, pl);
+typedef struct
+{
+ pdump_struct_list_elmt *list;
+ int count;
+ int size;
+} pdump_struct_list;
- HACK_O_MATIC (symbol, "symbol-storage", pl);
- pl = gc_plist_hack ("symbols-free", gc_count_num_symbol_freelist, pl);
- pl = gc_plist_hack ("symbols-used", gc_count_num_symbol_in_use, pl);
+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;
- HACK_O_MATIC (cons, "cons-storage", pl);
- pl = gc_plist_hack ("conses-free", gc_count_num_cons_freelist, pl);
- pl = gc_plist_hack ("conses-used", gc_count_num_cons_in_use, pl);
+static int pdump_alert_undump_object[256];
- /* The things we do for backwards-compatibility */
- return
- list6 (Fcons (make_int (gc_count_num_cons_in_use),
- make_int (gc_count_num_cons_freelist)),
- Fcons (make_int (gc_count_num_symbol_in_use),
- make_int (gc_count_num_symbol_freelist)),
- Fcons (make_int (gc_count_num_marker_in_use),
- make_int (gc_count_num_marker_freelist)),
- make_int (gc_count_string_total_size),
- make_int (gc_count_vector_total_size),
- pl);
-}
-#undef HACK_O_MATIC
+static unsigned long cur_offset;
+static size_t max_size;
+static int pdump_fd;
+static void *pdump_buf;
-DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /*
-Return the number of bytes consed since the last garbage collection.
-\"Consed\" is a misnomer in that this actually counts allocation
-of all different kinds of objects, not just conses.
+#define PDUMP_HASHSIZE 200001
-If this value exceeds `gc-cons-threshold', a garbage collection happens.
-*/
- ())
+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 make_int (consing_since_gc);
+ return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE;
}
-DEFUN ("memory-limit", Fmemory_limit, 0, 0, "", /*
-Return the address of the last byte Emacs has allocated, divided by 1024.
-This may be helpful in debugging Emacs's memory usage.
-The value is divided by 1024 to make sure it will fit in a lisp integer.
-*/
- ())
+static pdump_entry_list_elmt *
+pdump_get_entry (const void *obj)
{
- return make_int ((EMACS_INT) sbrk (0) / 1024);
-}
+ int pos = pdump_make_hash(obj);
+ pdump_entry_list_elmt *e;
+ while ((e = pdump_hash[pos]) != 0)
+ {
+ if (e->obj == obj)
+ return e;
+ pos++;
+ if (pos == PDUMP_HASHSIZE)
+ pos = 0;
+ }
+ return 0;
+}
-\f
-int
-object_dead_p (Lisp_Object obj)
+static void
+pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord)
{
- return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) ||
- (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) ||
- (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) ||
- (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) ||
- (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) ||
- (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) ||
- (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj))));
-}
+ pdump_entry_list_elmt *e;
+ int align;
+ int pos = pdump_make_hash (obj);
-#ifdef MEMORY_USAGE_STATS
+ while ((e = pdump_hash[pos]) != 0)
+ {
+ if (e->obj == obj)
+ return;
+
+ pos++;
+ if (pos == PDUMP_HASHSIZE)
+ pos = 0;
+ }
-/* Attempt to determine the actual amount of space that is used for
- the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE".
+ e = malloc (sizeof (pdump_entry_list_elmt));
- It seems that the following holds:
+ e->next = list->first;
+ e->obj = obj;
+ e->size = size;
+ e->count = count;
+ e->is_lrecord = is_lrecord;
+ list->first = e;
- 1. When using the old allocator (malloc.c):
+ list->count += count;
+ pdump_hash[pos] = e;
- -- blocks are always allocated in chunks of powers of two. For
- each block, there is an overhead of 8 bytes if rcheck is not
- defined, 20 bytes if it is defined. In other words, a
- one-byte allocation needs 8 bytes of overhead for a total of
- 9 bytes, and needs to have 16 bytes of memory chunked out for
- it.
+ align = align_table[size & 255];
+ if (align<2 && is_lrecord)
+ align = 2;
- 2. When using the new allocator (gmalloc.c):
+ if(align < list->align)
+ list->align = align;
+}
- -- blocks are always allocated in chunks of powers of two up
- to 4096 bytes. Larger blocks are allocated in chunks of
- an integral multiple of 4096 bytes. The minimum block
- size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG
- is defined. There is no per-block overhead, but there
- is an overhead of 3*sizeof (size_t) for each 4096 bytes
- allocated.
+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;
- 3. When using the system malloc, anything goes, but they are
- generally slower and more space-efficient than the GNU
- allocators. One possibly reasonable assumption to make
- for want of better data is that sizeof (void *), or maybe
- 2 * sizeof (void *), is required as overhead and that
- blocks are allocated in the minimum required size except
- that some minimum block size is imposed (e.g. 16 bytes). */
+ 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 = 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;
+}
-size_t
-malloced_storage_size (void *ptr, size_t claimed_size,
- struct overhead_stats *stats)
+static struct {
+ Lisp_Object obj;
+ int position;
+ int offset;
+} backtrace[65536];
+
+static int depth;
+
+static void pdump_backtrace (void)
{
- size_t orig_claimed_size = claimed_size;
+ 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",
+ XRECORD_LHEADER_IMPLEMENTATION (backtrace[i].obj)->name,
+ backtrace[i].position,
+ backtrace[i].offset);
+ }
+ }
+}
-#ifdef GNU_MALLOC
+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;
+}
- if (claimed_size < 2 * sizeof (void *))
- claimed_size = 2 * sizeof (void *);
-# ifdef SUNOS_LOCALTIME_BUG
- if (claimed_size < 16)
- claimed_size = 16;
-# endif
- if (claimed_size < 4096)
+static void
+pdump_register_sub (const void *data, const struct lrecord_description *desc, int me)
+{
+ int pos;
+ const void *rdata;
+
+ restart:
+ for (pos = 0; desc[pos].type != XD_END; pos++)
{
- int log = 1;
+ backtrace[me].position = pos;
+ backtrace[me].offset = desc[pos].offset;
- /* compute the log base two, more or less, then use it to compute
- the block size needed. */
- claimed_size--;
- /* It's big, it's heavy, it's wood! */
- while ((claimed_size /= 2) != 0)
- ++log;
- claimed_size = 1;
- /* It's better than bad, it's good! */
- while (log > 0)
- {
- claimed_size *= 2;
- log--;
- }
- /* We have to come up with some average about the amount of
- blocks used. */
- if ((size_t) (rand () & 4095) < claimed_size)
- claimed_size += 3 * sizeof (void *);
+ rdata = ((const char *)data) + desc[pos].offset;
+ switch(desc[pos].type)
+ {
+ case XD_SPECIFIER_END:
+ pos = 0;
+ desc = ((const struct 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:
+ {
+ 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++) {
+ 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)
+{
+ if (!obj ||
+ !POINTER_TYPE_P (XTYPE (obj)) ||
+ pdump_get_entry (XRECORD_LHEADER (obj)))
+ return;
+
+ if (XRECORD_LHEADER_IMPLEMENTATION (obj)->description)
+ {
+ int me = depth++;
+ if (me>65536)
+ {
+ fprintf (stderr, "Backtrace overflow, loop ?\n");
+ abort ();
+ }
+ backtrace[me].obj = obj;
+ backtrace[me].position = 0;
+ backtrace[me].offset = 0;
+
+ pdump_add_entry (pdump_object_table + XRECORD_LHEADER (obj)->type,
+ XRECORD_LHEADER (obj),
+ XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size ?
+ XRECORD_LHEADER_IMPLEMENTATION (obj)->static_size :
+ XRECORD_LHEADER_IMPLEMENTATION (obj)->size_in_bytes_method (XRECORD_LHEADER (obj)),
+ 1,
+ 1);
+ pdump_register_sub (XRECORD_LHEADER (obj),
+ XRECORD_LHEADER_IMPLEMENTATION (obj)->description,
+ me);
+ --depth;
}
else
{
- claimed_size += 4095;
- claimed_size &= ~4095;
- claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t);
+ pdump_alert_undump_object[XRECORD_LHEADER (obj)->type]++;
+ fprintf (stderr, "Undumpable object type : %s\n", XRECORD_LHEADER_IMPLEMENTATION (obj)->name);
+ pdump_backtrace ();
}
+}
-#elif defined (SYSTEM_MALLOC)
+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;
+ }
+}
- if (claimed_size < 16)
- claimed_size = 16;
- claimed_size += 2 * sizeof (void *);
+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;
+ void *rdata;
+ 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++)
+ {
+ rdata = cur + desc[pos].offset;
+ switch (desc[pos].type)
+ {
+ case XD_SPECIFIER_END:
+ pos = 0;
+ desc = ((const struct 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:
+ {
+ 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;
+ Lisp_Object dobj = *pobj;
+ if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
+ *pobj = pdump_get_entry (XRECORD_LHEADER (dobj))->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));
+}
-#else /* old GNU allocator */
+static void
+pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc)
+{
+ int pos;
+ void *rdata;
-# ifdef rcheck /* #### may not be defined here */
- claimed_size += 20;
-# else
- claimed_size += 8;
-# endif
- {
- int log = 1;
+ restart:
+ for (pos = 0; desc[pos].type != XD_END; pos++)
+ {
+ rdata = ((char *)data) + desc[pos].offset;
+ switch (desc[pos].type) {
+ case XD_SPECIFIER_END:
+ pos = 0;
+ desc = ((const struct 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:
+ 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;
+ Lisp_Object dobj = *pobj;
+ if (dobj && POINTER_TYPE_P (XTYPE (dobj)))
+ *pobj = dobj + 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 ();
+ };
+ }
+}
- /* compute the log base two, more or less, then use it to compute
- the block size needed. */
- claimed_size--;
- /* It's big, it's heavy, it's wood! */
- while ((claimed_size /= 2) != 0)
- ++log;
- claimed_size = 1;
- /* It's better than bad, it's good! */
- while (log > 0)
- {
- claimed_size *= 2;
- log--;
- }
+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_alignement (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)
+{
+ Lisp_Object *reloc = malloc (staticidx*sizeof (Lisp_Object));
+ int i;
+ write (pdump_fd, staticvec, staticidx*sizeof (Lisp_Object *));
+
+ for(i=0; i<staticidx; i++)
+ {
+ Lisp_Object obj = *staticvec[i];
+ if (obj && POINTER_TYPE_P (XTYPE (obj)))
+ reloc[i] = pdump_get_entry (XRECORD_LHEADER (obj))->save_offset;
+ else
+ reloc[i] = obj;
+ }
+ 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_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 (XRECORD_LHEADER (elmt->obj))->save_offset;
+ write (pdump_fd, &rdata, sizeof (rdata));
+ elmt = elmt->next;
+ }
}
-#endif /* old GNU allocator */
+ rt.desc = 0;
+ rt.count = 0;
+ write (pdump_fd, &rt, sizeof (rt));
- if (stats)
+ for (i=0; i<pdump_struct_table.count; i++)
{
- stats->was_requested += orig_claimed_size;
- stats->malloc_overhead += claimed_size - orig_claimed_size;
+ 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 (XRECORD_LHEADER (elmt->obj))->save_offset;
+ for (j=0; j<elmt->count; j++) {
+ write (pdump_fd, &rdata, sizeof (rdata));
+ rdata += elmt->size;
+ }
+ elmt = elmt->next;
+ }
}
- return claimed_size;
+ rt.desc = 0;
+ rt.count = 0;
+ write (pdump_fd, &rt, sizeof (rt));
}
-size_t
-fixed_type_block_overhead (size_t size)
+static void
+pdump_dump_wired (void)
{
- size_t per_block = TYPE_ALLOC_SIZE (cons, unsigned char);
- size_t overhead = 0;
- size_t storage_size = malloced_storage_size (0, per_block, 0);
- while (size >= per_block)
+ EMACS_INT count = pdump_wireidx + pdump_wireidx_list;
+ int i;
+
+ write (pdump_fd, &count, sizeof (count));
+
+ for (i=0; i<pdump_wireidx; i++)
{
- size -= per_block;
- overhead += sizeof (void *) + per_block - storage_size;
+ Lisp_Object 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));
}
- if (rand () % per_block < size)
- overhead += sizeof (void *) + per_block - storage_size;
- return overhead;
-}
+
+ for (i=0; i<pdump_wireidx_list; i++)
+ {
+ Lisp_Object obj = *(pdump_wirevec_list[i]);
+ pdump_entry_list_elmt *elmt;
+ EMACS_INT res;
-#endif /* MEMORY_USAGE_STATS */
+ 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));
+ }
+}
-\f
-/* Initialization */
void
-init_alloc_once_early (void)
+pdump (void)
{
- int iii;
+ int i;
+ Lisp_Object t_console, t_device, t_frame;
+ int none;
+ dump_header hd;
- last_lrecord_type_index_assigned = -1;
- for (iii = 0; iii < countof (lrecord_implementations_table); iii++)
+ /* 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 = malloc (PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *));
+ memset (pdump_hash, 0, PDUMP_HASHSIZE*sizeof (pdump_entry_list_elmt *));
+
+ for (i=0; i<=last_lrecord_type_index_assigned; i++)
{
- lrecord_implementations_table[iii] = 0;
+ 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;
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- /*
- * If USE_INDEXED_LRECORD_IMPLEMENTATION is defined, 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[0].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[0].lrecord_type_index) == 1);
-#endif /* USE_INDEXED_LRECORD_IMPLEMENTATION */
+ for (i=0; i<dumpstructidx; i++)
+ pdump_register_struct (*(void **)(dumpstructvec[i].data), dumpstructvec[i].desc, 1);
- symbols_initialized = 0;
+ memcpy (hd.signature, "XEmacsDP", 8);
+ hd.reloc_address = 0;
+ hd.nb_staticpro = staticidx;
+ hd.nb_structdmp = dumpstructidx;
+ hd.last_type = last_lrecord_type_index_assigned;
+
+ cur_offset = 256;
+ max_size = 0;
+
+ pdump_scan_by_alignement (pdump_allocate_offset);
+ pdump_qnil = pdump_get_entry (XRECORD_LHEADER (Qnil));
- gc_generation_number[0] = 0;
- /* purify_flag 1 is correct even if CANNOT_DUMP.
- * loadup.el will set to nil at end. */
- purify_flag = 1;
- pure_bytes_used = 0;
- pure_lossage = 0;
- breathing_space = 0;
-#ifndef LRECORD_VECTOR
- XSETINT (all_vectors, 0); /* Qzero may not be set yet. */
-#endif
- XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
- XSETINT (Vgc_message, 0);
- all_lcrecords = 0;
- ignore_malloc_warnings = 1;
-#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 */
-#endif
-#endif
- init_string_alloc ();
- init_string_chars_alloc ();
- init_cons_alloc ();
- init_symbol_alloc ();
- init_compiled_function_alloc ();
-#ifdef LISP_FLOAT_TYPE
- init_float_alloc ();
-#endif /* LISP_FLOAT_TYPE */
- init_marker_alloc ();
- init_extent_alloc ();
- init_event_alloc ();
+ pdump_buf = malloc (max_size);
+ pdump_fd = open ("xemacs.dmp", O_WRONLY|O_CREAT|O_TRUNC, 0666);
+ hd.stab_offset = (cur_offset + 3) & ~3;
- ignore_malloc_warnings = 0;
- staticidx = 0;
- consing_since_gc = 0;
-#if 1
- gc_cons_threshold = 500000; /* XEmacs change */
-#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;
+ write (pdump_fd, &hd, sizeof (hd));
+ lseek (pdump_fd, 256, SEEK_SET);
- gc_currently_forbidden = 0;
- gc_hooks_inhibited = 0;
+ pdump_scan_by_alignement (pdump_dump_data);
-#ifdef ERROR_CHECK_TYPECHECK
- ERROR_ME.really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
- 666;
- ERROR_ME_NOT.
- really_unlikely_name_to_have_accidentally_in_a_non_errb_structure = 42;
- ERROR_ME_WARN.
- really_unlikely_name_to_have_accidentally_in_a_non_errb_structure =
- 3333632;
-#endif /* ERROR_CHECK_TYPECHECK */
-}
+ lseek (pdump_fd, hd.stab_offset, SEEK_SET);
-void
-reinit_alloc (void)
-{
- gcprolist = 0;
-}
+ pdump_dump_staticvec ();
+ pdump_dump_structvec ();
+ pdump_dump_itable ();
+ pdump_dump_rtables ();
+ pdump_dump_wired ();
-void
-syms_of_alloc (void)
-{
- defsymbol (&Qpre_gc_hook, "pre-gc-hook");
- defsymbol (&Qpost_gc_hook, "post-gc-hook");
- defsymbol (&Qgarbage_collecting, "garbage-collecting");
+ close (pdump_fd);
+ free (pdump_buf);
- DEFSUBR (Fcons);
- DEFSUBR (Flist);
- DEFSUBR (Fvector);
- DEFSUBR (Fbit_vector);
- DEFSUBR (Fmake_byte_code);
- DEFSUBR (Fmake_list);
- DEFSUBR (Fmake_vector);
- DEFSUBR (Fmake_bit_vector);
- DEFSUBR (Fmake_string);
- DEFSUBR (Fstring);
- DEFSUBR (Fmake_symbol);
- DEFSUBR (Fmake_marker);
- DEFSUBR (Fpurecopy);
- DEFSUBR (Fgarbage_collect);
- DEFSUBR (Fmemory_limit);
- DEFSUBR (Fconsing_since_gc);
+ free (pdump_hash);
+
+ Vterminal_console = t_console;
+ Vterminal_frame = t_frame;
+ Vterminal_device = t_device;
}
-void
-vars_of_alloc (void)
+int
+pdump_load (void)
{
- DEFVAR_INT ("gc-cons-threshold", &gc_cons_threshold /*
-*Number of bytes of consing between garbage collections.
-\"Consing\" is a misnomer in that this actually counts allocation
-of all different kinds of objects, not just conses.
-Garbage collection can happen automatically once this many bytes have been
-allocated since the last garbage collection. All data types count.
-
-Garbage collection happens automatically when `eval' or `funcall' are
-called. (Note that `funcall' is called implicitly as part of evaluation.)
-By binding this temporarily to a large number, you can effectively
-prevent garbage collection during a part of the program.
+ size_t length;
+ int i;
+ char *p;
+ EMACS_INT delta;
+ EMACS_INT count;
-See also `consing-since-gc'.
-*/ );
+ pdump_start = pdump_end = 0;
- DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
-Number of bytes of sharable Lisp data allocated so far.
-*/ );
+ pdump_fd = open ("xemacs.dmp", O_RDONLY);
+ if (pdump_fd<0)
+ return 0;
-#if 0
- DEFVAR_INT ("data-bytes-used", &malloc_sbrk_used /*
-Number of bytes of unshared memory allocated in this session.
-*/ );
+ length = lseek (pdump_fd, 0, SEEK_END);
+ lseek (pdump_fd, 0, SEEK_SET);
- DEFVAR_INT ("data-bytes-free", &malloc_sbrk_unused /*
-Number of bytes of unshared memory remaining available in this session.
-*/ );
+#ifdef HAVE_MMAP
+ pdump_start = 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 = (void *)((((unsigned long)(malloc(length+255))) + 255) & ~255);
+ read(pdump_fd, pdump_start, length);
+ }
-#ifdef DEBUG_XEMACS
- DEFVAR_INT ("debug-allocation", &debug_allocation /*
-If non-zero, print out information to stderr about all objects allocated.
-See also `debug-allocation-backtrace-length'.
-*/ );
- debug_allocation = 0;
+ close (pdump_fd);
- DEFVAR_INT ("debug-allocation-backtrace-length",
- &debug_allocation_backtrace_length /*
-Length (in stack frames) of short backtrace printed out by `debug-allocation'.
-*/ );
- debug_allocation_backtrace_length = 2;
-#endif
+ pdump_end = pdump_start + length;
- DEFVAR_BOOL ("purify-flag", &purify_flag /*
-Non-nil means loading Lisp code in order to dump an executable.
-This means that certain objects should be allocated in shared (pure) space.
-*/ );
+ 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;
- DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /*
-Function or functions to be run just before each garbage collection.
-Interrupts, garbage collection, and errors are inhibited while this hook
-runs, so be extremely careful in what you add here. In particular, avoid
-consing, and do not interact with the user.
-*/ );
- Vpre_gc_hook = Qnil;
+ /* 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 = *(Lisp_Object *)p;
+ p += sizeof (Lisp_Object);
+ if (obj && POINTER_TYPE_P (XTYPE (obj)))
+ obj += delta;
+ *staticvec[i] = obj;
+ }
- DEFVAR_LISP ("post-gc-hook", &Vpost_gc_hook /*
-Function or functions to be run just after each garbage collection.
-Interrupts, garbage collection, and errors are inhibited while this hook
-runs, so be extremely careful in what you add here. In particular, avoid
-consing, and do not interact with the user.
-*/ );
- Vpost_gc_hook = Qnil;
+ /* Put back the dumpstructs */
+ for (i=0; i<((dump_header *)pdump_start)->nb_structdmp; i++)
+ {
+ void **adr = *(void **)p;
+ p += sizeof (void *);
+ *adr = (void *)((*(EMACS_INT *)p) + delta);
+ p += sizeof (EMACS_INT);
+ }
- DEFVAR_LISP ("gc-message", &Vgc_message /*
-String to print to indicate that a garbage collection is in progress.
-This is printed in the echo area. If the selected frame is on a
-window system and `gc-pointer-glyph' specifies a value (i.e. a pointer
-image instance) in the domain of the selected frame, the mouse pointer
-will change instead of this message being printed.
-*/ );
- Vgc_message = make_pure_string ((CONST Bufbyte *) gc_default_message,
- countof (gc_default_message) - 1,
- Qnil, 1);
+ /* Put back the lrecord_implementations_table */
+ memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table));
+ p += sizeof (lrecord_implementations_table);
- DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /*
-Pointer glyph used to indicate that a garbage collection is in progress.
-If the selected window is on a window system and this glyph specifies a
-value (i.e. a pointer image instance) in the domain of the selected
-window, the pointer will be changed as specified during garbage collection.
-Otherwise, a message will be printed in the echo area, as controlled
-by `gc-message'.
-*/ );
-}
+ /* Give back their numbers to the lrecord implementations */
+ for (i=0; i<sizeof(lrecord_implementations_table)/sizeof(lrecord_implementations_table[0]); i++)
+ if (lrecord_implementations_table[i])
+ {
+ *(lrecord_implementations_table[i]->lrecord_type_index) = i;
+ last_lrecord_type_index_assigned = i;
+ }
-void
-complex_vars_of_alloc (void)
-{
- Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer);
+ /* Do the relocations */
+ pdump_rt_list = p;
+ count = 2;
+ for(;;)
+ {
+ pdump_reloc_table *rt = (pdump_reloc_table *)p;
+ p += sizeof (pdump_reloc_table);
+ if (rt->desc) {
+ for (i=0; i<rt->count; i++)
+ {
+ EMACS_INT adr = delta + *(EMACS_INT *)p;
+ *(EMACS_INT *)p = adr;
+ pdump_reloc_one ((void *)adr, delta, rt->desc);
+ p += sizeof (EMACS_INT);
+ }
+ } else
+ if(!(--count))
+ break;
+ }
+
+ /* Put the pdump_wire variables in place */
+ count = *(EMACS_INT *)p;
+ p += sizeof(EMACS_INT);
+
+ for (i=0; i<count; i++)
+ {
+ Lisp_Object *var, obj;
+ var = *(Lisp_Object **)p;
+ p += sizeof (Lisp_Object *);
+
+ obj = *(Lisp_Object *)p;
+ p += sizeof (Lisp_Object);
+
+ if (obj && POINTER_TYPE_P (XTYPE (obj)))
+ obj += delta;
+ *var = obj;
+ }
+
+ /* Final cleanups */
+ /* reorganize hash tables */
+ p = pdump_rt_list;
+ for(;;)
+ {
+ pdump_reloc_table *rt = (pdump_reloc_table *)p;
+ p += sizeof (pdump_reloc_table);
+ if (!rt->desc)
+ break;
+ if (rt->desc == hash_table_description)
+ {
+ for (i=0; i<rt->count; i++)
+ {
+ struct Lisp_Hash_Table *ht = XHASH_TABLE (*(EMACS_INT *)p);
+ reorganize_hash_table (ht);
+ p += sizeof (EMACS_INT);
+ }
+ break;
+ } else
+ p += sizeof (EMACS_INT)*rt->count;
+ }
+ return 1;
}
+
+#endif
projects / chise / xemacs-chise.git- / blobdiff