X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Falloc.c;h=8ee5af5ec7d084f69468aa26b53f925cd88a11b4;hb=89b59fd43580fd8e01e1feda0fada5597f3f4f58;hp=509da0fb711453b76282cb9af49e0650708f600c;hpb=35adcaaeafb1fe93eaf00c39b48619e8f188ff3f;p=chise%2Fxemacs-chise.git- diff --git a/src/alloc.c b/src/alloc.c index 509da0f..8ee5af5 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -36,6 +36,7 @@ Boston, MA 02111-1307, USA. */ 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 @@ -56,13 +57,27 @@ Boston, MA 02111-1307, USA. */ #include "specifier.h" #include "sysfile.h" #include "window.h" - -#include +#include "console-stream.h" #ifdef DOUG_LEA_MALLOC #include #endif +#ifdef HAVE_MMAP +#include +#include +#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. */ @@ -80,12 +95,6 @@ EXFUN (Fgarbage_collect, 0); #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 */ @@ -94,8 +103,6 @@ EXFUN (Fgarbage_collect, 0); #define ALLOC_NO_POOLS #endif -#include "puresize.h" - #ifdef DEBUG_XEMACS static int debug_allocation; static int debug_allocation_backtrace_length; @@ -180,38 +187,9 @@ extern #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; @@ -219,93 +197,16 @@ 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; -} - - - -#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 */ /* Maximum amount of C stack to save when a GC happens. */ @@ -376,16 +277,20 @@ memory_full (void) void * xmalloc (size_t size) { - void *val = (void *) malloc (size); + void *val = malloc (size); if (!val && (size != 0)) memory_full (); return val; } +#ifdef xcalloc +#undef xcalloc +#endif + static void * xcalloc (size_t nelem, size_t elsize) { - void *val = (void *) calloc (nelem, elsize); + void *val = calloc (nelem, elsize); if (!val && (nelem != 0)) memory_full (); return val; @@ -406,7 +311,7 @@ xrealloc (void *block, size_t size) { /* We must call malloc explicitly when BLOCK is 0, since some reallocs don't do this. */ - void *val = (void *) (block ? realloc (block, size) : malloc (size)); + void *val = block ? realloc (block, size) : malloc (size); if (!val && (size != 0)) memory_full (); return val; @@ -470,8 +375,7 @@ xstrdup (CONST char *str) 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 @@ -486,19 +390,7 @@ strdup (CONST char *s) 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); } @@ -587,129 +479,66 @@ disksave_object_finalization_1 (void) } } - -/* 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 -} - /************************************************************************/ /* Debugger support */ /************************************************************************/ -/* Give gdb/dbx enough information to decode Lisp Objects. - We make sure certain symbols are defined, so gdb doesn't complain - about expressions in src/gdbinit. Values are randomly chosen. - See src/gdbinit or src/dbxrc to see how this is used. */ - -enum dbg_constants -{ -#ifdef USE_MINIMAL_TAGBITS - dbg_valmask = (EMACS_INT) (((1UL << VALBITS) - 1) << GCBITS), - dbg_typemask = (EMACS_INT) ((1UL << GCTYPEBITS) - 1), - dbg_USE_MINIMAL_TAGBITS = 1, - dbg_Lisp_Type_Int = 100, -#else /* ! USE_MIMIMAL_TAGBITS */ - dbg_valmask = (EMACS_INT) ((1UL << VALBITS) - 1), - dbg_typemask = (EMACS_INT) (((1UL << GCTYPEBITS) - 1) << (VALBITS + GCMARKBITS)), - dbg_USE_MINIMAL_TAGBITS = 0, - dbg_Lisp_Type_Int = Lisp_Type_Int, -#endif /* ! USE_MIMIMAL_TAGBITS */ +/* Give gdb/dbx enough information to decode Lisp Objects. We make + sure certain symbols are always defined, so gdb doesn't complain + about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc + to see how this is used. */ + +EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS; +EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1; #ifdef USE_UNION_TYPE - dbg_USE_UNION_TYPE = 1, +unsigned char dbg_USE_UNION_TYPE = 1; #else - dbg_USE_UNION_TYPE = 0, +unsigned char dbg_USE_UNION_TYPE = 0; #endif -#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION - dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 1, -#else - dbg_USE_INDEXED_LRECORD_IMPLEMENTATION = 0, -#endif +unsigned char Lisp_Type_Int = 100; +unsigned char Lisp_Type_Cons = 101; +unsigned char Lisp_Type_String = 102; +unsigned char Lisp_Type_Vector = 103; +unsigned char Lisp_Type_Symbol = 104; - dbg_Lisp_Type_Char = Lisp_Type_Char, - dbg_Lisp_Type_Record = Lisp_Type_Record, -#ifdef LRECORD_CONS - dbg_Lisp_Type_Cons = 101, -#else - dbg_Lisp_Type_Cons = Lisp_Type_Cons, - lrecord_cons = 201, -#endif -#ifdef LRECORD_STRING - dbg_Lisp_Type_String = 102, -#else - dbg_Lisp_Type_String = Lisp_Type_String, - lrecord_string = 202, -#endif -#ifdef LRECORD_VECTOR - dbg_Lisp_Type_Vector = 103, -#else - dbg_Lisp_Type_Vector = Lisp_Type_Vector, - lrecord_vector = 203, -#endif -#ifdef LRECORD_SYMBOL - dbg_Lisp_Type_Symbol = 104, -#else - dbg_Lisp_Type_Symbol = Lisp_Type_Symbol, - lrecord_symbol = 204, -#endif #ifndef MULE - lrecord_char_table_entry = 205, - lrecord_charset = 206, - lrecord_coding_system = 207, +unsigned char lrecord_char_table_entry; +unsigned char lrecord_charset; +#ifndef FILE_CODING +unsigned char lrecord_coding_system; +#endif #endif + #ifndef HAVE_TOOLBARS - lrecord_toolbar_button = 208, +unsigned char lrecord_toolbar_button; #endif -#ifndef HAVE_TOOLTALK - lrecord_tooltalk_message = 210, - lrecord_tooltalk_pattern = 211, + +#ifndef TOOLTALK +unsigned char lrecord_tooltalk_message; +unsigned char lrecord_tooltalk_pattern; #endif + #ifndef HAVE_DATABASE - lrecord_database = 212, +unsigned char lrecord_database; #endif - dbg_valbits = VALBITS, - dbg_gctypebits = GCTYPEBITS - /* If we don't have an actual object of this enum, pgcc (and perhaps - other compilers) might optimize away the entire type declaration :-( */ -} dbg_dummy; -/* A few macros turned into functions for ease of debugging. +unsigned char dbg_valbits = VALBITS; +unsigned char dbg_gctypebits = GCTYPEBITS; + +/* Macros turned into functions for ease of debugging. Debuggers don't know about macros! */ int dbg_eq (Lisp_Object obj1, Lisp_Object obj2); int @@ -1102,14 +931,13 @@ DECLARE_FIXED_TYPE_ALLOC (cons, struct Lisp_Cons); /* #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); } @@ -1126,6 +954,11 @@ cons_equal (Lisp_Object ob1, Lisp_Object ob2, int depth) 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, @@ -1135,8 +968,8 @@ DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons, * 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. @@ -1148,9 +981,7 @@ 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; @@ -1167,9 +998,7 @@ noseeum_cons (Lisp_Object car, Lisp_Object 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; @@ -1256,9 +1085,9 @@ Return a new list of length LENGTH, with each element being INIT. { Lisp_Object val = Qnil; - int size = XINT (length); + size_t size = XINT (length); - while (size-- > 0) + while (size--) val = Fcons (init, val); return val; } @@ -1281,7 +1110,7 @@ make_float (double float_value) 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; @@ -1294,16 +1123,15 @@ make_float (double float_value) /* 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; } @@ -1331,6 +1159,12 @@ vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) 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, @@ -1340,6 +1174,7 @@ DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION("vector", vector, * knows how to handle vectors. */ 0, + vector_description, size_vector, Lisp_Vector); /* #### should allocate `small' vectors from a frob-block */ @@ -1348,34 +1183,12 @@ make_vector_internal (size_t sizei) { /* 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) { @@ -1534,7 +1347,7 @@ make_bit_vector_internal (size_t sizei) 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"); @@ -1632,27 +1445,14 @@ DECLARE_FIXED_TYPE_ALLOC (compiled_function, Lisp_Compiled_Function); #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; @@ -1686,7 +1486,7 @@ This is terrible behavior which is retained for compatibility with old /* 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]; @@ -1696,22 +1496,6 @@ This is terrible behavior which is retained for compatibility with old 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))); @@ -1751,11 +1535,11 @@ This is terrible behavior which is retained for compatibility with old 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)) @@ -1763,7 +1547,7 @@ This is terrible behavior which is retained for compatibility with old 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; } @@ -1778,61 +1562,19 @@ This is terrible behavior which is retained for compatibility with old #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; } @@ -1856,14 +1598,11 @@ Its value and function definition are void, and its property list is nil. 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; @@ -1883,7 +1622,7 @@ allocate_extent (void) 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); @@ -1913,7 +1652,7 @@ allocate_event (void) 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; @@ -1936,7 +1675,7 @@ Return a new marker which does not point at any place. 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; @@ -1953,7 +1692,7 @@ noseeum_make_marker (void) 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; @@ -1981,18 +1720,17 @@ noseeum_make_marker (void) This new method makes things somewhat bigger, but it is MUCH safer. */ -DECLARE_FIXED_TYPE_ALLOC (string, struct Lisp_String); +DECLARE_FIXED_TYPE_ALLOC (string, Lisp_String); /* strings are used and freed quite often */ /* #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); + 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; } @@ -2005,6 +1743,13 @@ string_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) !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, /* @@ -2018,8 +1763,8 @@ DEFINE_BASIC_LRECORD_IMPLEMENTATION ("string", string, * SWEEP_FIXED_TYPE_BLOCK(). */ 0, string_equal, 0, - struct Lisp_String); -#endif /* LRECORD_STRING */ + string_description, + Lisp_String); /* String blocks contain this many useful bytes. */ #define STRING_CHARS_BLOCK_SIZE \ @@ -2037,34 +1782,29 @@ struct string_chars_block 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 * (including alignment padding). */ -#define STRING_FULLSIZE(s) \ - ALIGN_SIZE (((s) + 1 + sizeof (struct Lisp_String *)),\ - ALIGNOF (struct Lisp_String *)) +#define STRING_FULLSIZE(size) \ + ALIGN_SIZE (((size) + 1 + sizeof (Lisp_String *)),\ + ALIGNOF (Lisp_String *)) #define BIG_STRING_FULLSIZE_P(fullsize) ((fullsize) >= STRING_CHARS_BLOCK_SIZE) #define BIG_STRING_SIZE_P(size) (BIG_STRING_FULLSIZE_P (STRING_FULLSIZE(size))) -#define CHARS_TO_STRING_CHAR(x) \ - ((struct string_chars *) \ - (((char *) (x)) - (slot_offset (struct string_chars, chars[0])))) - - struct string_chars { - struct Lisp_String *string; + Lisp_String *string; unsigned char chars[1]; }; struct unused_string_chars { - struct Lisp_String *string; + Lisp_String *string; EMACS_INT fullsize; }; @@ -2079,19 +1819,14 @@ init_string_chars_alloc (void) } static struct string_chars * -allocate_string_chars_struct (struct Lisp_String *string_it_goes_with, +allocate_string_chars_struct (Lisp_String *string_it_goes_with, EMACS_INT fullsize) { struct string_chars *s_chars; - /* Allocate the string's actual data */ - if (BIG_STRING_FULLSIZE_P (fullsize)) - { - s_chars = (struct string_chars *) xmalloc (fullsize); - } - else if (fullsize <= - (countof (current_string_chars_block->string_chars) - - current_string_chars_block->pos)) + if (fullsize <= + (countof (current_string_chars_block->string_chars) + - current_string_chars_block->pos)) { /* This string can fit in the current string chars block */ s_chars = (struct string_chars *) @@ -2123,23 +1858,20 @@ allocate_string_chars_struct (struct Lisp_String *string_it_goes_with, Lisp_Object make_uninit_string (Bytecount length) { - struct Lisp_String *s; - struct string_chars *s_chars; + Lisp_String *s; EMACS_INT fullsize = STRING_FULLSIZE (length); Lisp_Object val; - if ((length < 0) || (fullsize <= 0)) - abort (); + assert (length >= 0 && fullsize > 0); /* Allocate the string header */ - ALLOCATE_FIXED_TYPE (string, struct Lisp_String, s); -#ifdef LRECORD_STRING - set_lheader_implementation (&(s->lheader), lrecord_string); -#endif + ALLOCATE_FIXED_TYPE (string, Lisp_String, s); + set_lheader_implementation (&(s->lheader), &lrecord_string); - s_chars = allocate_string_chars_struct (s, fullsize); + set_string_data (s, BIG_STRING_FULLSIZE_P (fullsize) + ? xnew_array (Bufbyte, length + 1) + : allocate_string_chars_struct (s, fullsize)->chars); - set_string_data (s, &(s_chars->chars[0])); set_string_length (s, length); s->plist = Qnil; @@ -2160,8 +1892,9 @@ static void verify_string_chars_integrity (void); */ void -resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta) +resize_string (Lisp_String *s, Bytecount pos, Bytecount delta) { + Bytecount oldfullsize, newfullsize; #ifdef VERIFY_STRING_CHARS_INTEGRITY verify_string_chars_integrity (); #endif @@ -2180,47 +1913,59 @@ resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta) } #endif /* ERROR_CHECK_BUFPOS */ - if (pos >= 0 && delta < 0) - /* If DELTA < 0, the functions below will delete the characters - before POS. We want to delete characters *after* POS, however, - so convert this to the appropriate form. */ - pos += -delta; - if (delta == 0) /* simplest case: no size change. */ return; - else - { - Bytecount oldfullsize = STRING_FULLSIZE (string_length (s)); - Bytecount newfullsize = STRING_FULLSIZE (string_length (s) + delta); - if (oldfullsize == newfullsize) + if (pos >= 0 && delta < 0) + /* If DELTA < 0, the functions below will delete the characters + before POS. We want to delete characters *after* POS, however, + so convert this to the appropriate form. */ + pos += -delta; + + oldfullsize = STRING_FULLSIZE (string_length (s)); + newfullsize = STRING_FULLSIZE (string_length (s) + delta); + + if (BIG_STRING_FULLSIZE_P (oldfullsize)) + { + if (BIG_STRING_FULLSIZE_P (newfullsize)) { - /* next simplest case; size change but the necessary - allocation size won't change (up or down; code somewhere - depends on there not being any unused allocation space, - modulo any alignment constraints). */ + /* Both strings are big. We can just realloc(). */ + set_string_data (s, (Bufbyte *) xrealloc (string_data (s), + string_length (s) + delta + 1)); if (pos >= 0) { Bufbyte *addroff = pos + string_data (s); memmove (addroff + delta, addroff, - /* +1 due to zero-termination. */ string_length (s) + 1 - pos); } } - else if (BIG_STRING_FULLSIZE_P (oldfullsize) && - BIG_STRING_FULLSIZE_P (newfullsize)) + else /* String has been demoted from BIG_STRING. */ { - /* next simplest case; the string is big enough to be malloc()ed - itself, so we just realloc. + Bufbyte *new_data = + allocate_string_chars_struct (s, newfullsize)->chars; + Bufbyte *old_data = string_data (s); - It's important not to let the string get below the threshold - for making big strings and still remain malloc()ed; if that - were the case, repeated calls to this function on the same - string could result in memory leakage. */ - set_string_data (s, (Bufbyte *) xrealloc (string_data (s), - newfullsize)); + if (pos >= 0) + { + memcpy (new_data, old_data, pos); + memcpy (new_data + pos + delta, old_data + pos, + string_length (s) + 1 - pos); + } + set_string_data (s, new_data); + xfree (old_data); + } + } + else /* old string is small */ + { + if (oldfullsize == newfullsize) + { + /* special case; size change but the necessary + allocation size won't change (up or down; code + somewhere depends on there not being any unused + allocation space, modulo any alignment + constraints). */ if (pos >= 0) { Bufbyte *addroff = pos + string_data (s); @@ -2232,58 +1977,52 @@ resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta) } else { - /* worst case. We make a new string_chars struct and copy - the string's data into it, inserting/deleting the delta - in the process. The old string data will either get - freed by us (if it was malloc()ed) or will be reclaimed - in the normal course of garbage collection. */ - struct string_chars *s_chars = - allocate_string_chars_struct (s, newfullsize); - Bufbyte *new_addr = &(s_chars->chars[0]); - Bufbyte *old_addr = string_data (s); + Bufbyte *old_data = string_data (s); + Bufbyte *new_data = + BIG_STRING_FULLSIZE_P (newfullsize) + ? xnew_array (Bufbyte, string_length (s) + delta + 1) + : allocate_string_chars_struct (s, newfullsize)->chars; + if (pos >= 0) { - memcpy (new_addr, old_addr, pos); - memcpy (new_addr + pos + delta, old_addr + pos, + memcpy (new_data, old_data, pos); + memcpy (new_data + pos + delta, old_data + pos, string_length (s) + 1 - pos); } - set_string_data (s, new_addr); - if (BIG_STRING_FULLSIZE_P (oldfullsize)) - xfree (old_addr); - else - { - /* We need to mark this chunk of the string_chars_block - as unused so that compact_string_chars() doesn't - freak. */ - struct string_chars *old_s_chars = - (struct string_chars *) ((char *) old_addr - - sizeof (struct Lisp_String *)); - /* Sanity check to make sure we aren't hosed by strange - alignment/padding. */ - assert (old_s_chars->string == s); - MARK_STRUCT_AS_FREE (old_s_chars); - ((struct unused_string_chars *) old_s_chars)->fullsize = - oldfullsize; - } + set_string_data (s, new_data); + + { + /* We need to mark this chunk of the string_chars_block + as unused so that compact_string_chars() doesn't + freak. */ + struct string_chars *old_s_chars = (struct string_chars *) + ((char *) old_data - offsetof (struct string_chars, chars)); + /* Sanity check to make sure we aren't hosed by strange + alignment/padding. */ + assert (old_s_chars->string == s); + MARK_STRUCT_AS_FREE (old_s_chars); + ((struct unused_string_chars *) old_s_chars)->fullsize = + oldfullsize; + } } + } - set_string_length (s, string_length (s) + delta); - /* If pos < 0, the string won't be zero-terminated. - Terminate now just to make sure. */ - string_data (s)[string_length (s)] = '\0'; + set_string_length (s, string_length (s) + delta); + /* If pos < 0, the string won't be zero-terminated. + Terminate now just to make sure. */ + string_data (s)[string_length (s)] = '\0'; - if (pos >= 0) - { - Lisp_Object string; - - XSETSTRING (string, s); - /* We also have to adjust all of the extent indices after the - place we did the change. We say "pos - 1" because - adjust_extents() is exclusive of the starting position - passed to it. */ - adjust_extents (string, pos - 1, string_length (s), - delta); - } + if (pos >= 0) + { + Lisp_Object string; + + XSETSTRING (string, s); + /* We also have to adjust all of the extent indices after the + place we did the change. We say "pos - 1" because + adjust_extents() is exclusive of the starting position + passed to it. */ + adjust_extents (string, pos - 1, string_length (s), + delta); } #ifdef VERIFY_STRING_CHARS_INTEGRITY @@ -2294,7 +2033,7 @@ resize_string (struct Lisp_String *s, Bytecount pos, Bytecount delta) #ifdef MULE void -set_string_char (struct Lisp_String *s, Charcount i, Emchar c) +set_string_char (Lisp_String *s, Charcount i, Emchar c) { Bufbyte newstr[MAX_EMCHAR_LEN]; Bytecount bytoff = charcount_to_bytecount (string_data (s), i); @@ -2327,7 +2066,7 @@ LENGTH must be an integer and INIT must be a character. 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--) @@ -2335,6 +2074,10 @@ LENGTH must be an integer and INIT must be a character. Bufbyte *init_ptr = init_str; switch (len) { +#ifdef UTF2000 + case 6: *ptr++ = *init_ptr++; + case 5: *ptr++ = *init_ptr++; +#endif case 4: *ptr++ = *init_ptr++; case 3: *ptr++ = *init_ptr++; case 2: *ptr++ = *init_ptr++; @@ -2363,6 +2106,7 @@ Concatenate all the argument characters and make the result a string. 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 @@ -2413,6 +2157,29 @@ build_translated_string (CONST char *str) return build_string (GETTEXT (str)); } +Lisp_Object +make_string_nocopy (CONST Bufbyte *contents, Bytecount length) +{ + 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, 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; +} + /************************************************************************/ /* lcrecord lists */ @@ -2426,7 +2193,7 @@ build_translated_string (CONST char *str) 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() @@ -2447,7 +2214,7 @@ build_translated_string (CONST char *str) */ 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; @@ -2484,13 +2251,13 @@ mark_lcrecord_list (Lisp_Object obj, void (*markobj) (Lisp_Object)) 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; @@ -2570,701 +2337,167 @@ free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord) } -/************************************************************************/ -/* 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) -{ - 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)); - - 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; - } - } - } - - if (!check_purespace (size)) - return make_string (data, length); - - 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; - -#ifdef PURESTAT - bump_purestat (&purestat_string_all, size); - if (purecopying_function_constants) - bump_purestat (&purestat_string_other_function, size); -#endif /* PURESTAT */ - - /* Do this after the official "completion" of the purecopying. */ - s->plist = Fpurecopy (plist); - - { - Lisp_Object string; - XSETSTRING (string, s); - return string; - } -} - -Lisp_Object -make_pure_pname (CONST Bufbyte *data, Bytecount length, - int no_need_to_copy_data) + +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_Object name = make_pure_string (data, length, Qnil, - no_need_to_copy_data); - bump_purestat (&purestat_string_pname, pure_sizeof (name)); - - /* We've made (at least) Qnil now, and Vobarray will soon be set up. */ - symbols_initialized = 1; - - return name; + return obj; } -Lisp_Object -pure_cons (Lisp_Object car, Lisp_Object cdr) -{ - Lisp_Cons *c; + +/************************************************************************/ +/* Garbage Collection */ +/************************************************************************/ - if (!check_purespace (sizeof (Lisp_Cons))) - return Fcons (Fpurecopy (car), Fpurecopy (cdr)); +/* This will be used more extensively In The Future */ +static int last_lrecord_type_index_assigned; - 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)); +CONST struct lrecord_implementation *lrecord_implementations_table[128]; +#define max_lrecord_type (countof (lrecord_implementations_table) - 1) - c->car = Fpurecopy (car); - c->cdr = Fpurecopy (cdr); +struct gcpro *gcprolist; - { - Lisp_Object cons; - XSETCONS (cons, c); - return cons; - } -} - -Lisp_Object -pure_list (int nargs, Lisp_Object *args) -{ - Lisp_Object val = Qnil; - - 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); - - f = (struct Lisp_Float *) (PUREBEG + pure_bytes_used); - set_lheader_implementation (&(f->lheader), lrecord_float); -#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION - f->lheader.pure = 1; +/* 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 - pure_bytes_used += sizeof (struct Lisp_Float); - bump_purestat (&purestat_float, sizeof (struct Lisp_Float)); +/* Not "static" because of linker lossage on some systems */ +Lisp_Object *staticvec[NSTATICS] + /* Force it into data space! */ + = {0}; +static int staticidx; - float_data (f) = num; - XSETFLOAT (val, f); - return val; +/* 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 /* LISP_FLOAT_TYPE */ +/* 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_vector (size_t len, Lisp_Object init) +/* Put an entry in staticvec_nodump, pointing at the variable whose address is given + */ +void +staticpro_nodump (Lisp_Object *varaddress) { - 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; - - for (size = 0; size < len; size++) - v->contents[size] = init; - - { - Lisp_Object vector; - XSETVECTOR (vector, v); - return vector; - } + 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; } -#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 (); - - set_lheader_implementation (header, implementation); - header->next = 0; - return header; -} -#endif /* unused */ +/* Not "static" because of linker lossage on some systems */ +struct { + void *data; + const struct struct_description *desc; +} dumpstructvec[200]; +static int dumpstructidx; - -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)) +/* Put an entry in dumpstructvec, pointing at the variable whose address is given + */ +void +dumpstruct (void *varaddress, const struct struct_description *desc) { - 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)) - { - 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; - } - 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; - - XSETOPAQUE (pure_obj, new_opaque); - return pure_obj; - } - else - { - signal_simple_error ("Can't purecopy %S", obj); - } - return obj; /* Unreached */ + if (dumpstructidx >= countof (dumpstructvec)) + abort (); + dumpstructvec[dumpstructidx].data = varaddress; + dumpstructvec[dumpstructidx].desc = desc; + dumpstructidx++; } +Lisp_Object *pdump_wirevec[50]; +static int pdump_wireidx; - -static void -puresize_adjust_h (size_t puresize) -{ - FILE *stream = fopen ("puresize-adjust.h", "w"); - - if (stream == NULL) - report_file_error ("Opening puresize adjustment file", - Fcons (build_string ("puresize-adjust.h"), Qnil)); - - fprintf (stream, - "/*\tDo not edit this file!\n" - "\tAutomatically generated by XEmacs */\n" - "# define PURESIZE_ADJUSTMENT (%ld)\n", - (long) (puresize - RAW_PURESIZE)); - fclose (stream); -} - +/* Put an entry in pdump_wirevec, pointing at the variable whose address is given + */ void -report_pure_usage (int report_impurities, - int die_if_pure_storage_exceeded) +pdump_wire (Lisp_Object *varaddress) { - int rc = 0; - - if (pure_lossage) - { - 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) - { - puresize_adjust_h (get_PURESIZE() + pure_lossage); -#ifdef HEAP_IN_DATA - sheap_adjust_h(); -#endif - rc = -1; - } - } - else - { - 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; - } - } - - strcat (buf, ")."); - message ("%s", buf); - } - -#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 */ - - - if (report_impurities) - { - 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_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); - } - } - 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"); - } + if (pdump_wireidx >= countof (pdump_wirevec)) + abort (); + pdump_wirevec[pdump_wireidx++] = varaddress; } - -/************************************************************************/ -/* Garbage Collection */ -/************************************************************************/ - -/* This will be used more extensively In The Future */ -static int last_lrecord_type_index_assigned; - -CONST struct lrecord_implementation *lrecord_implementations_table[128]; -#define max_lrecord_type (countof (lrecord_implementations_table) - 1) - -struct gcpro *gcprolist; -/* 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; +Lisp_Object *pdump_wirevec_list[50]; +static int pdump_wireidx_list; -/* Put an entry in staticvec, pointing at the variable whose address is given +/* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given */ void -staticpro (Lisp_Object *varaddress) +pdump_wire_list (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. */ + if (pdump_wireidx_list >= countof (pdump_wirevec_list)) abort (); - staticvec[staticidx++] = varaddress; + pdump_wirevec_list[pdump_wireidx_list++] = varaddress; } /* 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 +void mark_object (Lisp_Object obj) { tail_recurse: #ifdef ERROR_CHECK_GC - assert (! (GC_EQ (obj, Qnull_pointer))); + 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; */ - switch (XGCTYPE (obj)) + if (XTYPE (obj) == Lisp_Type_Record) { -#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 - - 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); + struct lrecord_header *lheader = XRECORD_LHEADER (obj); +#if defined (ERROR_CHECK_GC) + assert (lheader->type <= last_lrecord_type_index_assigned); #endif - if (PURIFIED (lheader)) - return; + if (C_READONLY_RECORD_HEADER_P (lheader)) + return; - if (! MARKED_RECORD_HEADER_P (lheader) && - ! UNMARKABLE_RECORD_HEADER_P (lheader)) - { - CONST struct lrecord_implementation *implementation = - LHEADER_IMPLEMENTATION (lheader); - MARK_RECORD_HEADER (lheader); + 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); + 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; - - while (!XMARKBIT (sym->plist)) - { - XMARK (sym->plist); - mark_object (sym->value); - mark_object (sym->function); + if (implementation->marker) { - /* - * 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); + obj = implementation->marker (obj); + if (!NILP (obj)) goto tail_recurse; } - 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 */ + } } } @@ -3290,82 +2523,15 @@ mark_conses_in_list (Lisp_Object obj) } -#ifdef PURESTAT -/* Simpler than mark-object, because pure structure can't - have any circularities */ - -static size_t -pure_string_sizeof (Lisp_Object obj) -{ - struct Lisp_String *ptr = XSTRING (obj); - - 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 - { - size_t size = sizeof (*ptr) + string_length (ptr) + 1; - size = ALIGN_SIZE (size, sizeof (Lisp_Object)); - return size; - } -} - -static size_t -pure_sizeof (Lisp_Object obj) -{ - 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); - - 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 */ -} -#endif /* PURESTAT */ +/* Find all structures not marked, and free them. */ +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; - - -/* 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; - -/* static int gc_count_total_records_used, gc_count_records_total_size; */ +/* static int gc_count_total_records_used, gc_count_records_total_size; */ int @@ -3378,8 +2544,7 @@ lrecord_type_index (CONST struct lrecord_implementation *implementation) if (type_index < 0 || type_index > max_lrecord_type || lrecord_implementations_table[type_index] != implementation) { - if (last_lrecord_type_index_assigned == max_lrecord_type) - abort (); + 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; @@ -3398,21 +2563,6 @@ static struct int instances_on_free_list; } lcrecord_stats [countof (lrecord_implementations_table)]; - -static void -reset_lcrecord_stats (void) -{ - int i; - for (i = 0; i < countof (lcrecord_stats); i++) - { - lcrecord_stats[i].instances_in_use = 0; - lcrecord_stats[i].bytes_in_use = 0; - lcrecord_stats[i].instances_freed = 0; - lcrecord_stats[i].bytes_freed = 0; - lcrecord_stats[i].instances_on_free_list = 0; - } -} - static void tick_lcrecord_stats (CONST struct lrecord_header *h, int free_p) { @@ -3452,7 +2602,8 @@ sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) struct lcrecord_header *header; int num_used = 0; /* int total_size = 0; */ - reset_lcrecord_stats (); + + xzero (lcrecord_stats); /* Reset all statistics to 0. */ /* First go through and call all the finalize methods. Then go through and free the objects. There used to @@ -3467,7 +2618,9 @@ sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) for (header = *prev; header; header = header->next) { struct lrecord_header *h = &(header->lheader); - if (!MARKED_RECORD_HEADER_P (h) && ! (header->free)) + if (!C_READONLY_RECORD_HEADER_P(h) + && !MARKED_RECORD_HEADER_P (h) + && ! (header->free)) { if (LHEADER_IMPLEMENTATION (h)->finalizer) LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); @@ -3477,11 +2630,13 @@ sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) for (header = *prev; header; ) { struct lrecord_header *h = &(header->lheader); - if (MARKED_RECORD_HEADER_P (h)) + if (C_READONLY_RECORD_HEADER_P(h) || MARKED_RECORD_HEADER_P (h)) { - UNMARK_RECORD_HEADER (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); @@ -3500,47 +2655,6 @@ sweep_lcrecords_1 (struct lcrecord_header **prev, int *used) /* *total = total_size; */ } -#ifndef LRECORD_VECTOR - -static void -sweep_vectors_1 (Lisp_Object *prev, - int *used, int *total, int *storage) -{ - Lisp_Object vector; - int num_used = 0; - int total_size = 0; - int total_storage = 0; - - for (vector = *prev; VECTORP (vector); ) - { - 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; - } - } - *used = num_used; - *total = total_size; - *storage = total_storage; -} - -#endif /* ! LRECORD_VECTOR */ static void sweep_bit_vectors_1 (Lisp_Object *prev, @@ -3557,15 +2671,17 @@ sweep_bit_vectors_1 (Lisp_Object *prev, { Lisp_Bit_Vector *v = XBIT_VECTOR (bit_vector); int len = v->size; - if (MARKED_RECORD_P (bit_vector)) + if (C_READONLY_RECORD_HEADER_P(&(v->lheader)) || MARKED_RECORD_P (bit_vector)) { - UNMARK_RECORD_HEADER (&(v->lheader)); + 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; } @@ -3610,7 +2726,11 @@ do { \ { \ num_free++; \ } \ - else if (!MARKED_##typename##_P (SFTB_victim)) \ + 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); \ @@ -3660,7 +2780,12 @@ do { \ num_free++; \ PUT_FIXED_TYPE_ON_FREE_LIST (typename, obj_type, SFTB_victim); \ } \ - else if (!MARKED_##typename##_P (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); \ @@ -3713,13 +2838,7 @@ do { \ 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 UNMARK_cons(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) #define ADDITIONAL_FREE_cons(ptr) SWEEP_FIXED_TYPE_BLOCK (cons, struct Lisp_Cons); @@ -3783,8 +2902,6 @@ free_alist (Lisp_Object alist) static void sweep_compiled_functions (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) @@ -3796,7 +2913,6 @@ sweep_compiled_functions (void) 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) @@ -3807,13 +2923,7 @@ sweep_floats (void) 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 UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) #define ADDITIONAL_FREE_symbol(ptr) SWEEP_FIXED_TYPE_BLOCK (symbol, struct Lisp_Symbol); @@ -3822,7 +2932,6 @@ sweep_symbols (void) 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) @@ -3832,7 +2941,6 @@ sweep_extents (void) 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) @@ -3842,7 +2950,6 @@ sweep_events (void) 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; \ @@ -3861,7 +2968,7 @@ free_marker (struct Lisp_Marker *ptr) /* Perhaps this will catch freeing an already-freed marker. */ Lisp_Object temmy; XSETMARKER (temmy, ptr); - assert (GC_MARKERP (temmy)); + assert (MARKERP (temmy)); #endif /* ERROR_CHECK_GC */ #ifndef ALLOC_NO_POOLS @@ -3886,7 +2993,7 @@ verify_string_chars_integrity (void) { struct string_chars *s_chars = (struct string_chars *) &(sb->string_chars[pos]); - struct Lisp_String *string; + Lisp_String *string; int size; int fullsize; @@ -3937,7 +3044,7 @@ compact_string_chars (void) 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; + Lisp_String *string; int size; int fullsize; @@ -3967,11 +3074,7 @@ compact_string_chars (void) abort (); /* 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; @@ -4026,7 +3129,7 @@ compact_string_chars (void) static int debug_string_purity; static void -debug_string_purity_print (struct Lisp_String *p) +debug_string_purity_print (Lisp_String *p) { Charcount i; Charcount s = string_char_length (p); @@ -4052,49 +3155,25 @@ sweep_strings (void) int num_small_used = 0, num_small_bytes = 0, num_bytes = 0; int debug = debug_string_purity; -#ifdef LRECORD_STRING - -# 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) - -#else - -# 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) - -#endif /* ! LRECORD_STRING */ +#define UNMARK_string(ptr) do { \ + Lisp_String *p = (ptr); \ + size_t 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(ptr) do { \ + size_t size = string_length (ptr); \ + if (BIG_STRING_SIZE_P (size)) \ + xfree (ptr->data); \ + } while (0) - SWEEP_FIXED_TYPE_BLOCK (string, struct Lisp_String); + SWEEP_FIXED_TYPE_BLOCK (string, Lisp_String); gc_count_num_short_string_in_use = num_small_used; gc_count_string_total_size = num_bytes; @@ -4103,68 +3182,26 @@ sweep_strings (void) /* I hate duplicating all this crap! */ -static int +int marked_p (Lisp_Object obj) { #ifdef ERROR_CHECK_GC - assert (! (GC_EQ (obj, Qnull_pointer))); + 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; */ - switch (XGCTYPE (obj)) + if (XTYPE (obj) == Lisp_Type_Record) { -#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 - - /* 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; + 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 @@ -4200,13 +3237,6 @@ gc_sweep (void) /* Put all unmarked conses on free list */ sweep_conses (); -#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 - /* Free all unmarked bit vectors */ sweep_bit_vectors_1 (&all_bit_vectors, &gc_count_num_bit_vector_used, @@ -4233,6 +3263,27 @@ gc_sweep (void) sweep_events (); +#ifdef PDUMP + /* Unmark all dumped objects */ + { + int i; + char *p = pdump_rt_list; + if(p) + for(;;) + { + pdump_reloc_table *rt = (pdump_reloc_table *)p; + p += sizeof (pdump_reloc_table); + if (rt->desc) { + for (i=0; icount; i++) + { + UNMARK_RECORD_HEADER ((struct lrecord_header *)(*(EMACS_INT *)p)); + p += sizeof (EMACS_INT); + } + } else + break; + } + } +#endif } /* Clearing for disksave. */ @@ -4259,6 +3310,8 @@ disksave_object_finalization (void) 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) || \ @@ -4272,14 +3325,6 @@ disksave_object_finalization (void) /* Run the disksave finalization methods of all live objects. */ disksave_object_finalization_1 (); -#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 - /* Zero out the uninitialized (really, unused) part of the containers for the live strings. */ { @@ -4319,7 +3364,6 @@ garbage_collect_1 (void) char stack_top_variable; extern char *stack_bottom; #endif - int i; struct frame *f; int speccount; int cursor_changed; @@ -4436,38 +3480,47 @@ garbage_collect_1 (void) cleanup_specifiers (); /* Mark all the special slots that serve as the roots of accessibility. */ - { - struct gcpro *tail; - struct catchtag *catch; - struct backtrace *backlist; - struct specbinding *bind; + { /* staticpro() */ + int i; for (i = 0; i < staticidx; i++) - { - mark_object (*(staticvec[i])); - } + mark_object (*(staticvec[i])); + for (i = 0; i < staticidx_nodump; i++) + mark_object (*(staticvec_nodump[i])); + } + { /* 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 (i = 0; i < tail->nvars; i++) + mark_object (tail->var[i]); + } + { /* specbind() */ + struct specbinding *bind; for (bind = specpdl; bind != specpdl_ptr; bind++) { mark_object (bind->symbol); mark_object (bind->old_value); } + } + { + struct catchtag *catch; for (catch = catchlist; catch; catch = catch->next) { mark_object (catch->tag); mark_object (catch->val); } + } + { + struct backtrace *backlist; for (backlist = backtrace_list; backlist; backlist = backlist->next) { int nargs = backlist->nargs; + int i; mark_object (*backlist->function); if (nargs == UNEVALLED || nargs == MANY) @@ -4476,11 +3529,11 @@ garbage_collect_1 (void) for (i = 0; i < nargs; i++) mark_object (backlist->args[i]); } - - mark_redisplay (mark_object); - mark_profiling_info (mark_object); } + mark_redisplay (); + mark_profiling_info (); + /* 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. @@ -4488,18 +3541,18 @@ garbage_collect_1 (void) weak hash table, the former one might get marked. So we have to iterate until nothing more gets marked. */ - while (finish_marking_weak_hash_tables (marked_p, mark_object) > 0 || - finish_marking_weak_lists (marked_p, mark_object) > 0) + while (finish_marking_weak_hash_tables () > 0 || + finish_marking_weak_lists () > 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 (marked_p); - prune_weak_lists (marked_p); - prune_specifiers (marked_p); - prune_syntax_tables (marked_p); + prune_weak_hash_tables (); + prune_weak_lists (); + prune_specifiers (); + prune_syntax_tables (); gc_sweep (); @@ -4589,16 +3642,11 @@ Garbage collection happens automatically if you cons more than { 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++) + for (i = 0; i <= last_lrecord_type_index_assigned; i++) { if (lcrecord_stats[i].bytes_in_use != 0 || lcrecord_stats[i].bytes_freed != 0 @@ -4607,12 +3655,11 @@ Garbage collection happens automatically if you cons more than 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) + if (i == *lrecord_vector.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' */ @@ -4671,13 +3718,6 @@ Garbage collection happens automatically if you cons more than pl = gc_plist_hack ("compiled-functions-used", gc_count_num_compiled_function_in_use, pl); -#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 - 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); @@ -4880,46 +3920,10 @@ fixed_type_block_overhead (size_t size) /* Initialization */ void -init_alloc_once_early (void) +reinit_alloc_once_early (void) { - int iii; - - last_lrecord_type_index_assigned = -1; - for (iii = 0; iii < countof (lrecord_implementations_table); iii++) - { - lrecord_implementations_table[iii] = 0; - } - -#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 */ - - symbols_initialized = 0; - gc_generation_number[0] = 0; - /* purify_flag 1 is correct even if CANNOT_DUMP. - * loadup.el will set to nil at end. */ - purify_flag = 1; - 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; @@ -4944,7 +3948,11 @@ init_alloc_once_early (void) init_event_alloc (); ignore_malloc_warnings = 0; - staticidx = 0; + + staticidx_nodump = 0; + dumpstructidx = 0; + pdump_wireidx = 0; + consing_since_gc = 0; #if 1 gc_cons_threshold = 500000; /* XEmacs change */ @@ -4974,6 +3982,40 @@ init_alloc_once_early (void) } void +init_alloc_once_early (void) +{ + int iii; + + reinit_alloc_once_early (); + + last_lrecord_type_index_assigned = -1; + for (iii = 0; iii < countof (lrecord_implementations_table); iii++) + { + lrecord_implementations_table[iii] = 0; + } + + /* + * 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); + + staticidx = 0; +} + +int pure_bytes_used = 0; + +void reinit_alloc (void) { gcprolist = 0; @@ -5052,7 +4094,7 @@ Length (in stack frames) of short backtrace printed out by `debug-allocation'. 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. +This means that certain objects should be allocated in readonly space. */ ); DEFVAR_LISP ("pre-gc-hook", &Vpre_gc_hook /* @@ -5078,9 +4120,7 @@ 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); + Vgc_message = build_string (gc_default_message); DEFVAR_LISP ("gc-pointer-glyph", &Vgc_pointer_glyph /* Pointer glyph used to indicate that a garbage collection is in progress. @@ -5097,3 +4137,982 @@ complex_vars_of_alloc (void) { Vgc_pointer_glyph = Fmake_glyph_internal (Qpointer); } + + +#ifdef PDUMP + +/* The structure of the file + * + * 0 - header + * 256 - dumped objects + * stab_offset - nb_staticpro*(Lisp_Object *) from staticvec + * - nb_staticpro*(relocated Lisp_Object) pointed to by staticpro + * - nb_structdmp*pair(void *, adr) for pointers to structures + * - lrecord_implementations_table[] + * - relocation table + * - wired variable address/value couples with the count preceding the list + */ +typedef struct +{ + char signature[8]; + EMACS_UINT stab_offset; + EMACS_UINT reloc_address; + int nb_staticpro; + int nb_structdmp; + int last_type; +} dump_header; + +char *pdump_start, *pdump_end; + +static const unsigned char align_table[256] = +{ + 8, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, + 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 +}; + +typedef struct pdump_entry_list_elmt +{ + struct pdump_entry_list_elmt *next; + const void *obj; + size_t size; + int count; + int is_lrecord; + EMACS_INT save_offset; +} pdump_entry_list_elmt; + +typedef struct +{ + pdump_entry_list_elmt *first; + int align; + int count; +} pdump_entry_list; + +typedef struct pdump_struct_list_elmt +{ + pdump_entry_list list; + const struct struct_description *sdesc; +} pdump_struct_list_elmt; + +typedef struct +{ + pdump_struct_list_elmt *list; + int count; + int size; +} pdump_struct_list; + +static pdump_entry_list pdump_object_table[256]; +static pdump_entry_list pdump_opaque_data_list; +static pdump_struct_list pdump_struct_table; +static pdump_entry_list_elmt *pdump_qnil; + +static int pdump_alert_undump_object[256]; + +static unsigned long cur_offset; +static size_t max_size; +static int pdump_fd; +static void *pdump_buf; + +#define PDUMP_HASHSIZE 200001 + +static pdump_entry_list_elmt **pdump_hash; + +/* Since most pointers are eight bytes aligned, the >>3 allows for a better hash */ +static int +pdump_make_hash (const void *obj) +{ + return ((unsigned long)(obj)>>3) % PDUMP_HASHSIZE; +} + +static pdump_entry_list_elmt * +pdump_get_entry (const void *obj) +{ + int pos = pdump_make_hash(obj); + pdump_entry_list_elmt *e; + while ((e = pdump_hash[pos]) != 0) + { + if (e->obj == obj) + return e; + + pos++; + if (pos == PDUMP_HASHSIZE) + pos = 0; + } + return 0; +} + +static void +pdump_add_entry (pdump_entry_list *list, const void *obj, size_t size, int count, int is_lrecord) +{ + pdump_entry_list_elmt *e; + int align; + int pos = pdump_make_hash (obj); + + while ((e = pdump_hash[pos]) != 0) + { + if (e->obj == obj) + return; + + pos++; + if (pos == PDUMP_HASHSIZE) + pos = 0; + } + + e = malloc (sizeof (pdump_entry_list_elmt)); + + e->next = list->first; + e->obj = obj; + e->size = size; + e->count = count; + e->is_lrecord = is_lrecord; + list->first = e; + + list->count += count; + pdump_hash[pos] = e; + + align = align_table[size & 255]; + if (align<2 && is_lrecord) + align = 2; + + if(align < list->align) + list->align = align; +} + +static pdump_entry_list * +pdump_get_entry_list(const struct struct_description *sdesc) +{ + int i; + for(i=0; iname, + backtrace[i].position, + backtrace[i].offset); + } + } +} + +static void pdump_register_object (Lisp_Object obj); +static void pdump_register_struct (const void *data, const struct struct_description *sdesc, int count); + +static EMACS_INT +pdump_get_indirect_count (EMACS_INT code, const struct lrecord_description *idesc, const void *idata) +{ + EMACS_INT count; + const void *irdata; + + int line = XD_INDIRECT_VAL (code); + int delta = XD_INDIRECT_DELTA (code); + + irdata = ((char *)idata) + idesc[line].offset; + switch (idesc[line].type) { + case XD_SIZE_T: + count = *(size_t *)irdata; + break; + case XD_INT: + count = *(int *)irdata; + break; + case XD_LONG: + count = *(long *)irdata; + break; + case XD_BYTECOUNT: + count = *(Bytecount *)irdata; + break; + default: + fprintf (stderr, "Unsupported count type : %d (line = %d, code=%ld)\n", idesc[line].type, line, (long)code); + pdump_backtrace (); + abort (); + } + count += delta; + return count; +} + +static void +pdump_register_sub (const void *data, const struct lrecord_description *desc, int me) +{ + int pos; + const void *rdata; + + restart: + for (pos = 0; desc[pos].type != XD_END; pos++) + { + backtrace[me].position = pos; + backtrace[me].offset = desc[pos].offset; + + 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;idescription) + { + 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 + { + pdump_alert_undump_object[XRECORD_LHEADER (obj)->type]++; + fprintf (stderr, "Undumpable object type : %s\n", XRECORD_LHEADER_IMPLEMENTATION (obj)->name); + pdump_backtrace (); + } +} + +static void +pdump_register_struct (const void *data, const struct struct_description *sdesc, int count) +{ + if (data && !pdump_get_entry (data)) + { + int me = depth++; + int i; + if (me>65536) + { + fprintf (stderr, "Backtrace overflow, loop ?\n"); + abort (); + } + backtrace[me].obj = 0; + backtrace[me].position = 0; + backtrace[me].offset = 0; + + pdump_add_entry (pdump_get_entry_list (sdesc), + data, + sdesc->size, + count, + 0); + for (i=0; isize*i, + sdesc->description, + me); + } + --depth; + } +} + +static void +pdump_dump_data (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc) +{ + size_t size = elmt->size; + int count = elmt->count; + if (desc) + { + int pos, i; + void *rdata; + memcpy (pdump_buf, elmt->obj, size*count); + + for (i=0; iobj))->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; isave_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; isave_offset; + } + break; + } + case XD_DOC_STRING: + { + EMACS_INT str = *(EMACS_INT *)rdata; + if (str > 0) + *(EMACS_INT *)rdata = pdump_get_entry ((void *)str)->save_offset; + break; + } + default: + fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type); + abort (); + }; + } + } + } + write (pdump_fd, desc ? pdump_buf : elmt->obj, size*count); + if (elmt->is_lrecord && ((size*count) & 3)) + write (pdump_fd, "\0\0\0", 4-((size*count) & 3)); +} + +static void +pdump_reloc_one (void *data, EMACS_INT delta, const struct lrecord_description *desc) +{ + int pos; + void *rdata; + + 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 0) + *(EMACS_INT *)rdata = str + delta; + break; + } + default: + fprintf (stderr, "Unsupported dump type : %d\n", desc[pos].type); + abort (); + }; + } +} + +static void +pdump_allocate_offset (pdump_entry_list_elmt *elmt, const struct lrecord_description *desc) +{ + size_t size = (elmt->is_lrecord ? (elmt->size + 3) & ~3 : elmt->size)*elmt->count; + elmt->save_offset = cur_offset; + if (size>max_size) + max_size = size; + cur_offset += size; +} + +static void +pdump_scan_by_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; idescription; + 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; isave_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; isave_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; + } + } + + rt.desc = 0; + rt.count = 0; + write (pdump_fd, &rt, sizeof (rt)); + + for (i=0; idescription; + 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; jcount; j++) { + write (pdump_fd, &rdata, sizeof (rdata)); + rdata += elmt->size; + } + elmt = elmt->next; + } + } + rt.desc = 0; + rt.count = 0; + write (pdump_fd, &rt, sizeof (rt)); +} + +static void +pdump_dump_wired (void) +{ + EMACS_INT count = pdump_wireidx + pdump_wireidx_list; + int i; + + write (pdump_fd, &count, sizeof (count)); + + for (i=0; isave_offset; + write (pdump_fd, &pdump_wirevec[i], sizeof (pdump_wirevec[i])); + write (pdump_fd, &obj, sizeof (obj)); + } + + for (i=0; idescription; + for (pos = 0; desc[pos].type != XD_LO_LINK; pos++) + if (desc[pos].type == XD_END) + abort (); + + obj = *(Lisp_Object *)(desc[pos].offset + (char *)(XRECORD_LHEADER (obj))); + } + res = elmt->save_offset; + + write (pdump_fd, &pdump_wirevec_list[i], sizeof (pdump_wirevec_list[i])); + write (pdump_fd, &res, sizeof (res)); + } +} + +void +pdump (void) +{ + int i; + Lisp_Object t_console, t_device, t_frame; + int none; + dump_header hd; + + /* These appear in a DEFVAR_LISP, which does a staticpro() */ + t_console = Vterminal_console; + t_frame = Vterminal_frame; + t_device = Vterminal_device; + + Vterminal_console = Qnil; + Vterminal_frame = Qnil; + Vterminal_device = Qnil; + + pdump_hash = 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++) + { + 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; iname, pdump_alert_undump_object[i]); + } + if (!none) + return; + + for (i=0; inb_staticpro; + last_lrecord_type_index_assigned = ((dump_header *)(pdump_start))->last_type; + delta = ((EMACS_INT)pdump_start) - ((dump_header *)pdump_start)->reloc_address; + p = pdump_start + ((dump_header *)pdump_start)->stab_offset; + + /* Put back the staticvec in place */ + memcpy (staticvec, p, staticidx*sizeof (Lisp_Object *)); + p += staticidx*sizeof (Lisp_Object *); + for (i=0; inb_structdmp; i++) + { + void **adr = *(void **)p; + p += sizeof (void *); + *adr = (void *)((*(EMACS_INT *)p) + delta); + p += sizeof (EMACS_INT); + } + + /* Put back the lrecord_implementations_table */ + memcpy (lrecord_implementations_table, p, sizeof (lrecord_implementations_table)); + p += sizeof (lrecord_implementations_table); + + /* Give back their numbers to the lrecord implementations */ + for (i=0; ilrecord_type_index) = i; + last_lrecord_type_index_assigned = i; + } + + /* 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; icount; 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; idesc) + break; + if (rt->desc == hash_table_description) + { + for (i=0; icount; 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