Boston, MA 02111-1307, USA. */
#include <config.h>
+#include <stdio.h>
/* Note that this declares bzero on OSF/1. How dumb. */
/* The following come from gmalloc.c. */
-#if defined (__STDC__) && __STDC__
+#if defined (STDC_HEADERS)
#include <stddef.h>
#define __malloc_size_t size_t
#else
/* Mark, unmark, query mark bit of a Lisp string. S must be a pointer
to a struct Lisp_String. */
-#define MARK_STRING(S) XMARK ((S)->size)
-#define UNMARK_STRING(S) XUNMARK ((S)->size)
-#define STRING_MARKED_P(S) XMARKBIT ((S)->size)
+#define MARK_STRING(S) ((S)->size |= MARKBIT)
+#define UNMARK_STRING(S) ((S)->size &= ~MARKBIT)
+#define STRING_MARKED_P(S) ((S)->size & MARKBIT)
/* Value is the number of bytes/chars of S, a pointer to a struct
Lisp_String. This must be used instead of STRING_BYTES (S) or
static int malloc_hysteresis;
-/* Nonzero when malloc is called for allocating Lisp object space.
- Currently set but not used. */
-
-int allocating_for_lisp;
-
/* Non-nil means defun should do purecopy on the function definition. */
Lisp_Object Vpurify_flag;
extern int message_enable_multibyte;
-
-#if GC_MARK_STACK
-
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
-#include <stdio.h> /* For fprintf. */
-#endif
-
-/* A unique object in pure space used to make some Lisp objects
- on free lists recognizable in O(1). */
-
-Lisp_Object Vdead;
-
/* When scanning the C stack for live Lisp objects, Emacs keeps track
of what memory allocated via lisp_malloc is intended for what
purpose. This enumeration specifies the type of memory. */
MEM_TYPE_VECTOR
};
+#if GC_MARK_STACK
+
+#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
+#include <stdio.h> /* For fprintf. */
+#endif
+
+/* A unique object in pure space used to make some Lisp objects
+ on free lists recognizable in O(1). */
+
+Lisp_Object Vdead;
+
struct mem_node;
static void *lisp_malloc P_ ((int, enum mem_type));
static void mark_stack P_ ((void));
static int live_symbol_p P_ ((struct mem_node *, void *));
static int live_float_p P_ ((struct mem_node *, void *));
static int live_misc_p P_ ((struct mem_node *, void *));
+static void mark_maybe_object P_ ((Lisp_Object));
static void mark_memory P_ ((void *, void *));
static void mem_init P_ ((void));
static struct mem_node *mem_insert P_ ((void *, void *, enum mem_type));
}
+/* Like strdup, but uses xmalloc. */
+
+char *
+xstrdup (s)
+ char *s;
+{
+ int len = strlen (s) + 1;
+ char *p = (char *) xmalloc (len);
+ bcopy (s, p, len);
+ return p;
+}
+
+
/* Like malloc but used for allocating Lisp data. NBYTES is the
number of bytes to allocate, TYPE describes the intended use of the
allcated memory block (for strings, for conses, ...). */
register void *val;
BLOCK_INPUT;
- allocating_for_lisp++;
val = (void *) malloc (nbytes);
- allocating_for_lisp--;
- UNBLOCK_INPUT;
- if (!val && nbytes)
- memory_full ();
-
#if GC_MARK_STACK
- if (type != MEM_TYPE_NON_LISP)
+ if (val && type != MEM_TYPE_NON_LISP)
mem_insert (val, (char *) val + nbytes, type);
#endif
+ UNBLOCK_INPUT;
+ if (!val && nbytes)
+ memory_full ();
return val;
}
long *block;
{
BLOCK_INPUT;
- allocating_for_lisp++;
free (block);
#if GC_MARK_STACK
mem_delete (mem_find (block));
#endif
- allocating_for_lisp--;
UNBLOCK_INPUT;
}
if (interval_free_list)
{
val = interval_free_list;
- interval_free_list = interval_free_list->parent;
+ interval_free_list = INTERVAL_PARENT (interval_free_list);
}
else
{
/* XMARK expands to an assignment; the LHS of an assignment can't be
a cast. */
- XMARK (* (Lisp_Object *) &tree->parent);
+ XMARK (tree->up.obj);
traverse_intervals (tree, 1, 0, mark_interval, Qnil);
}
#define MARK_INTERVAL_TREE(i) \
do { \
if (!NULL_INTERVAL_P (i) \
- && ! XMARKBIT (*(Lisp_Object *) &i->parent)) \
+ && ! XMARKBIT (i->up.obj)) \
mark_interval_tree (i); \
} while (0)
do { \
if (! NULL_INTERVAL_P (i)) \
{ \
- XUNMARK (* (Lisp_Object *) (&(i)->parent)); \
+ XUNMARK ((i)->up.obj); \
(i) = balance_intervals (i); \
} \
} while (0)
-
+\f
+/* Number support. If NO_UNION_TYPE isn't in effect, we
+ can't create number objects in macros. */
+#ifndef make_number
+Lisp_Object
+make_number (n)
+ int n;
+{
+ Lisp_Object obj;
+ obj.s.val = n;
+ obj.s.type = Lisp_Int;
+ return obj;
+}
+#endif
\f
/***********************************************************************
String Allocation
int nbytes;
{
register Lisp_Object val;
- int nchars = chars_in_text (contents, nbytes);
+ int nchars, multibyte_nbytes;
+
+ parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
val = make_uninit_multibyte_string (nchars, nbytes);
bcopy (contents, XSTRING (val)->data, nbytes);
- if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size)
+ if (nbytes == nchars || nbytes != multibyte_nbytes)
+ /* CONTENTS contains no multibyte sequences or contains an invalid
+ multibyte sequence. We must make unibyte string. */
SET_STRING_BYTES (XSTRING (val), -1);
return val;
}
val = make_pure_vector ((EMACS_INT) nargs);
else
val = Fmake_vector (len, Qnil);
+
+ if (STRINGP (args[1]) && STRING_MULTIBYTE (args[1]))
+ /* BYTECODE-STRING must have been produced by Emacs 20.2 or the
+ earlier because they produced a raw 8-bit string for byte-code
+ and now such a byte-code string is loaded as multibyte while
+ raw 8-bit characters converted to multibyte form. Thus, now we
+ must convert them back to the original unibyte form. */
+ args[1] = Fstring_as_unibyte (args[1]);
+
p = XVECTOR (val);
for (index = 0; index < nargs; index++)
{
#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
+/* Mark OBJ if we can prove it's a Lisp_Object. */
+
+static INLINE void
+mark_maybe_object (obj)
+ Lisp_Object obj;
+{
+ void *po = (void *) XPNTR (obj);
+ struct mem_node *m = mem_find (po);
+
+ if (m != MEM_NIL)
+ {
+ int mark_p = 0;
+
+ switch (XGCTYPE (obj))
+ {
+ case Lisp_String:
+ mark_p = (live_string_p (m, po)
+ && !STRING_MARKED_P ((struct Lisp_String *) po));
+ break;
+
+ case Lisp_Cons:
+ mark_p = (live_cons_p (m, po)
+ && !XMARKBIT (XCONS (obj)->car));
+ break;
+
+ case Lisp_Symbol:
+ mark_p = (live_symbol_p (m, po)
+ && !XMARKBIT (XSYMBOL (obj)->plist));
+ break;
+
+ case Lisp_Float:
+ mark_p = (live_float_p (m, po)
+ && !XMARKBIT (XFLOAT (obj)->type));
+ break;
+
+ case Lisp_Vectorlike:
+ /* Note: can't check GC_BUFFERP before we know it's a
+ buffer because checking that dereferences the pointer
+ PO which might point anywhere. */
+ if (live_vector_p (m, po))
+ mark_p = (!GC_SUBRP (obj)
+ && !(XVECTOR (obj)->size & ARRAY_MARK_FLAG));
+ else if (live_buffer_p (m, po))
+ mark_p = GC_BUFFERP (obj) && !XMARKBIT (XBUFFER (obj)->name);
+ break;
+
+ case Lisp_Misc:
+ if (live_misc_p (m, po))
+ {
+ switch (XMISCTYPE (obj))
+ {
+ case Lisp_Misc_Marker:
+ mark_p = !XMARKBIT (XMARKER (obj)->chain);
+ break;
+
+ case Lisp_Misc_Buffer_Local_Value:
+ case Lisp_Misc_Some_Buffer_Local_Value:
+ mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue);
+ break;
+
+ case Lisp_Misc_Overlay:
+ mark_p = !XMARKBIT (XOVERLAY (obj)->plist);
+ break;
+ }
+ }
+ break;
+ }
+
+ if (mark_p)
+ {
+#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
+ if (nzombies < MAX_ZOMBIES)
+ zombies[nzombies] = *p;
+ ++nzombies;
+#endif
+ mark_object (&obj);
+ }
+ }
+}
+
/* Mark Lisp objects in the address range START..END. */
static void
start = end;
end = tem;
}
-
+
for (p = (Lisp_Object *) start; (void *) p < end; ++p)
+ mark_maybe_object (*p);
+}
+
+
+#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
+
+static int setjmp_tested_p, longjmps_done;
+
+#define SETJMP_WILL_LIKELY_WORK "\
+\n\
+Emacs garbage collector has been changed to use conservative stack\n\
+marking. Emacs has determined that the method it uses to do the\n\
+marking will likely work on your system, but this isn't sure.\n\
+\n\
+If you are a system-programmer, or can get the help of a local wizard\n\
+who is, please take a look at the function mark_stack in alloc.c, and\n\
+verify that the methods used are appropriate for your system.\n\
+\n\
+Please mail the result to <gerd@gnu.org>.\n\
+"
+
+#define SETJMP_WILL_NOT_WORK "\
+\n\
+Emacs garbage collector has been changed to use conservative stack\n\
+marking. Emacs has determined that the default method it uses to do the\n\
+marking will not work on your system. We will need a system-dependent\n\
+solution for your system.\n\
+\n\
+Please take a look at the function mark_stack in alloc.c, and\n\
+try to find a way to make it work on your system.\n\
+Please mail the result to <gerd@gnu.org>.\n\
+"
+
+
+/* Perform a quick check if it looks like setjmp saves registers in a
+ jmp_buf. Print a message to stderr saying so. When this test
+ succeeds, this is _not_ a proof that setjmp is sufficient for
+ conservative stack marking. Only the sources or a disassembly
+ can prove that. */
+
+static void
+test_setjmp ()
+{
+ char buf[10];
+ register int x;
+ jmp_buf jbuf;
+ int result = 0;
+
+ /* Arrange for X to be put in a register. */
+ sprintf (buf, "1");
+ x = strlen (buf);
+ x = 2 * x - 1;
+
+ setjmp (jbuf);
+ if (longjmps_done == 1)
{
- void *po = (void *) XPNTR (*p);
- struct mem_node *m = mem_find (po);
-
- if (m != MEM_NIL)
- {
- int mark_p = 0;
+ /* Came here after the longjmp at the end of the function.
- switch (XGCTYPE (*p))
- {
- case Lisp_String:
- mark_p = (live_string_p (m, po)
- && !STRING_MARKED_P ((struct Lisp_String *) po));
- break;
-
- case Lisp_Cons:
- mark_p = (live_cons_p (m, po)
- && !XMARKBIT (XCONS (*p)->car));
- break;
-
- case Lisp_Symbol:
- mark_p = (live_symbol_p (m, po)
- && !XMARKBIT (XSYMBOL (*p)->plist));
- break;
-
- case Lisp_Float:
- mark_p = (live_float_p (m, po)
- && !XMARKBIT (XFLOAT (*p)->type));
- break;
-
- case Lisp_Vectorlike:
- /* Note: can't check GC_BUFFERP before we know it's a
- buffer because checking that dereferences the pointer
- PO which might point anywhere. */
- if (live_vector_p (m, po))
- mark_p = (!GC_SUBRP (*p)
- && !(XVECTOR (*p)->size & ARRAY_MARK_FLAG));
- else if (live_buffer_p (m, po))
- mark_p = GC_BUFFERP (*p) && !XMARKBIT (XBUFFER (*p)->name);
- break;
-
- case Lisp_Misc:
- if (live_misc_p (m, po))
- {
- switch (XMISCTYPE (*p))
- {
- case Lisp_Misc_Marker:
- mark_p = !XMARKBIT (XMARKER (*p)->chain);
- break;
-
- case Lisp_Misc_Buffer_Local_Value:
- case Lisp_Misc_Some_Buffer_Local_Value:
- mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (*p)->realvalue);
- break;
-
- case Lisp_Misc_Overlay:
- mark_p = !XMARKBIT (XOVERLAY (*p)->plist);
- break;
- }
- }
- break;
- }
+ If x == 1, the longjmp has restored the register to its
+ value before the setjmp, and we can hope that setjmp
+ saves all such registers in the jmp_buf, although that
+ isn't sure.
- if (mark_p)
- {
-#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES
- if (nzombies < MAX_ZOMBIES)
- zombies[nzombies] = *p;
- ++nzombies;
-#endif
- mark_object (p);
- }
+ For other values of X, either something really strange is
+ taking place, or the setjmp just didn't save the register. */
+
+ if (x == 1)
+ fprintf (stderr, SETJMP_WILL_LIKELY_WORK);
+ else
+ {
+ fprintf (stderr, SETJMP_WILL_NOT_WORK);
+ exit (1);
}
}
+
+ ++longjmps_done;
+ x = 2;
+ if (longjmps_done == 1)
+ longjmp (jbuf, 1);
}
+#endif /* not GC_SAVE_REGISTERS_ON_STACK && not GC_SETJMP_WORKS */
+
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */
-/* Mark live Lisp objects on the C stack. */
+/* Mark live Lisp objects on the C stack.
+
+ There are several system-dependent problems to consider when
+ porting this to new architectures:
+
+ Processor Registers
+
+ We have to mark Lisp objects in CPU registers that can hold local
+ variables or are used to pass parameters.
+
+ If GC_SAVE_REGISTERS_ON_STACK is defined, it should expand to
+ something that either saves relevant registers on the stack, or
+ calls mark_maybe_object passing it each register's contents.
+
+ If GC_SAVE_REGISTERS_ON_STACK is not defined, the current
+ implementation assumes that calling setjmp saves registers we need
+ to see in a jmp_buf which itself lies on the stack. This doesn't
+ have to be true! It must be verified for each system, possibly
+ by taking a look at the source code of setjmp.
+
+ Stack Layout
+
+ Architectures differ in the way their processor stack is organized.
+ For example, the stack might look like this
+
+ +----------------+
+ | Lisp_Object | size = 4
+ +----------------+
+ | something else | size = 2
+ +----------------+
+ | Lisp_Object | size = 4
+ +----------------+
+ | ... |
+
+ In such a case, not every Lisp_Object will be aligned equally. To
+ find all Lisp_Object on the stack it won't be sufficient to walk
+ the stack in steps of 4 bytes. Instead, two passes will be
+ necessary, one starting at the start of the stack, and a second
+ pass starting at the start of the stack + 2. Likewise, if the
+ minimal alignment of Lisp_Objects on the stack is 1, four passes
+ would be necessary, each one starting with one byte more offset
+ from the stack start.
+
+ The current code assumes by default that Lisp_Objects are aligned
+ equally on the stack. */
static void
mark_stack ()
pass parameters. */
#ifdef GC_SAVE_REGISTERS_ON_STACK
GC_SAVE_REGISTERS_ON_STACK (end);
-#else
+#else /* not GC_SAVE_REGISTERS_ON_STACK */
+
+#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that
+ setjmp will definitely work, test it
+ and print a message with the result
+ of the test. */
+ if (!setjmp_tested_p)
+ {
+ setjmp_tested_p = 1;
+ test_setjmp ();
+ }
+#endif /* GC_SETJMP_WORKS */
+
setjmp (j);
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j;
-#endif
+#endif /* not GC_SAVE_REGISTERS_ON_STACK */
/* This assumes that the stack is a contiguous region in memory. If
- that's not the case, something has to be done here to iterate over
- the stack segments. */
+ that's not the case, something has to be done here to iterate
+ over the stack segments. */
+#if GC_LISP_OBJECT_ALIGNMENT == 1
+ mark_memory (stack_base, end);
+ mark_memory ((char *) stack_base + 1, end);
+ mark_memory ((char *) stack_base + 2, end);
+ mark_memory ((char *) stack_base + 3, end);
+#elif GC_LISP_OBJECT_ALIGNMENT == 2
+ mark_memory (stack_base, end);
+ mark_memory ((char *) stack_base + 2, end);
+#else
mark_memory (stack_base, end);
+#endif
#if GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS
check_gcpros ();
{
for (j = 0; j < LFACE_VECTOR_SIZE; ++j)
mark_object (&face->lface[j]);
- mark_object (&face->registry);
}
}
}
{
if (! XMARKBIT (iblk->intervals[i].plist))
{
- iblk->intervals[i].parent = interval_free_list;
+ SET_INTERVAL_PARENT (&iblk->intervals[i], interval_free_list);
interval_free_list = &iblk->intervals[i];
this_free++;
}
{
*iprev = iblk->next;
/* Unhook from the free list. */
- interval_free_list = iblk->intervals[0].parent;
+ interval_free_list = INTERVAL_PARENT (&iblk->intervals[0]);
lisp_free (iblk);
n_interval_blocks--;
}
return Flist (8, consed);
}
+
+int suppress_checking;
+void
+die (msg, file, line)
+ const char *msg;
+ const char *file;
+ int line;
+{
+ fprintf (stderr, "\r\nEmacs fatal error: %s:%d: %s\r\n",
+ file, line, msg);
+ abort ();
+}
\f
/* Initialization */
{
gcprolist = 0;
byte_stack_list = 0;
+#if GC_MARK_STACK
+#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS
+ setjmp_tested_p = longjmps_done = 0;
+#endif
+#endif
}
void