-#ifdef ERROR_CHECK_GC
- /* Make sure the size is correct. This will catch, for example,
- putting a window configuration on the wrong free list. */
- if (implementation->size_in_bytes_method)
- assert (implementation->size_in_bytes_method (lheader) == list->size);
- else
- assert (implementation->static_size == list->size);
-#endif /* ERROR_CHECK_GC */
-
- if (implementation->finalizer)
- implementation->finalizer (lheader, 0);
- free_header->chain = list->free;
- free_header->lcheader.free = 1;
- list->free = lcrecord;
-}
-
-\f
-/************************************************************************/
-/* Purity of essence, peace on earth */
-/************************************************************************/
-
-static int symbols_initialized;
-
-Lisp_Object
-make_pure_string (CONST Bufbyte *data, Bytecount length,
- Lisp_Object plist, int no_need_to_copy_data)
-{
- 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)
-{
- 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;
-}
-
-
-Lisp_Object
-pure_cons (Lisp_Object car, Lisp_Object cdr)
-{
- Lisp_Cons *c;
-
- if (!check_purespace (sizeof (Lisp_Cons)))
- return Fcons (Fpurecopy (car), Fpurecopy (cdr));
-
- c = (Lisp_Cons *) (PUREBEG + pure_bytes_used);
-#ifdef LRECORD_CONS
- set_lheader_implementation (&(c->lheader), lrecord_cons);
-#ifdef USE_INDEXED_LRECORD_IMPLEMENTATION
- c->lheader.pure = 1;
-#endif
-#endif
- pure_bytes_used += sizeof (Lisp_Cons);
- bump_purestat (&purestat_cons, sizeof (Lisp_Cons));
-
- c->car = Fpurecopy (car);
- c->cdr = Fpurecopy (cdr);
-
- {
- Lisp_Object 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;
-#endif
- pure_bytes_used += sizeof (struct Lisp_Float);
- bump_purestat (&purestat_float, sizeof (struct Lisp_Float));
-
- float_data (f) = num;
- XSETFLOAT (val, f);
- return val;
-}
-
-#endif /* LISP_FLOAT_TYPE */
-
-Lisp_Object
-make_pure_vector (size_t len, Lisp_Object init)
-{
- 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 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 */
-
-
-\f
-DEFUN ("purecopy", Fpurecopy, 1, 1, 0, /*
-Make a copy of OBJECT in pure storage.
-Recursively copies contents of vectors and cons cells.
-Does not copy symbols.
-*/
- (obj))
-{
- 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 */
-}
-
-
-\f
-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);
-}
-
-void
-report_pure_usage (int report_impurities,
- int die_if_pure_storage_exceeded)
-{
- 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 */