X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/1c34c3c03598d1676dd0fabdf58131d47861e055..844e0de1bc2bf56118b749f50a4880db7c918fd5:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 17ec809a14..a300396514 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -142,13 +142,6 @@ extern Lisp_Object which_symbols (Lisp_Object, EMACS_INT) EXTERNALLY_VISIBLE; /* Recording what needs to be marked for gc. */ struct gcpro *gcprolist; - -static void -XFLOAT_INIT (Lisp_Object f, double n) -{ - XFLOAT (f)->u.data = n; -} - /************************************************************************ Malloc @@ -232,6 +225,51 @@ xfree (void *block) return; } +/* Allocate pointerless memory. */ + +void * +xmalloc_atomic (size_t size) +{ + void *val = GC_MALLOC_ATOMIC (size); + if (! val && size) + memory_full (size); + return val; +} + +void * +xzalloc_atomic (size_t size) +{ + return xmalloc_atomic (size); +} + +/* Allocate uncollectable memory. */ + +void * +xmalloc_uncollectable (size_t size) +{ + void *val = GC_MALLOC_UNCOLLECTABLE (size); + if (! val && size) + memory_full (size); + return val; +} + +/* Allocate memory, but if memory is exhausted, return NULL instead of + signalling an error. */ + +void * +xmalloc_unsafe (size_t size) +{ + return GC_MALLOC (size); +} + +/* Allocate pointerless memory, but if memory is exhausted, return + NULL instead of signalling an error. */ + +void * +xmalloc_atomic_unsafe (size_t size) +{ + return GC_MALLOC_ATOMIC (size); +} /* Other parts of Emacs pass large int values to allocator functions expecting ptrdiff_t. This is portable in practice, but check it to @@ -251,6 +289,16 @@ xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size) return xmalloc (nitems * item_size); } +/* Like xnmalloc for pointerless objects. */ + +void * +xnmalloc_atomic (ptrdiff_t nitems, ptrdiff_t item_size) +{ + eassert (0 <= nitems && 0 < item_size); + if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems) + memory_full (SIZE_MAX); + return xmalloc_atomic (nitems * item_size); +} /* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE. Signal an error on memory exhaustion. */ @@ -331,7 +379,7 @@ xstrdup (const char *s) ptrdiff_t size; eassert (s); size = strlen (s) + 1; - return memcpy (xmalloc (size), s, size); + return memcpy (xmalloc_atomic (size), s, size); } /* Like above, but duplicates Lisp string to C string. */ @@ -340,7 +388,7 @@ char * xlispstrdup (Lisp_Object string) { ptrdiff_t size = SBYTES (string) + 1; - return memcpy (xmalloc (size), SSDATA (string), size); + return memcpy (xmalloc_atomic (size), SSDATA (string), size); } /* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly @@ -366,16 +414,6 @@ xputenv (char const *string) if (putenv ((char *) string) != 0) memory_full (0); } - -/* Return a newly allocated memory block of SIZE bytes, remembering - to free it when unwinding. */ -void * -record_xmalloc (size_t size) -{ - void *p = xmalloc (size); - record_unwind_protect_ptr (xfree, p); - return p; -} /*********************************************************************** Interval Allocation @@ -409,7 +447,11 @@ init_strings (void) static struct Lisp_String * allocate_string (void) { - return xmalloc (sizeof (struct Lisp_String)); + struct Lisp_String *p; + + p = xmalloc (sizeof *p); + SCM_NEWSMOB (p->self, lisp_string_tag, p); + return p; } @@ -731,13 +773,9 @@ make_formatted_string (char *buf, const char *format, ...) Lisp_Object make_float (double float_value) { - register Lisp_Object val; - XSETFLOAT (val, xmalloc (sizeof (struct Lisp_Float))); - XFLOAT_INIT (val, float_value); - return val; + return scm_from_double (float_value); } - /*********************************************************************** Cons Allocation @@ -747,12 +785,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, doc: /* Create a new cons, give it CAR and CDR as components, and return it. */) (Lisp_Object car, Lisp_Object cdr) { - register Lisp_Object val; - - XSETCONS (val, xmalloc (sizeof (struct Lisp_Cons))); - XSETCAR (val, car); - XSETCDR (val, cdr); - return val; + return scm_cons (car, cdr); } /* Make a list of 1, 2, 3, 4 or 5 specified objects. */ @@ -903,8 +936,11 @@ Lisp_Object zero_vector; static void init_vectors (void) { - XSETVECTOR (zero_vector, xmalloc (header_size)); - XVECTOR (zero_vector)->header.size = 0; + struct Lisp_Vector *p = xmalloc (header_size); + + SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); + p->header.size = 0; + XSETVECTOR (zero_vector, p); } /* Value is a pointer to a newly allocated Lisp_Vector structure @@ -913,10 +949,17 @@ init_vectors (void) static struct Lisp_Vector * allocate_vectorlike (ptrdiff_t len) { + struct Lisp_Vector *p; + if (len == 0) - return XVECTOR (zero_vector); + p = XVECTOR (zero_vector); else - return xmalloc (header_size + len * word_size); + { + p = xmalloc (header_size + len * word_size); + SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p); + } + + return p; } @@ -962,6 +1005,7 @@ allocate_buffer (void) { struct buffer *b = xmalloc (sizeof *b); + SCM_NEWSMOB (b->header.self, lisp_vectorlike_tag, b); BUFFER_PVEC_INIT (b); /* Put B on the chain of all buffers including killed ones. */ b->next = all_buffers; @@ -1121,10 +1165,20 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT Symbol Allocation ***********************************************************************/ -static void -set_symbol_name (Lisp_Object sym, Lisp_Object name) +void +initialize_symbol (Lisp_Object val, Lisp_Object name) { - XSYMBOL (sym)->name = name; + sym_t p; + + scm_module_define (symbol_module, val, scm_c_make_vector (5, SCM_BOOL_F)); + p = XSYMBOL (val); + SET_SYMBOL_SELF (p, val); + scm_module_define (plist_module, val, Qnil); + SET_SYMBOL_REDIRECT (p, SYMBOL_PLAINVAL); + SET_SYMBOL_VAL (p, Qunbound); + scm_module_define (function_module, val, Qnil); + SET_SYMBOL_CONSTANT (p, 0); + SET_SYMBOL_DECLARED_SPECIAL (p, false); } DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0, @@ -1133,23 +1187,12 @@ Its value is void, and its function definition and property list are nil. */) (Lisp_Object name) { register Lisp_Object val; - register struct Lisp_Symbol *p; CHECK_STRING (name); - XSETSYMBOL (val, xmalloc (sizeof (struct Lisp_Symbol))); - p = XSYMBOL (val); - set_symbol_name (val, name); - set_symbol_plist (val, Qnil); - p->redirect = SYMBOL_PLAINVAL; - SET_SYMBOL_VAL (p, Qunbound); - set_symbol_function (val, Qnil); - set_symbol_next (val, NULL); - p->gcmarkbit = false; - p->interned = SYMBOL_UNINTERNED; - p->constant = 0; - p->declared_special = false; - p->pinned = false; + val = scm_make_symbol (scm_from_utf8_stringn (SSDATA (name), + SBYTES (name))); + initialize_symbol (val, name); return val; } @@ -1165,8 +1208,11 @@ static Lisp_Object allocate_misc (enum Lisp_Misc_Type type) { Lisp_Object val; + union Lisp_Misc *p; - XSETMISC (val, xmalloc (sizeof (union Lisp_Misc))); + p = xmalloc (sizeof *p); + SCM_NEWSMOB (p->u_any.self, lisp_misc_tag, p); + XSETMISC (val, p); XMISCANY (val)->type = type; return val; } @@ -1404,7 +1450,7 @@ memory_full (size_t nbytes) bool enough_free_memory = 0; if (SPARE_MEMORY < nbytes) { - void *p = GC_MALLOC (SPARE_MEMORY); + void *p = xmalloc_atomic_unsafe (SPARE_MEMORY); if (p) { xfree (p); @@ -1440,7 +1486,7 @@ void refill_memory_reserve (void) { if (spare_memory == NULL) - spare_memory = GC_MALLOC (SPARE_MEMORY); + spare_memory = xmalloc_atomic_unsafe (SPARE_MEMORY); if (spare_memory) Vmemory_full = Qnil; @@ -1484,10 +1530,10 @@ valid_lisp_object_p (Lisp_Object obj) { void *p; - if (INTEGERP (obj)) + if (SCM_IMP (obj)) return 1; - p = (void *) XPNTR (obj); + p = (void *) SCM2PTR (obj); if (p == &buffer_defaults || p == &buffer_local_symbols) return 2; @@ -1591,6 +1637,10 @@ die (const char *msg, const char *file, int line) void init_alloc_once (void) { + lisp_misc_tag = scm_make_smob_type ("elisp-misc", 0); + lisp_string_tag = scm_make_smob_type ("elisp-string", 0); + lisp_vectorlike_tag = scm_make_smob_type ("elisp-vectorlike", 0); + /* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */ init_strings (); @@ -1615,6 +1665,8 @@ init_alloc (void) void syms_of_alloc (void) { +#include "alloc.x" + DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold, doc: /* Number of bytes of consing between garbage collections. Garbage collection can happen automatically once this many bytes have been @@ -1671,20 +1723,6 @@ do hash-consing of the objects allocated to pure space. */); The time is in seconds as a floating point value. */); DEFVAR_INT ("gcs-done", gcs_done, doc: /* Accumulated number of garbage collections done. */); - - defsubr (&Scons); - defsubr (&Slist); - defsubr (&Svector); - defsubr (&Sbool_vector); - defsubr (&Smake_byte_code); - defsubr (&Smake_list); - defsubr (&Smake_vector); - defsubr (&Smake_string); - defsubr (&Smake_bool_vector); - defsubr (&Smake_symbol); - defsubr (&Smake_marker); - defsubr (&Spurecopy); - defsubr (&Sgarbage_collect); } /* When compiled with GCC, GDB might say "No enum type named @@ -1697,7 +1735,6 @@ union enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS; enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS; enum char_bits char_bits; - enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE; enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE; enum Lisp_Bits Lisp_Bits; enum Lisp_Compiled Lisp_Compiled;