X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/c55b0da6b8b1da970a1848e484f32878fdd7b2bc..f4e1400d40a45059b6cc54b67787da1792630e02:/src/alloc.c diff --git a/src/alloc.c b/src/alloc.c index 728c5f9557..d703d3d99b 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -1,5 +1,5 @@ /* Storage allocation and gc for GNU Emacs Lisp interpreter. - Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002 + Copyright (C) 1985, 86, 88, 93, 94, 95, 97, 98, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -256,6 +256,9 @@ Lisp_Object Qgc_cons_threshold, Qchar_table_extra_slots; Lisp_Object Vpost_gc_hook, Qpost_gc_hook; +Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */ +EMACS_INT gcs_done; /* accumulated GCs */ + static void mark_buffer P_ ((Lisp_Object)); static void mark_kboards P_ ((void)); static void gc_sweep P_ ((void)); @@ -341,14 +344,19 @@ int dont_register_blocks; struct mem_node { - struct mem_node *left, *right, *parent; + /* Children of this node. These pointers are never NULL. When there + is no child, the value is MEM_NIL, which points to a dummy node. */ + struct mem_node *left, *right; + + /* The parent of this node. In the root node, this is NULL. */ + struct mem_node *parent; /* Start and end of allocated region. */ void *start, *end; /* Node color. */ enum {MEM_BLACK, MEM_RED} color; - + /* Memory type. */ enum mem_type type; }; @@ -588,14 +596,14 @@ lisp_malloc (nbytes, type) #ifdef GC_MALLOC_CHECK allocated_mem_type = type; #endif - + val = (void *) malloc (nbytes); #if GC_MARK_STACK && !defined GC_MALLOC_CHECK if (val && type != MEM_TYPE_NON_LISP) mem_insert (val, (char *) val + nbytes, type); #endif - + UNBLOCK_INPUT; if (!val && nbytes) memory_full (); @@ -609,7 +617,7 @@ lisp_malloc (nbytes, type) struct buffer * allocate_buffer () { - struct buffer *b + struct buffer *b = (struct buffer *) lisp_malloc (sizeof (struct buffer), MEM_TYPE_BUFFER); VALIDATE_LISP_STORAGE (b, sizeof *b); @@ -640,8 +648,8 @@ lisp_free (block) elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT pairs; unfortunately, we have no idea what C library functions might call malloc, so we can't really protect them unless you're - using GNU malloc. Fortunately, most of the major operating can use - GNU malloc. */ + using GNU malloc. Fortunately, most of the major operating systems + can use GNU malloc. */ #ifndef SYSTEM_MALLOC #ifndef DOUG_LEA_MALLOC @@ -666,7 +674,7 @@ emacs_blocked_free (ptr) if (ptr) { struct mem_node *m; - + m = mem_find (ptr); if (m == MEM_NIL || m->start != ptr) { @@ -681,10 +689,10 @@ emacs_blocked_free (ptr) } } #endif /* GC_MALLOC_CHECK */ - + __free_hook = old_free_hook; free (ptr); - + /* If we released our reserve (due to running out of memory), and we have a fair amount free once again, try to set aside another reserve in case we run out once more. */ @@ -754,7 +762,7 @@ emacs_blocked_malloc (size) } } #endif /* GC_MALLOC_CHECK */ - + __malloc_hook = emacs_blocked_malloc; UNBLOCK_INPUT; @@ -789,9 +797,9 @@ emacs_blocked_realloc (ptr, size) mem_delete (m); } - + /* fprintf (stderr, "%p -> realloc\n", ptr); */ - + /* Prevent malloc from registering blocks. */ dont_register_blocks = 1; #endif /* GC_MALLOC_CHECK */ @@ -812,10 +820,10 @@ emacs_blocked_realloc (ptr, size) /* Can't handle zero size regions in the red-black tree. */ mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP); } - + /* fprintf (stderr, "%p <- realloc\n", value); */ #endif /* GC_MALLOC_CHECK */ - + __realloc_hook = emacs_blocked_realloc; UNBLOCK_INPUT; @@ -1061,13 +1069,13 @@ struct sdata struct Lisp_String *string; #ifdef GC_CHECK_STRING_BYTES - + EMACS_INT nbytes; unsigned char data[1]; - + #define SDATA_NBYTES(S) (S)->nbytes #define SDATA_DATA(S) (S)->data - + #else /* not GC_CHECK_STRING_BYTES */ union @@ -1078,7 +1086,7 @@ struct sdata /* When STRING is null. */ EMACS_INT nbytes; } u; - + #define SDATA_NBYTES(S) (S)->u.nbytes #define SDATA_DATA(S) (S)->u.data @@ -1157,7 +1165,7 @@ static int total_string_size; S must be live, i.e. S->data must not be null. S->data is actually a pointer to the `u.data' member of its sdata structure; the structure starts at a constant offset in front of that. */ - + #ifdef GC_CHECK_STRING_BYTES #define SDATA_OF_STRING(S) \ @@ -1230,33 +1238,33 @@ string_bytes (s) abort (); return nbytes; } - -/* Check validity Lisp strings' string_bytes member in B. */ + +/* Check validity of Lisp strings' string_bytes member in B. */ void check_sblock (b) struct sblock *b; { struct sdata *from, *end, *from_end; - + end = b->next_free; - + for (from = &b->first_data; from < end; from = from_end) { /* Compute the next FROM here because copying below may overwrite data we need to compute it. */ int nbytes; - + /* Check that the string size recorded in the string is the same as the one recorded in the sdata structure. */ if (from->string) CHECK_STRING_BYTES (from->string); - + if (from->string) nbytes = GC_STRING_BYTES (from->string); else nbytes = SDATA_NBYTES (from); - + nbytes = SDATA_SIZE (nbytes); from_end = (struct sdata *) ((char *) from + nbytes); } @@ -1281,7 +1289,7 @@ check_string_bytes (all_p) if (s) CHECK_STRING_BYTES (s); } - + for (b = oldest_sblock; b; b = b->next) check_sblock (b); } @@ -1387,12 +1395,12 @@ allocate_string_data (s, nchars, nbytes) #endif b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP); - + #ifdef DOUG_LEA_MALLOC /* Back to a reasonable maximum of mmap'ed areas. */ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); #endif - + b->next_free = &b->first_data; b->first_data.string = NULL; b->next = large_sblocks; @@ -1420,7 +1428,7 @@ allocate_string_data (s, nchars, nbytes) old_data = s->data ? SDATA_OF_STRING (s) : NULL; old_nbytes = GC_STRING_BYTES (s); - + data = b->next_free; data->string = s; s->data = SDATA_DATA (data); @@ -1431,7 +1439,7 @@ allocate_string_data (s, nchars, nbytes) s->size_byte = nbytes; s->data[nbytes] = '\0'; b->next_free = (struct sdata *) ((char *) data + needed); - + /* If S had already data assigned, mark that as free by setting its string back-pointer to null, and recording the size of the data in it. */ @@ -1452,7 +1460,7 @@ sweep_strings () { struct string_block *b, *next; struct string_block *live_blocks = NULL; - + string_free_list = NULL; total_strings = total_free_strings = 0; total_string_size = 0; @@ -1476,7 +1484,7 @@ sweep_strings () { /* String is live; unmark it and its intervals. */ UNMARK_STRING (s); - + if (!NULL_INTERVAL_P (s->intervals)) UNMARK_BALANCE_INTERVALS (s->intervals); @@ -1548,7 +1556,7 @@ free_large_strings () { struct sblock *b, *next; struct sblock *live_blocks = NULL; - + for (b = large_sblocks; b; b = next) { next = b->next; @@ -1589,7 +1597,7 @@ compact_small_strings () { end = b->next_free; xassert ((char *) end <= (char *) b + SBLOCK_SIZE); - + for (from = &b->first_data; from < end; from = from_end) { /* Compute the next FROM here because copying below may @@ -1603,15 +1611,15 @@ compact_small_strings () && GC_STRING_BYTES (from->string) != SDATA_NBYTES (from)) abort (); #endif /* GC_CHECK_STRING_BYTES */ - + if (from->string) nbytes = GC_STRING_BYTES (from->string); else nbytes = SDATA_NBYTES (from); - + nbytes = SDATA_SIZE (nbytes); from_end = (struct sdata *) ((char *) from + nbytes); - + /* FROM->string non-null means it's alive. Copy its data. */ if (from->string) { @@ -1625,7 +1633,7 @@ compact_small_strings () to = &tb->first_data; to_end = (struct sdata *) ((char *) to + nbytes); } - + /* Copy, and update the string's `data' pointer. */ if (from != to) { @@ -1692,7 +1700,7 @@ Both LENGTH and INIT must be numbers. */) p += len; } } - + *p = 0; return val; } @@ -1720,16 +1728,16 @@ LENGTH must be a number. INIT matters only in whether it is t or nil. */) slot `size' of the struct Lisp_Bool_Vector. */ val = Fmake_vector (make_number (length_in_elts + 1), Qnil); p = XBOOL_VECTOR (val); - + /* Get rid of any bits that would cause confusion. */ p->vector_size = 0; XSETBOOL_VECTOR (val, p); p->size = XFASTINT (length); - + real_init = (NILP (init) ? 0 : -1); for (i = 0; i < length_in_chars ; i++) p->data[i] = real_init; - + /* Clear the extraneous bits in the last byte. */ if (XINT (length) != length_in_chars * BITS_PER_CHAR) XBOOL_VECTOR (val)->data[length_in_chars - 1] @@ -1974,7 +1982,7 @@ make_float (float_value) } XSETFLOAT (val, &float_block->floats[float_block_index++]); } - + XFLOAT_DATA (val) = float_value; XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */ consing_since_gc += sizeof (struct Lisp_Float); @@ -2081,7 +2089,7 @@ DEFUN ("cons", Fcons, Scons, 2, 2, 0, } XSETCONS (val, &cons_block->conses[cons_block_index++]); } - + XSETCAR (val, car); XSETCDR (val, cdr); consing_since_gc += sizeof (struct Lisp_Cons); @@ -2166,17 +2174,17 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, { val = Fcons (init, val); --size; - + if (size > 0) { val = Fcons (init, val); --size; - + if (size > 0) { val = Fcons (init, val); --size; - + if (size > 0) { val = Fcons (init, val); @@ -2188,7 +2196,7 @@ DEFUN ("make-list", Fmake_list, Smake_list, 2, 2, 0, QUIT; } - + return val; } @@ -2224,15 +2232,15 @@ allocate_vectorlike (len, type) a dumped Emacs. */ mallopt (M_MMAP_MAX, 0); #endif - + nbytes = sizeof *p + (len - 1) * sizeof p->contents[0]; p = (struct Lisp_Vector *) lisp_malloc (nbytes, type); - + #ifdef DOUG_LEA_MALLOC /* Back to a reasonable maximum of mmap'ed areas. */ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); #endif - + VALIDATE_LISP_STORAGE (p, 0); consing_since_gc += nbytes; vector_cells_consed += len; @@ -2264,11 +2272,11 @@ allocate_hash_table () EMACS_INT len = VECSIZE (struct Lisp_Hash_Table); struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE); EMACS_INT i; - + v->size = len; for (i = 0; i < len; ++i) v->contents[i] = Qnil; - + return (struct Lisp_Hash_Table *) v; } @@ -2279,11 +2287,11 @@ allocate_window () EMACS_INT len = VECSIZE (struct window); struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW); EMACS_INT i; - + for (i = 0; i < len; ++i) v->contents[i] = Qnil; v->size = len; - + return (struct window *) v; } @@ -2294,7 +2302,7 @@ allocate_frame () EMACS_INT len = VECSIZE (struct frame); struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME); EMACS_INT i; - + for (i = 0; i < len; ++i) v->contents[i] = make_number (0); v->size = len; @@ -2308,11 +2316,11 @@ allocate_process () EMACS_INT len = VECSIZE (struct Lisp_Process); struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS); EMACS_INT i; - + for (i = 0; i < len; ++i) v->contents[i] = Qnil; v->size = len; - + return (struct Lisp_Process *) v; } @@ -2323,11 +2331,11 @@ allocate_other_vector (len) { struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR); EMACS_INT i; - + for (i = 0; i < len; ++i) v->contents[i] = Qnil; v->size = len; - + return v; } @@ -2539,7 +2547,7 @@ Its value and function definition are void, and its property list is nil. */) } XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]); } - + p = XSYMBOL (val); p->xname = name; p->plist = Qnil; @@ -2620,12 +2628,32 @@ allocate_misc () } XSETMISC (val, &marker_block->markers[marker_block_index++]); } - + consing_since_gc += sizeof (union Lisp_Misc); misc_objects_consed++; return val; } +/* Return a Lisp_Misc_Save_Value object containing POINTER and + INTEGER. This is used to package C values to call record_unwind_protect. + The unwind function can get the C values back using XSAVE_VALUE. */ + +Lisp_Object +make_save_value (pointer, integer) + void *pointer; + int integer; +{ + register Lisp_Object val; + register struct Lisp_Save_Value *p; + + val = allocate_misc (); + XMISCTYPE (val) = Lisp_Misc_Save_Value; + p = XSAVE_VALUE (val); + p->pointer = pointer; + p->integer = integer; + return val; +} + DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, doc: /* Return a newly allocated marker which does not point at any place. */) () @@ -2685,7 +2713,7 @@ make_event_array (nargs, args) characters, so we can make a string. */ { Lisp_Object result; - + result = Fmake_string (make_number (nargs), make_number (0)); for (i = 0; i < nargs; i++) { @@ -2694,7 +2722,7 @@ make_event_array (nargs, args) if (XINT (args[i]) & CHAR_META) SSET (result, i, SREF (result, i) | 0x80); } - + return result; } } @@ -2777,7 +2805,7 @@ mem_insert (start, end, type) parent = NULL; #if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS - + while (c != MEM_NIL) { if (start >= c->start && start < c->end) @@ -2785,15 +2813,15 @@ mem_insert (start, end, type) parent = c; c = start < c->start ? c->left : c->right; } - + #else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */ - + while (c != MEM_NIL) { parent = c; c = start < c->start ? c->left : c->right; } - + #endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */ /* Create a new node. */ @@ -2819,7 +2847,7 @@ mem_insert (start, end, type) else parent->right = x; } - else + else mem_root = x; /* Re-establish red-black tree properties. */ @@ -2840,13 +2868,13 @@ mem_insert_fixup (x) { /* X is red and its parent is red. This is a violation of red-black tree property #3. */ - + if (x->parent == x->parent->parent->left) { /* We're on the left side of our grandparent, and Y is our "uncle". */ struct mem_node *y = x->parent->parent->right; - + if (y->color == MEM_RED) { /* Uncle and parent are red but should be black because @@ -2876,7 +2904,7 @@ mem_insert_fixup (x) { /* This is the symmetrical case of above. */ struct mem_node *y = x->parent->parent->left; - + if (y->color == MEM_RED) { x->parent->color = MEM_BLACK; @@ -2891,7 +2919,7 @@ mem_insert_fixup (x) x = x->parent; mem_rotate_right (x); } - + x->parent->color = MEM_BLACK; x->parent->parent->color = MEM_RED; mem_rotate_left (x->parent->parent); @@ -2905,8 +2933,8 @@ mem_insert_fixup (x) } -/* (x) (y) - / \ / \ +/* (x) (y) + / \ / \ a (y) ===> (x) c / \ / \ b c a b */ @@ -2945,10 +2973,10 @@ mem_rotate_left (x) } -/* (x) (Y) - / \ / \ - (y) c ===> a (x) - / \ / \ +/* (x) (Y) + / \ / \ + (y) c ===> a (x) + / \ / \ a b b c */ static void @@ -2960,7 +2988,7 @@ mem_rotate_right (x) x->left = y->right; if (y->right != MEM_NIL) y->right->parent = x; - + if (y != MEM_NIL) y->parent = x->parent; if (x->parent) @@ -2972,7 +3000,7 @@ mem_rotate_right (x) } else mem_root = y; - + y->right = x; if (x != MEM_NIL) x->parent = y; @@ -3021,7 +3049,7 @@ mem_delete (z) z->end = y->end; z->type = y->type; } - + if (y->color == MEM_BLACK) mem_delete_fixup (x); @@ -3045,7 +3073,7 @@ mem_delete_fixup (x) if (x == x->parent->left) { struct mem_node *w = x->parent->right; - + if (w->color == MEM_RED) { w->color = MEM_BLACK; @@ -3053,7 +3081,7 @@ mem_delete_fixup (x) mem_rotate_left (x->parent); w = x->parent->right; } - + if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK) { w->color = MEM_RED; @@ -3078,7 +3106,7 @@ mem_delete_fixup (x) else { struct mem_node *w = x->parent->left; - + if (w->color == MEM_RED) { w->color = MEM_BLACK; @@ -3086,7 +3114,7 @@ mem_delete_fixup (x) mem_rotate_right (x->parent); w = x->parent->left; } - + if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK) { w->color = MEM_RED; @@ -3101,7 +3129,7 @@ mem_delete_fixup (x) mem_rotate_left (w); w = x->parent->left; } - + w->color = x->parent->color; x->parent->color = MEM_BLACK; w->left->color = MEM_BLACK; @@ -3110,7 +3138,7 @@ mem_delete_fixup (x) } } } - + x->color = MEM_BLACK; } @@ -3178,7 +3206,7 @@ live_symbol_p (m, p) { struct symbol_block *b = (struct symbol_block *) m->start; int offset = (char *) p - (char *) &b->symbols[0]; - + /* P must point to the start of a Lisp_Symbol, not be one of the unused cells in the current symbol block, and not be on the free-list. */ @@ -3205,7 +3233,7 @@ live_float_p (m, p) { struct float_block *b = (struct float_block *) m->start; int offset = (char *) p - (char *) &b->floats[0]; - + /* P must point to the start of a Lisp_Float, not be one of the unused cells in the current float block, and not be on the free-list. */ @@ -3232,7 +3260,7 @@ live_misc_p (m, p) { struct marker_block *b = (struct marker_block *) m->start; int offset = (char *) p - (char *) &b->markers[0]; - + /* P must point to the start of a Lisp_Misc, not be one of the unused cells in the current misc block, and not be on the free-list. */ @@ -3312,15 +3340,19 @@ DEFUN ("gc-status", Fgc_status, Sgc_status, 0, 0, "", doc: /* Show information about live and zombie objects. */) () { - Lisp_Object args[7]; - args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d"); + Lisp_Object args[8], zombie_list = Qnil; + int i; + for (i = 0; i < nzombies; i++) + zombie_list = Fcons (zombies[i], zombie_list); + args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S"); args[1] = make_number (ngcs); args[2] = make_float (avg_live); args[3] = make_float (avg_zombies); args[4] = make_float (avg_zombies / avg_live / 100); args[5] = make_number (max_live); args[6] = make_number (max_zombies); - return Fmessage (7, args); + args[7] = zombie_list; + return Fmessage (8, args); } #endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */ @@ -3334,7 +3366,7 @@ mark_maybe_object (obj) { void *po = (void *) XPNTR (obj); struct mem_node *m = mem_find (po); - + if (m != MEM_NIL) { int mark_p = 0; @@ -3380,12 +3412,12 @@ mark_maybe_object (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; @@ -3402,7 +3434,7 @@ mark_maybe_object (obj) { #if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES if (nzombies < MAX_ZOMBIES) - zombies[nzombies] = *p; + zombies[nzombies] = obj; ++nzombies; #endif mark_object (&obj); @@ -3424,30 +3456,30 @@ mark_maybe_pointer (p) assume that Lisp data is aligned on even addresses. */ if ((EMACS_INT) p & 1) return; - + m = mem_find (p); if (m != MEM_NIL) { Lisp_Object obj = Qnil; - + switch (m->type) { case MEM_TYPE_NON_LISP: /* Nothing to do; not a pointer to Lisp memory. */ break; - + case MEM_TYPE_BUFFER: if (live_buffer_p (m, p) && !XMARKBIT (((struct buffer *) p)->name)) XSETVECTOR (obj, p); break; - + case MEM_TYPE_CONS: if (live_cons_p (m, p) && !XMARKBIT (((struct Lisp_Cons *) p)->car)) XSETCONS (obj, p); break; - + case MEM_TYPE_STRING: if (live_string_p (m, p) && !STRING_MARKED_P ((struct Lisp_String *) p)) @@ -3459,20 +3491,20 @@ mark_maybe_pointer (p) { Lisp_Object tem; XSETMISC (tem, p); - + switch (XMISCTYPE (tem)) { case Lisp_Misc_Marker: if (!XMARKBIT (XMARKER (tem)->chain)) obj = tem; break; - + case Lisp_Misc_Buffer_Local_Value: case Lisp_Misc_Some_Buffer_Local_Value: if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue)) obj = tem; break; - + case Lisp_Misc_Overlay: if (!XMARKBIT (XOVERLAY (tem)->plist)) obj = tem; @@ -3480,19 +3512,19 @@ mark_maybe_pointer (p) } } break; - + case MEM_TYPE_SYMBOL: if (live_symbol_p (m, p) && !XMARKBIT (((struct Lisp_Symbol *) p)->plist)) XSETSYMBOL (obj, p); break; - + case MEM_TYPE_FLOAT: if (live_float_p (m, p) && !XMARKBIT (((struct Lisp_Float *) p)->type)) XSETFLOAT (obj, p); break; - + case MEM_TYPE_VECTOR: case MEM_TYPE_PROCESS: case MEM_TYPE_HASH_TABLE: @@ -3520,7 +3552,7 @@ mark_maybe_pointer (p) /* Mark Lisp objects referenced from the address range START..END. */ -static void +static void mark_memory (start, end) void *start, *end; { @@ -3561,11 +3593,15 @@ mark_memory (start, end) Here, `obj' isn't really used, and the compiler optimizes it away. The only reference to the life string is through the pointer `s'. */ - + for (pp = (void **) start; (void *) pp < end; ++pp) mark_maybe_pointer (*pp); } +/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in + the GCC system configuration. In gcc 3.2, the only systems for + which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included + by others?) and ns32k-pc532-min. */ #if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS @@ -3593,6 +3629,10 @@ 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\ +\n\ +Note that you may get false negatives, depending on the compiler.\n\ +In particular, you need to use -O with GCC for this test.\n\ +\n\ Please mail the result to .\n\ " @@ -3737,17 +3777,20 @@ mark_stack () /* This trick flushes the register windows so that all the state of the process is contained in the stack. */ + /* Fixme: Code in the Boehm GC sugests flushing (with `flushrs') is + needed on ia64 too. See mach_dep.c, where it also says inline + assembler doesn't work with relevant proprietary compilers. */ #ifdef sparc asm ("ta 3"); #endif - + /* Save registers that we need to see on the stack. We need to see registers used to hold register variables and registers used to pass parameters. */ #ifdef GC_SAVE_REGISTERS_ON_STACK GC_SAVE_REGISTERS_ON_STACK (end); #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 @@ -3758,7 +3801,7 @@ mark_stack () test_setjmp (); } #endif /* GC_SETJMP_WORKS */ - + setjmp (j); end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; #endif /* not GC_SAVE_REGISTERS_ON_STACK */ @@ -3767,7 +3810,11 @@ mark_stack () that's not the case, something has to be done here to iterate over the stack segments. */ #ifndef GC_LISP_OBJECT_ALIGNMENT +#ifdef __GNUC__ +#define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object) +#else #define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object) +#endif #endif for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT) mark_memory ((char *) stack_base + i, end); @@ -3798,38 +3845,34 @@ pure_alloc (size, type) size_t size; int type; { - size_t nbytes; POINTER_TYPE *result; - char *beg = purebeg; + size_t alignment = sizeof (EMACS_INT); /* Give Lisp_Floats an extra alignment. */ if (type == Lisp_Float) { - size_t alignment; #if defined __GNUC__ && __GNUC__ >= 2 alignment = __alignof (struct Lisp_Float); #else alignment = sizeof (struct Lisp_Float); #endif - pure_bytes_used = ALIGN (pure_bytes_used, alignment); - } - - nbytes = ALIGN (size, sizeof (EMACS_INT)); - - if (pure_bytes_used + nbytes > pure_size) - { - /* Don't allocate a large amount here, - because it might get mmap'd and then its address - might not be usable. */ - beg = purebeg = (char *) xmalloc (10000); - pure_size = 10000; - pure_bytes_used_before_overflow += pure_bytes_used; - pure_bytes_used = 0; } - result = (POINTER_TYPE *) (beg + pure_bytes_used); - pure_bytes_used += nbytes; - return result; + again: + result = (POINTER_TYPE *) ALIGN ((EMACS_UINT)purebeg + pure_bytes_used, alignment); + pure_bytes_used = ((char *)result - (char *)purebeg) + size; + + if (pure_bytes_used <= pure_size) + return result; + + /* Don't allocate a large amount here, + because it might get mmap'd and then its address + might not be usable. */ + purebeg = (char *) xmalloc (10000); + pure_size = 10000; + pure_bytes_used_before_overflow += pure_bytes_used - size; + pure_bytes_used = 0; + goto again; } @@ -4045,6 +4088,9 @@ Garbage collection happens automatically if you cons more than int message_p; Lisp_Object total[8]; int count = SPECPDL_INDEX (); + EMACS_TIME t1, t2, t3; + + EMACS_GET_TIME (t1); /* Can't GC if pure storage overflowed because we can't determine if something is a pure object or not. */ @@ -4100,7 +4146,7 @@ Garbage collection happens automatically if you cons more than Qt tends to return NULL, which effectively turns undo back on. So don't call truncate_undo_list if undo_list is Qt. */ if (! EQ (nextb->undo_list, Qt)) - nextb->undo_list + nextb->undo_list = truncate_undo_list (nextb->undo_list, undo_limit, undo_strong_limit); @@ -4153,7 +4199,7 @@ Garbage collection happens automatically if you cons more than XMARK (tail->var[i]); } #endif - + mark_byte_stack (); for (bind = specpdl; bind != specpdl_ptr; bind++) { @@ -4164,12 +4210,12 @@ Garbage collection happens automatically if you cons more than { mark_object (&catch->tag); mark_object (&catch->val); - } + } for (handler = handlerlist; handler; handler = handler->next) { mark_object (&handler->handler); mark_object (&handler->var); - } + } for (backlist = backtrace_list; backlist; backlist = backlist->next) { if (!XMARKBIT (*backlist->function)) @@ -4187,7 +4233,7 @@ Garbage collection happens automatically if you cons more than mark_object (&backlist->args[i]); XMARK (backlist->args[i]); } - } + } mark_kboards (); /* Look thru every buffer's undo list @@ -4237,6 +4283,13 @@ Garbage collection happens automatically if you cons more than mark_stack (); #endif +#ifdef USE_GTK + { + extern void xg_mark_data (); + xg_mark_data (); + } +#endif + gc_sweep (); /* Clear the mark bits that we set in certain root slots. */ @@ -4247,7 +4300,7 @@ Garbage collection happens automatically if you cons more than for (i = 0; i < tail->nvars; i++) XUNMARK (tail->var[i]); #endif - + unmark_byte_stack (); for (backlist = backtrace_list; backlist; backlist = backlist->next) { @@ -4258,7 +4311,7 @@ Garbage collection happens automatically if you cons more than i = backlist->nargs - 1; for (; i >= 0; i--) XUNMARK (backlist->args[i]); - } + } XUNMARK (buffer_defaults.name); XUNMARK (buffer_local_symbols.name); @@ -4304,9 +4357,10 @@ Garbage collection happens automatically if you cons more than { /* Compute average percentage of zombies. */ double nlive = 0; - + for (i = 0; i < 7; ++i) - nlive += XFASTINT (XCAR (total[i])); + if (CONSP (total[i])) + nlive += XFASTINT (XCAR (total[i])); avg_live = (avg_live * ngcs + nlive) / (ngcs + 1); max_live = max (nlive, max_live); @@ -4322,7 +4376,16 @@ Garbage collection happens automatically if you cons more than safe_run_hooks (Qpost_gc_hook); unbind_to (count, Qnil); } - + + /* Accumulate statistics. */ + EMACS_GET_TIME (t2); + EMACS_SUB_TIME (t3, t2, t1); + if (FLOATP (Vgc_elapsed)) + Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) + + EMACS_SECS (t3) + + EMACS_USECS (t3) * 1.0e-6); + gcs_done++; + return Flist (sizeof total / sizeof *total, total); } @@ -4345,7 +4408,7 @@ mark_glyph_matrix (matrix) { struct glyph *glyph = row->glyphs[area]; struct glyph *end_glyph = glyph + row->used[area]; - + for (; glyph < end_glyph; ++glyph) if (GC_STRINGP (glyph->object) && !STRING_MARKED_P (XSTRING (glyph->object))) @@ -4387,7 +4450,7 @@ mark_image (img) struct image *img; { mark_object (&img->spec); - + if (!NILP (img->data.lisp_val)) mark_object (&img->data.lisp_val); } @@ -4475,13 +4538,13 @@ mark_object (argptr) CHECK_ALLOCATED (); \ CHECK_LIVE (LIVEP); \ } while (0) \ - + #else /* not GC_CHECK_MARKED_OBJECTS */ - + #define CHECK_ALLOCATED() (void) 0 #define CHECK_LIVE(LIVEP) (void) 0 #define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0 - + #endif /* not GC_CHECK_MARKED_OBJECTS */ switch (SWITCH_ENUM_CAST (XGCTYPE (obj))) @@ -4508,7 +4571,7 @@ mark_object (argptr) && po != &buffer_local_symbols) abort (); #endif /* GC_CHECK_MARKED_OBJECTS */ - + if (GC_BUFFERP (obj)) { if (!XMARKBIT (XBUFFER (obj)->name)) @@ -4539,7 +4602,7 @@ mark_object (argptr) if (size & ARRAY_MARK_FLAG) break; /* Already marked */ - + CHECK_LIVE (live_vector_p); ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ size &= PSEUDOVECTOR_SIZE_MASK; @@ -4632,18 +4695,18 @@ mark_object (argptr) { struct Lisp_Hash_Table *h = XHASH_TABLE (obj); EMACS_INT size = h->size; - + /* Stop if already marked. */ if (size & ARRAY_MARK_FLAG) break; - + /* Mark it. */ CHECK_LIVE (live_vector_p); h->size |= ARRAY_MARK_FLAG; /* Mark contents. */ /* Do not mark next_free or next_weak. - Being in the next_weak chain + Being in the next_weak chain should not keep the hash table alive. No need to mark `count' since it is an integer. */ mark_object (&h->test); @@ -4662,7 +4725,7 @@ mark_object (argptr) mark_object (&h->key_and_value); else XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG; - + } else { @@ -4696,7 +4759,7 @@ mark_object (argptr) if (!PURE_POINTER_P (XSTRING (ptr->xname))) MARK_STRING (XSTRING (ptr->xname)); MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname)); - + /* Note that we do not mark the obarray of the symbol. It is safe not to do so because nothing accesses that slot except to check whether it is nil. */ @@ -4870,7 +4933,7 @@ mark_buffer (buf) /* If this is an indirect buffer, mark its base buffer. */ if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name)) { - XSETBUFFER (base_buffer, buffer->base_buffer); + XSETBUFFER (base_buffer, buffer->base_buffer); mark_buffer (base_buffer); } } @@ -4912,7 +4975,7 @@ survives_gc_p (obj) Lisp_Object obj; { int survives_p; - + switch (XGCTYPE (obj)) { case Lisp_Int: @@ -4929,12 +4992,12 @@ survives_gc_p (obj) case Lisp_Misc_Marker: survives_p = XMARKBIT (obj); break; - + case Lisp_Misc_Buffer_Local_Value: case Lisp_Misc_Some_Buffer_Local_Value: survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue); break; - + case Lisp_Misc_Intfwd: case Lisp_Misc_Boolfwd: case Lisp_Misc_Objfwd: @@ -4942,7 +5005,7 @@ survives_gc_p (obj) case Lisp_Misc_Kboard_Objfwd: survives_p = 1; break; - + case Lisp_Misc_Overlay: survives_p = XMARKBIT (XOVERLAY (obj)->plist); break; @@ -5008,7 +5071,7 @@ gc_sweep () register int num_free = 0, num_used = 0; cons_free_list = 0; - + for (cblk = cons_block; cblk; cblk = *cprev) { register int i; @@ -5058,7 +5121,7 @@ gc_sweep () register int num_free = 0, num_used = 0; float_free_list = 0; - + for (fblk = float_block; fblk; fblk = *fprev) { register int i; @@ -5158,7 +5221,7 @@ gc_sweep () register int num_free = 0, num_used = 0; symbol_free_list = NULL; - + for (sblk = symbol_block; sblk; sblk = *sprev) { int this_free = 0; @@ -5171,7 +5234,7 @@ gc_sweep () it might be pointed to by pure bytecode which we don't trace, so we conservatively assume that it is live. */ int pure_p = PURE_POINTER_P (XSTRING (sym->xname)); - + if (!XMARKBIT (sym->plist) && !pure_p) { *(struct Lisp_Symbol **) &sym->value = symbol_free_list; @@ -5189,7 +5252,7 @@ gc_sweep () XUNMARK (sym->plist); } } - + lim = SYMBOL_BLOCK_SIZE; /* If this block contains only free symbols and we have already seen more than two blocks worth of free symbols then deallocate @@ -5221,7 +5284,7 @@ gc_sweep () register int num_free = 0, num_used = 0; marker_free_list = 0; - + for (mblk = marker_block; mblk; mblk = *mprev) { register int i; @@ -5351,7 +5414,7 @@ gc_sweep () prev = vector, vector = vector->next; } } - + #ifdef GC_CHECK_STRING_BYTES if (!noninteractive) check_string_bytes (1); @@ -5477,6 +5540,8 @@ init_alloc () setjmp_tested_p = longjmps_done = 0; #endif #endif + Vgc_elapsed = make_float (0.0); + gcs_done = 0; } void @@ -5566,6 +5631,14 @@ which includes both saved text and other data. */); staticpro (&Qchar_table_extra_slots); Qchar_table_extra_slots = intern ("char-table-extra-slots"); + DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed, + doc: /* Accumulated time elapsed in garbage collections. +The time is in seconds as a floating point value. +Programs may reset this to get statistics in a specific period. */); + DEFVAR_INT ("gcs-done", &gcs_done, + doc: /* Accumulated number of garbage collections done. +Programs may reset this to get statistics in a specific period. */); + defsubr (&Scons); defsubr (&Slist); defsubr (&Svector);