#include <config.h>
#include "lisp.h"
-#include "alloc.h"
#include "backtrace.h"
#include "buffer.h"
#include "bytecode.h"
After doing the mark phase, GC will walk this linked list
and free any lcrecord which hasn't been marked. */
static struct lcrecord_header *all_lcrecords;
+#ifdef UTF2000
+static struct lcrecord_header *all_older_lcrecords;
+#endif
void *
alloc_lcrecord (size_t size, const struct lrecord_implementation *implementation)
return lcheader;
}
+#ifdef UTF2000
+void *
+alloc_older_lcrecord (size_t size,
+ const struct lrecord_implementation *implementation)
+{
+ struct lcrecord_header *lcheader;
+
+ type_checking_assert
+ ((implementation->static_size == 0 ?
+ implementation->size_in_bytes_method != NULL :
+ implementation->static_size == size)
+ &&
+ (! implementation->basic_p)
+ &&
+ (! (implementation->hash == NULL && implementation->equal != NULL)));
+
+ lcheader = (struct lcrecord_header *) allocate_lisp_storage (size);
+ set_lheader_older_implementation (&lcheader->lheader, implementation);
+ lcheader->next = all_older_lcrecords;
+#if 1 /* mly prefers to see small ID numbers */
+ lcheader->uid = lrecord_uid_counter++;
+#else /* jwz prefers to see real addrs */
+ lcheader->uid = (int) &lcheader;
+#endif
+ lcheader->free = 0;
+ all_older_lcrecords = lcheader;
+ INCREMENT_CONS_COUNTER (size, implementation->name);
+ return lcheader;
+}
+#endif
+
#if 0 /* Presently unused */
/* Very, very poor man's EGC?
* This may be slow and thrash pages all over the place.
!header->free)
LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
}
+#ifdef UTF2000
+ for (header = all_older_lcrecords; header; header = header->next)
+ {
+ if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer &&
+ !header->free)
+ LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1);
+ }
+#endif
}
\f
about expressions in src/.gdbinit. See src/.gdbinit or src/.dbxrc
to see how this is used. */
-EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
-EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
+const EMACS_UINT dbg_valmask = ((1UL << VALBITS) - 1) << GCBITS;
+const EMACS_UINT dbg_typemask = (1UL << GCTYPEBITS) - 1;
#ifdef USE_UNION_TYPE
-unsigned char dbg_USE_UNION_TYPE = 1;
+const unsigned char dbg_USE_UNION_TYPE = 1;
#else
-unsigned char dbg_USE_UNION_TYPE = 0;
+const unsigned char dbg_USE_UNION_TYPE = 0;
#endif
-unsigned char dbg_valbits = VALBITS;
-unsigned char dbg_gctypebits = GCTYPEBITS;
+const unsigned char dbg_valbits = VALBITS;
+const unsigned char dbg_gctypebits = GCTYPEBITS;
/* Macros turned into functions for ease of debugging.
Debuggers don't know about macros! */
/* The construct (* (void **) (ptr)) would cause aliasing problems
with modern optimizing compilers like `gcc -O3 -fstrict-aliasing'.
- But `char *' can legally alias any pointer. Hence this union trick. */
+ But `char *' can legally alias any pointer. Hence this union trick...
+
+ It turned out that the union trick was not good enough for xlC -O3;
+ and it is questionable whether it really complies with the C standard.
+ so we use memset instead, which should be safe from optimizations. */
typedef union { char c; void *p; } *aliasing_voidpp;
#define ALIASING_VOIDPP_DEREFERENCE(ptr) \
(((aliasing_voidpp) (ptr))->p)
#define FREE_STRUCT_P(ptr) \
(ALIASING_VOIDPP_DEREFERENCE (ptr) == (void *) INVALID_POINTER_VALUE)
-#define MARK_STRUCT_AS_FREE(ptr) \
- (ALIASING_VOIDPP_DEREFERENCE (ptr) = (void *) INVALID_POINTER_VALUE)
-#define MARK_STRUCT_AS_NOT_FREE(ptr) \
- (ALIASING_VOIDPP_DEREFERENCE (ptr) = 0)
+#define MARK_STRUCT_AS_FREE(ptr) memset (ptr, 0xff, sizeof (void *))
+#define MARK_STRUCT_AS_NOT_FREE(ptr) memset (ptr, 0x00, sizeof (void *))
#ifdef ERROR_CHECK_GC
}
}
+#ifdef HAVE_GGC
+Lisp_Object
+make_older_vector (size_t length, Lisp_Object init)
+{
+ struct lcrecord_header* orig_all_lcrecords = all_lcrecords;
+ Lisp_Object obj;
+
+ all_lcrecords = all_older_lcrecords;
+ obj = make_vector (length, init);
+ all_older_lcrecords = all_lcrecords;
+ all_lcrecords = orig_all_lcrecords;
+ return obj;
+}
+
+void make_vector_newer_1 (Lisp_Object v);
+void
+make_vector_newer_1 (Lisp_Object v)
+{
+ struct lcrecord_header* lcrecords = all_older_lcrecords;
+
+ if (lcrecords != NULL)
+ {
+ if (lcrecords == XPNTR (v))
+ {
+ lcrecords->lheader.older = 0;
+ all_older_lcrecords = all_older_lcrecords->next;
+ lcrecords->next = all_lcrecords;
+ all_lcrecords = lcrecords;
+ return;
+ }
+ else
+ {
+ struct lcrecord_header* plcrecords = lcrecords;
+
+ lcrecords = lcrecords->next;
+ while (lcrecords != NULL)
+ {
+ if (lcrecords == XPNTR (v))
+ {
+ lcrecords->lheader.older = 0;
+ plcrecords->next = lcrecords->next;
+ lcrecords->next = all_lcrecords;
+ all_lcrecords = lcrecords;
+ return;
+ }
+ plcrecords = lcrecords;
+ lcrecords = lcrecords->next;
+ }
+ }
+ }
+}
+
+void
+make_vector_newer (Lisp_Object v)
+{
+ int i;
+
+ for (i = 0; i < XVECTOR_LENGTH (v); i++)
+ {
+ Lisp_Object obj = XVECTOR_DATA (v)[i];
+
+ if (VECTORP (obj) && !EQ (obj, v))
+ make_vector_newer (obj);
+ }
+ make_vector_newer_1 (v);
+}
+#endif
+
DEFUN ("make-vector", Fmake_vector, 2, 2, 0, /*
Return a new vector of length LENGTH, with each element being OBJECT.
See also the function `vector'.
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++;
struct gcpro *gcprolist;
-/* 415 used Mly 29-Jun-93 */
-/* 1327 used slb 28-Feb-98 */
-/* 1328 used og 03-Oct-99 (moving slowly, heh?) */
-#ifdef HAVE_SHLIB
-#define NSTATICS 4000
-#else
-#define NSTATICS 2000
-#endif
-
-/* Not "static" because used by dumper.c */
-Lisp_Object *staticvec[NSTATICS];
-int staticidx;
-
-/* Put an entry in staticvec, pointing at the variable whose address is given
- */
-void
-staticpro (Lisp_Object *varaddress)
-{
- /* #### This is now a dubious assert() since this routine may be called */
- /* by Lisp attempting to load a DLL. */
- assert (staticidx < countof (staticvec));
- staticvec[staticidx++] = varaddress;
-}
-
-
-Lisp_Object *staticvec_nodump[200];
-int staticidx_nodump;
-
-/* Put an entry in staticvec_nodump, pointing at the variable whose address is given
- */
-void
-staticpro_nodump (Lisp_Object *varaddress)
-{
- /* #### This is now a dubious assert() since this routine may be called */
- /* by Lisp attempting to load a DLL. */
- assert (staticidx_nodump < countof (staticvec_nodump));
- staticvec_nodump[staticidx_nodump++] = varaddress;
-}
-
-
-struct pdump_dumpstructinfo dumpstructvec[200];
-int dumpstructidx;
-
-/* Put an entry in dumpstructvec, pointing at the variable whose address is given
- */
-void
-dumpstruct (void *varaddress, const struct struct_description *desc)
-{
- assert (dumpstructidx < countof (dumpstructvec));
- dumpstructvec[dumpstructidx].data = varaddress;
- dumpstructvec[dumpstructidx].desc = desc;
- dumpstructidx++;
-}
+/* We want the staticpros relocated, but not the pointers found therein.
+ Hence we use a trivial description, as for pointerless objects. */
+static const struct lrecord_description staticpro_description_1[] = {
+ { XD_END }
+};
-struct pdump_dumpopaqueinfo dumpopaquevec[250];
-int dumpopaqueidx;
+static const struct struct_description staticpro_description = {
+ sizeof (Lisp_Object *),
+ staticpro_description_1
+};
-/* Put an entry in dumpopaquevec, pointing at the variable whose address is given
- */
-void
-dumpopaque (void *varaddress, size_t size)
-{
- assert (dumpopaqueidx < countof (dumpopaquevec));
+static const struct lrecord_description staticpros_description_1[] = {
+ XD_DYNARR_DESC (Lisp_Object_ptr_dynarr, &staticpro_description),
+ { XD_END }
+};
- dumpopaquevec[dumpopaqueidx].data = varaddress;
- dumpopaquevec[dumpopaqueidx].size = size;
- dumpopaqueidx++;
-}
+static const struct struct_description staticpros_description = {
+ sizeof (Lisp_Object_ptr_dynarr),
+ staticpros_description_1
+};
-Lisp_Object *pdump_wirevec[50];
-int pdump_wireidx;
+Lisp_Object_ptr_dynarr *staticpros;
-/* Put an entry in pdump_wirevec, pointing at the variable whose address is given
- */
+/* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
+ garbage collection, and for dumping. */
void
-pdump_wire (Lisp_Object *varaddress)
+staticpro (Lisp_Object *varaddress)
{
- assert (pdump_wireidx < countof (pdump_wirevec));
- pdump_wirevec[pdump_wireidx++] = varaddress;
+ Dynarr_add (staticpros, varaddress);
+ dump_add_root_object (varaddress);
}
-Lisp_Object *pdump_wirevec_list[50];
-int pdump_wireidx_list;
+Lisp_Object_ptr_dynarr *staticpros_nodump;
-/* Put an entry in pdump_wirevec_list, pointing at the variable whose address is given
- */
+/* Mark the Lisp_Object at non-heap VARADDRESS as a root object for
+ garbage collection, but not for dumping. */
void
-pdump_wire_list (Lisp_Object *varaddress)
+staticpro_nodump (Lisp_Object *varaddress)
{
- assert (pdump_wireidx_list < countof (pdump_wirevec_list));
- pdump_wirevec_list[pdump_wireidx_list++] = varaddress;
+ Dynarr_add (staticpros_nodump, varaddress);
}
#ifdef ERROR_CHECK_GC
/* All c_readonly objects have their mark bit set,
so that we only need to check the mark bit here. */
- if (! MARKED_RECORD_HEADER_P (lheader))
+ if ( (!MARKED_RECORD_HEADER_P (lheader))
+#ifdef UTF2000
+ && (!OLDER_RECORD_HEADER_P (lheader))
+#endif
+ )
{
MARK_RECORD_HEADER (lheader);
/* Mark all the special slots that serve as the roots of accessibility. */
{ /* staticpro() */
- int i;
- for (i = 0; i < staticidx; i++)
- mark_object (*(staticvec[i]));
- for (i = 0; i < staticidx_nodump; i++)
- mark_object (*(staticvec_nodump[i]));
+ Lisp_Object **p = Dynarr_begin (staticpros);
+ size_t count;
+ for (count = Dynarr_length (staticpros); count; count--)
+ mark_object (**p++);
+ }
+
+ { /* staticpro_nodump() */
+ Lisp_Object **p = Dynarr_begin (staticpros_nodump);
+ size_t count;
+ for (count = Dynarr_length (staticpros_nodump); count; count--)
+ mark_object (**p++);
}
{ /* GCPRO() */
int i;
mark_object (*backlist->function);
- if (nargs == UNEVALLED || nargs == MANY)
+ if (nargs < 0 /* nargs == UNEVALLED || nargs == MANY */)
mark_object (backlist->args[0]);
else
for (i = 0; i < nargs; i++)
XSETINT (all_bit_vectors, 0); /* Qzero may not be set yet. */
XSETINT (Vgc_message, 0);
all_lcrecords = 0;
+#ifdef UTF2000
+ all_older_lcrecords = 0;
+#endif
ignore_malloc_warnings = 1;
#ifdef DOUG_LEA_MALLOC
mallopt (M_TRIM_THRESHOLD, 128*1024); /* trim threshold */
ignore_malloc_warnings = 0;
- staticidx_nodump = 0;
- dumpstructidx = 0;
- pdump_wireidx = 0;
+ if (staticpros_nodump)
+ Dynarr_free (staticpros_nodump);
+ staticpros_nodump = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
+ Dynarr_resize (staticpros_nodump, 100); /* merely a small optimization */
consing_since_gc = 0;
#if 1
INIT_LRECORD_IMPLEMENTATION (string);
INIT_LRECORD_IMPLEMENTATION (lcrecord_list);
- staticidx = 0;
+ staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *);
+ Dynarr_resize (staticpros, 1410); /* merely a small optimization */
+ dump_add_root_struct_ptr (&staticpros, &staticpros_description);
}
-int pure_bytes_used = 0;
-
void
reinit_alloc (void)
{
See also `consing-since-gc'.
*/ );
- DEFVAR_INT ("pure-bytes-used", &pure_bytes_used /*
-Number of bytes of sharable Lisp data allocated so far.
-*/ );
-
#ifdef DEBUG_XEMACS
DEFVAR_INT ("debug-allocation", &debug_allocation /*
If non-zero, print out information to stderr about all objects allocated.
projects / chise / xemacs-chise.git- / blobdiff