1 |
/* Storage allocation and gc for GNU Emacs Lisp interpreter. |
/* Storage allocation and gc for GNU Emacs Lisp interpreter. |
2 |
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 |
3 |
Free Software Foundation, Inc. |
Free Software Foundation, Inc. |
4 |
|
|
5 |
This file is part of GNU Emacs. |
This file is part of GNU Emacs. |
22 |
#include <config.h> |
#include <config.h> |
23 |
#include <stdio.h> |
#include <stdio.h> |
24 |
|
|
25 |
|
#ifdef ALLOC_DEBUG |
26 |
|
#undef INLINE |
27 |
|
#endif |
28 |
|
|
29 |
/* Note that this declares bzero on OSF/1. How dumb. */ |
/* Note that this declares bzero on OSF/1. How dumb. */ |
30 |
|
|
31 |
#include <signal.h> |
#include <signal.h> |
185 |
|
|
186 |
Lisp_Object Vpurify_flag; |
Lisp_Object Vpurify_flag; |
187 |
|
|
188 |
|
/* Non-nil means we are handling a memory-full error. */ |
189 |
|
|
190 |
|
Lisp_Object Vmemory_full; |
191 |
|
|
192 |
#ifndef HAVE_SHM |
#ifndef HAVE_SHM |
193 |
|
|
194 |
/* Force it into data space! */ |
/* Force it into data space! */ |
232 |
|
|
233 |
/* Pre-computed signal argument for use when memory is exhausted. */ |
/* Pre-computed signal argument for use when memory is exhausted. */ |
234 |
|
|
235 |
Lisp_Object memory_signal_data; |
Lisp_Object Vmemory_signal_data; |
236 |
|
|
237 |
/* Maximum amount of C stack to save when a GC happens. */ |
/* Maximum amount of C stack to save when a GC happens. */ |
238 |
|
|
256 |
|
|
257 |
Lisp_Object Vpost_gc_hook, Qpost_gc_hook; |
Lisp_Object Vpost_gc_hook, Qpost_gc_hook; |
258 |
|
|
259 |
|
Lisp_Object Vgc_elapsed; /* accumulated elapsed time in GC */ |
260 |
|
EMACS_INT gcs_done; /* accumulated GCs */ |
261 |
|
|
262 |
static void mark_buffer P_ ((Lisp_Object)); |
static void mark_buffer P_ ((Lisp_Object)); |
263 |
static void mark_kboards P_ ((void)); |
static void mark_kboards P_ ((void)); |
264 |
static void gc_sweep P_ ((void)); |
static void gc_sweep P_ ((void)); |
344 |
|
|
345 |
struct mem_node |
struct mem_node |
346 |
{ |
{ |
347 |
struct mem_node *left, *right, *parent; |
/* Children of this node. These pointers are never NULL. When there |
348 |
|
is no child, the value is MEM_NIL, which points to a dummy node. */ |
349 |
|
struct mem_node *left, *right; |
350 |
|
|
351 |
|
/* The parent of this node. In the root node, this is NULL. */ |
352 |
|
struct mem_node *parent; |
353 |
|
|
354 |
/* Start and end of allocated region. */ |
/* Start and end of allocated region. */ |
355 |
void *start, *end; |
void *start, *end; |
356 |
|
|
357 |
/* Node color. */ |
/* Node color. */ |
358 |
enum {MEM_BLACK, MEM_RED} color; |
enum {MEM_BLACK, MEM_RED} color; |
359 |
|
|
360 |
/* Memory type. */ |
/* Memory type. */ |
361 |
enum mem_type type; |
enum mem_type type; |
362 |
}; |
}; |
434 |
Malloc |
Malloc |
435 |
************************************************************************/ |
************************************************************************/ |
436 |
|
|
437 |
/* Write STR to Vstandard_output plus some advice on how to free some |
/* Function malloc calls this if it finds we are near exhausting storage. */ |
|
memory. Called when memory gets low. */ |
|
|
|
|
|
Lisp_Object |
|
|
malloc_warning_1 (str) |
|
|
Lisp_Object str; |
|
|
{ |
|
|
Fprinc (str, Vstandard_output); |
|
|
write_string ("\nKilling some buffers may delay running out of memory.\n", -1); |
|
|
write_string ("However, certainly by the time you receive the 95% warning,\n", -1); |
|
|
write_string ("you should clean up, kill this Emacs, and start a new one.", -1); |
|
|
return Qnil; |
|
|
} |
|
|
|
|
|
|
|
|
/* Function malloc calls this if it finds we are near exhausting |
|
|
storage. */ |
|
438 |
|
|
439 |
void |
void |
440 |
malloc_warning (str) |
malloc_warning (str) |
444 |
} |
} |
445 |
|
|
446 |
|
|
447 |
/* Display a malloc warning in buffer *Danger*. */ |
/* Display an already-pending malloc warning. */ |
448 |
|
|
449 |
void |
void |
450 |
display_malloc_warning () |
display_malloc_warning () |
451 |
{ |
{ |
452 |
register Lisp_Object val; |
call3 (intern ("display-warning"), |
453 |
|
intern ("alloc"), |
454 |
val = build_string (pending_malloc_warning); |
build_string (pending_malloc_warning), |
455 |
|
intern ("emergency")); |
456 |
pending_malloc_warning = 0; |
pending_malloc_warning = 0; |
|
internal_with_output_to_temp_buffer (" *Danger*", malloc_warning_1, val); |
|
457 |
} |
} |
458 |
|
|
459 |
|
|
469 |
void |
void |
470 |
memory_full () |
memory_full () |
471 |
{ |
{ |
472 |
|
Vmemory_full = Qt; |
473 |
|
|
474 |
#ifndef SYSTEM_MALLOC |
#ifndef SYSTEM_MALLOC |
475 |
bytes_used_when_full = BYTES_USED; |
bytes_used_when_full = BYTES_USED; |
476 |
#endif |
#endif |
485 |
/* This used to call error, but if we've run out of memory, we could |
/* This used to call error, but if we've run out of memory, we could |
486 |
get infinite recursion trying to build the string. */ |
get infinite recursion trying to build the string. */ |
487 |
while (1) |
while (1) |
488 |
Fsignal (Qnil, memory_signal_data); |
Fsignal (Qnil, Vmemory_signal_data); |
489 |
} |
} |
490 |
|
|
491 |
|
|
505 |
memory_full (); |
memory_full (); |
506 |
#endif |
#endif |
507 |
|
|
508 |
|
Vmemory_full = Qt; |
509 |
|
|
510 |
/* This used to call error, but if we've run out of memory, we could |
/* This used to call error, but if we've run out of memory, we could |
511 |
get infinite recursion trying to build the string. */ |
get infinite recursion trying to build the string. */ |
512 |
while (1) |
while (1) |
513 |
Fsignal (Qerror, memory_signal_data); |
Fsignal (Qnil, Vmemory_signal_data); |
514 |
} |
} |
515 |
|
|
516 |
|
|
571 |
|
|
572 |
char * |
char * |
573 |
xstrdup (s) |
xstrdup (s) |
574 |
char *s; |
const char *s; |
575 |
{ |
{ |
576 |
size_t len = strlen (s) + 1; |
size_t len = strlen (s) + 1; |
577 |
char *p = (char *) xmalloc (len); |
char *p = (char *) xmalloc (len); |
596 |
#ifdef GC_MALLOC_CHECK |
#ifdef GC_MALLOC_CHECK |
597 |
allocated_mem_type = type; |
allocated_mem_type = type; |
598 |
#endif |
#endif |
599 |
|
|
600 |
val = (void *) malloc (nbytes); |
val = (void *) malloc (nbytes); |
601 |
|
|
602 |
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK |
#if GC_MARK_STACK && !defined GC_MALLOC_CHECK |
603 |
if (val && type != MEM_TYPE_NON_LISP) |
if (val && type != MEM_TYPE_NON_LISP) |
604 |
mem_insert (val, (char *) val + nbytes, type); |
mem_insert (val, (char *) val + nbytes, type); |
605 |
#endif |
#endif |
606 |
|
|
607 |
UNBLOCK_INPUT; |
UNBLOCK_INPUT; |
608 |
if (!val && nbytes) |
if (!val && nbytes) |
609 |
memory_full (); |
memory_full (); |
617 |
struct buffer * |
struct buffer * |
618 |
allocate_buffer () |
allocate_buffer () |
619 |
{ |
{ |
620 |
struct buffer *b |
struct buffer *b |
621 |
= (struct buffer *) lisp_malloc (sizeof (struct buffer), |
= (struct buffer *) lisp_malloc (sizeof (struct buffer), |
622 |
MEM_TYPE_BUFFER); |
MEM_TYPE_BUFFER); |
623 |
VALIDATE_LISP_STORAGE (b, sizeof *b); |
VALIDATE_LISP_STORAGE (b, sizeof *b); |
648 |
elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT |
elsewhere in the code should be inside a BLOCK_INPUT/UNBLOCK_INPUT |
649 |
pairs; unfortunately, we have no idea what C library functions |
pairs; unfortunately, we have no idea what C library functions |
650 |
might call malloc, so we can't really protect them unless you're |
might call malloc, so we can't really protect them unless you're |
651 |
using GNU malloc. Fortunately, most of the major operating can use |
using GNU malloc. Fortunately, most of the major operating systems |
652 |
GNU malloc. */ |
can use GNU malloc. */ |
653 |
|
|
654 |
#ifndef SYSTEM_MALLOC |
#ifndef SYSTEM_MALLOC |
655 |
#ifndef DOUG_LEA_MALLOC |
#ifndef DOUG_LEA_MALLOC |
674 |
if (ptr) |
if (ptr) |
675 |
{ |
{ |
676 |
struct mem_node *m; |
struct mem_node *m; |
677 |
|
|
678 |
m = mem_find (ptr); |
m = mem_find (ptr); |
679 |
if (m == MEM_NIL || m->start != ptr) |
if (m == MEM_NIL || m->start != ptr) |
680 |
{ |
{ |
689 |
} |
} |
690 |
} |
} |
691 |
#endif /* GC_MALLOC_CHECK */ |
#endif /* GC_MALLOC_CHECK */ |
692 |
|
|
693 |
__free_hook = old_free_hook; |
__free_hook = old_free_hook; |
694 |
free (ptr); |
free (ptr); |
695 |
|
|
696 |
/* If we released our reserve (due to running out of memory), |
/* If we released our reserve (due to running out of memory), |
697 |
and we have a fair amount free once again, |
and we have a fair amount free once again, |
698 |
try to set aside another reserve in case we run out once more. */ |
try to set aside another reserve in case we run out once more. */ |
762 |
} |
} |
763 |
} |
} |
764 |
#endif /* GC_MALLOC_CHECK */ |
#endif /* GC_MALLOC_CHECK */ |
765 |
|
|
766 |
__malloc_hook = emacs_blocked_malloc; |
__malloc_hook = emacs_blocked_malloc; |
767 |
UNBLOCK_INPUT; |
UNBLOCK_INPUT; |
768 |
|
|
797 |
|
|
798 |
mem_delete (m); |
mem_delete (m); |
799 |
} |
} |
800 |
|
|
801 |
/* fprintf (stderr, "%p -> realloc\n", ptr); */ |
/* fprintf (stderr, "%p -> realloc\n", ptr); */ |
802 |
|
|
803 |
/* Prevent malloc from registering blocks. */ |
/* Prevent malloc from registering blocks. */ |
804 |
dont_register_blocks = 1; |
dont_register_blocks = 1; |
805 |
#endif /* GC_MALLOC_CHECK */ |
#endif /* GC_MALLOC_CHECK */ |
820 |
/* Can't handle zero size regions in the red-black tree. */ |
/* Can't handle zero size regions in the red-black tree. */ |
821 |
mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP); |
mem_insert (value, (char *) value + max (size, 1), MEM_TYPE_NON_LISP); |
822 |
} |
} |
823 |
|
|
824 |
/* fprintf (stderr, "%p <- realloc\n", value); */ |
/* fprintf (stderr, "%p <- realloc\n", value); */ |
825 |
#endif /* GC_MALLOC_CHECK */ |
#endif /* GC_MALLOC_CHECK */ |
826 |
|
|
827 |
__realloc_hook = emacs_blocked_realloc; |
__realloc_hook = emacs_blocked_realloc; |
828 |
UNBLOCK_INPUT; |
UNBLOCK_INPUT; |
829 |
|
|
1069 |
struct Lisp_String *string; |
struct Lisp_String *string; |
1070 |
|
|
1071 |
#ifdef GC_CHECK_STRING_BYTES |
#ifdef GC_CHECK_STRING_BYTES |
1072 |
|
|
1073 |
EMACS_INT nbytes; |
EMACS_INT nbytes; |
1074 |
unsigned char data[1]; |
unsigned char data[1]; |
1075 |
|
|
1076 |
#define SDATA_NBYTES(S) (S)->nbytes |
#define SDATA_NBYTES(S) (S)->nbytes |
1077 |
#define SDATA_DATA(S) (S)->data |
#define SDATA_DATA(S) (S)->data |
1078 |
|
|
1079 |
#else /* not GC_CHECK_STRING_BYTES */ |
#else /* not GC_CHECK_STRING_BYTES */ |
1080 |
|
|
1081 |
union |
union |
1086 |
/* When STRING is null. */ |
/* When STRING is null. */ |
1087 |
EMACS_INT nbytes; |
EMACS_INT nbytes; |
1088 |
} u; |
} u; |
1089 |
|
|
1090 |
|
|
1091 |
#define SDATA_NBYTES(S) (S)->u.nbytes |
#define SDATA_NBYTES(S) (S)->u.nbytes |
1092 |
#define SDATA_DATA(S) (S)->u.data |
#define SDATA_DATA(S) (S)->u.data |
1165 |
S must be live, i.e. S->data must not be null. S->data is actually |
S must be live, i.e. S->data must not be null. S->data is actually |
1166 |
a pointer to the `u.data' member of its sdata structure; the |
a pointer to the `u.data' member of its sdata structure; the |
1167 |
structure starts at a constant offset in front of that. */ |
structure starts at a constant offset in front of that. */ |
1168 |
|
|
1169 |
#ifdef GC_CHECK_STRING_BYTES |
#ifdef GC_CHECK_STRING_BYTES |
1170 |
|
|
1171 |
#define SDATA_OF_STRING(S) \ |
#define SDATA_OF_STRING(S) \ |
1238 |
abort (); |
abort (); |
1239 |
return nbytes; |
return nbytes; |
1240 |
} |
} |
1241 |
|
|
1242 |
/* Check validity Lisp strings' string_bytes member in B. */ |
/* Check validity of Lisp strings' string_bytes member in B. */ |
1243 |
|
|
1244 |
void |
void |
1245 |
check_sblock (b) |
check_sblock (b) |
1246 |
struct sblock *b; |
struct sblock *b; |
1247 |
{ |
{ |
1248 |
struct sdata *from, *end, *from_end; |
struct sdata *from, *end, *from_end; |
1249 |
|
|
1250 |
end = b->next_free; |
end = b->next_free; |
1251 |
|
|
1252 |
for (from = &b->first_data; from < end; from = from_end) |
for (from = &b->first_data; from < end; from = from_end) |
1253 |
{ |
{ |
1254 |
/* Compute the next FROM here because copying below may |
/* Compute the next FROM here because copying below may |
1255 |
overwrite data we need to compute it. */ |
overwrite data we need to compute it. */ |
1256 |
int nbytes; |
int nbytes; |
1257 |
|
|
1258 |
/* Check that the string size recorded in the string is the |
/* Check that the string size recorded in the string is the |
1259 |
same as the one recorded in the sdata structure. */ |
same as the one recorded in the sdata structure. */ |
1260 |
if (from->string) |
if (from->string) |
1261 |
CHECK_STRING_BYTES (from->string); |
CHECK_STRING_BYTES (from->string); |
1262 |
|
|
1263 |
if (from->string) |
if (from->string) |
1264 |
nbytes = GC_STRING_BYTES (from->string); |
nbytes = GC_STRING_BYTES (from->string); |
1265 |
else |
else |
1266 |
nbytes = SDATA_NBYTES (from); |
nbytes = SDATA_NBYTES (from); |
1267 |
|
|
1268 |
nbytes = SDATA_SIZE (nbytes); |
nbytes = SDATA_SIZE (nbytes); |
1269 |
from_end = (struct sdata *) ((char *) from + nbytes); |
from_end = (struct sdata *) ((char *) from + nbytes); |
1270 |
} |
} |
1289 |
if (s) |
if (s) |
1290 |
CHECK_STRING_BYTES (s); |
CHECK_STRING_BYTES (s); |
1291 |
} |
} |
1292 |
|
|
1293 |
for (b = oldest_sblock; b; b = b->next) |
for (b = oldest_sblock; b; b = b->next) |
1294 |
check_sblock (b); |
check_sblock (b); |
1295 |
} |
} |
1395 |
#endif |
#endif |
1396 |
|
|
1397 |
b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP); |
b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP); |
1398 |
|
|
1399 |
#ifdef DOUG_LEA_MALLOC |
#ifdef DOUG_LEA_MALLOC |
1400 |
/* Back to a reasonable maximum of mmap'ed areas. */ |
/* Back to a reasonable maximum of mmap'ed areas. */ |
1401 |
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); |
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); |
1402 |
#endif |
#endif |
1403 |
|
|
1404 |
b->next_free = &b->first_data; |
b->next_free = &b->first_data; |
1405 |
b->first_data.string = NULL; |
b->first_data.string = NULL; |
1406 |
b->next = large_sblocks; |
b->next = large_sblocks; |
1428 |
|
|
1429 |
old_data = s->data ? SDATA_OF_STRING (s) : NULL; |
old_data = s->data ? SDATA_OF_STRING (s) : NULL; |
1430 |
old_nbytes = GC_STRING_BYTES (s); |
old_nbytes = GC_STRING_BYTES (s); |
1431 |
|
|
1432 |
data = b->next_free; |
data = b->next_free; |
1433 |
data->string = s; |
data->string = s; |
1434 |
s->data = SDATA_DATA (data); |
s->data = SDATA_DATA (data); |
1439 |
s->size_byte = nbytes; |
s->size_byte = nbytes; |
1440 |
s->data[nbytes] = '\0'; |
s->data[nbytes] = '\0'; |
1441 |
b->next_free = (struct sdata *) ((char *) data + needed); |
b->next_free = (struct sdata *) ((char *) data + needed); |
1442 |
|
|
1443 |
/* If S had already data assigned, mark that as free by setting its |
/* If S had already data assigned, mark that as free by setting its |
1444 |
string back-pointer to null, and recording the size of the data |
string back-pointer to null, and recording the size of the data |
1445 |
in it. */ |
in it. */ |
1460 |
{ |
{ |
1461 |
struct string_block *b, *next; |
struct string_block *b, *next; |
1462 |
struct string_block *live_blocks = NULL; |
struct string_block *live_blocks = NULL; |
1463 |
|
|
1464 |
string_free_list = NULL; |
string_free_list = NULL; |
1465 |
total_strings = total_free_strings = 0; |
total_strings = total_free_strings = 0; |
1466 |
total_string_size = 0; |
total_string_size = 0; |
1484 |
{ |
{ |
1485 |
/* String is live; unmark it and its intervals. */ |
/* String is live; unmark it and its intervals. */ |
1486 |
UNMARK_STRING (s); |
UNMARK_STRING (s); |
1487 |
|
|
1488 |
if (!NULL_INTERVAL_P (s->intervals)) |
if (!NULL_INTERVAL_P (s->intervals)) |
1489 |
UNMARK_BALANCE_INTERVALS (s->intervals); |
UNMARK_BALANCE_INTERVALS (s->intervals); |
1490 |
|
|
1556 |
{ |
{ |
1557 |
struct sblock *b, *next; |
struct sblock *b, *next; |
1558 |
struct sblock *live_blocks = NULL; |
struct sblock *live_blocks = NULL; |
1559 |
|
|
1560 |
for (b = large_sblocks; b; b = next) |
for (b = large_sblocks; b; b = next) |
1561 |
{ |
{ |
1562 |
next = b->next; |
next = b->next; |
1597 |
{ |
{ |
1598 |
end = b->next_free; |
end = b->next_free; |
1599 |
xassert ((char *) end <= (char *) b + SBLOCK_SIZE); |
xassert ((char *) end <= (char *) b + SBLOCK_SIZE); |
1600 |
|
|
1601 |
for (from = &b->first_data; from < end; from = from_end) |
for (from = &b->first_data; from < end; from = from_end) |
1602 |
{ |
{ |
1603 |
/* Compute the next FROM here because copying below may |
/* Compute the next FROM here because copying below may |
1611 |
&& GC_STRING_BYTES (from->string) != SDATA_NBYTES (from)) |
&& GC_STRING_BYTES (from->string) != SDATA_NBYTES (from)) |
1612 |
abort (); |
abort (); |
1613 |
#endif /* GC_CHECK_STRING_BYTES */ |
#endif /* GC_CHECK_STRING_BYTES */ |
1614 |
|
|
1615 |
if (from->string) |
if (from->string) |
1616 |
nbytes = GC_STRING_BYTES (from->string); |
nbytes = GC_STRING_BYTES (from->string); |
1617 |
else |
else |
1618 |
nbytes = SDATA_NBYTES (from); |
nbytes = SDATA_NBYTES (from); |
1619 |
|
|
1620 |
nbytes = SDATA_SIZE (nbytes); |
nbytes = SDATA_SIZE (nbytes); |
1621 |
from_end = (struct sdata *) ((char *) from + nbytes); |
from_end = (struct sdata *) ((char *) from + nbytes); |
1622 |
|
|
1623 |
/* FROM->string non-null means it's alive. Copy its data. */ |
/* FROM->string non-null means it's alive. Copy its data. */ |
1624 |
if (from->string) |
if (from->string) |
1625 |
{ |
{ |
1633 |
to = &tb->first_data; |
to = &tb->first_data; |
1634 |
to_end = (struct sdata *) ((char *) to + nbytes); |
to_end = (struct sdata *) ((char *) to + nbytes); |
1635 |
} |
} |
1636 |
|
|
1637 |
/* Copy, and update the string's `data' pointer. */ |
/* Copy, and update the string's `data' pointer. */ |
1638 |
if (from != to) |
if (from != to) |
1639 |
{ |
{ |
1680 |
{ |
{ |
1681 |
nbytes = XINT (length); |
nbytes = XINT (length); |
1682 |
val = make_uninit_string (nbytes); |
val = make_uninit_string (nbytes); |
1683 |
p = XSTRING (val)->data; |
p = SDATA (val); |
1684 |
end = p + XSTRING (val)->size; |
end = p + SCHARS (val); |
1685 |
while (p != end) |
while (p != end) |
1686 |
*p++ = c; |
*p++ = c; |
1687 |
} |
} |
1692 |
|
|
1693 |
nbytes = len * XINT (length); |
nbytes = len * XINT (length); |
1694 |
val = make_uninit_multibyte_string (XINT (length), nbytes); |
val = make_uninit_multibyte_string (XINT (length), nbytes); |
1695 |
p = XSTRING (val)->data; |
p = SDATA (val); |
1696 |
end = p + nbytes; |
end = p + nbytes; |
1697 |
while (p != end) |
while (p != end) |
1698 |
{ |
{ |
1700 |
p += len; |
p += len; |
1701 |
} |
} |
1702 |
} |
} |
1703 |
|
|
1704 |
*p = 0; |
*p = 0; |
1705 |
return val; |
return val; |
1706 |
} |
} |
1728 |
slot `size' of the struct Lisp_Bool_Vector. */ |
slot `size' of the struct Lisp_Bool_Vector. */ |
1729 |
val = Fmake_vector (make_number (length_in_elts + 1), Qnil); |
val = Fmake_vector (make_number (length_in_elts + 1), Qnil); |
1730 |
p = XBOOL_VECTOR (val); |
p = XBOOL_VECTOR (val); |
1731 |
|
|
1732 |
/* Get rid of any bits that would cause confusion. */ |
/* Get rid of any bits that would cause confusion. */ |
1733 |
p->vector_size = 0; |
p->vector_size = 0; |
1734 |
XSETBOOL_VECTOR (val, p); |
XSETBOOL_VECTOR (val, p); |
1735 |
p->size = XFASTINT (length); |
p->size = XFASTINT (length); |
1736 |
|
|
1737 |
real_init = (NILP (init) ? 0 : -1); |
real_init = (NILP (init) ? 0 : -1); |
1738 |
for (i = 0; i < length_in_chars ; i++) |
for (i = 0; i < length_in_chars ; i++) |
1739 |
p->data[i] = real_init; |
p->data[i] = real_init; |
1740 |
|
|
1741 |
/* Clear the extraneous bits in the last byte. */ |
/* Clear the extraneous bits in the last byte. */ |
1742 |
if (XINT (length) != length_in_chars * BITS_PER_CHAR) |
if (XINT (length) != length_in_chars * BITS_PER_CHAR) |
1743 |
XBOOL_VECTOR (val)->data[length_in_chars - 1] |
XBOOL_VECTOR (val)->data[length_in_chars - 1] |
1753 |
|
|
1754 |
Lisp_Object |
Lisp_Object |
1755 |
make_string (contents, nbytes) |
make_string (contents, nbytes) |
1756 |
char *contents; |
const char *contents; |
1757 |
int nbytes; |
int nbytes; |
1758 |
{ |
{ |
1759 |
register Lisp_Object val; |
register Lisp_Object val; |
1774 |
|
|
1775 |
Lisp_Object |
Lisp_Object |
1776 |
make_unibyte_string (contents, length) |
make_unibyte_string (contents, length) |
1777 |
char *contents; |
const char *contents; |
1778 |
int length; |
int length; |
1779 |
{ |
{ |
1780 |
register Lisp_Object val; |
register Lisp_Object val; |
1781 |
val = make_uninit_string (length); |
val = make_uninit_string (length); |
1782 |
bcopy (contents, XSTRING (val)->data, length); |
bcopy (contents, SDATA (val), length); |
1783 |
SET_STRING_BYTES (XSTRING (val), -1); |
STRING_SET_UNIBYTE (val); |
1784 |
return val; |
return val; |
1785 |
} |
} |
1786 |
|
|
1790 |
|
|
1791 |
Lisp_Object |
Lisp_Object |
1792 |
make_multibyte_string (contents, nchars, nbytes) |
make_multibyte_string (contents, nchars, nbytes) |
1793 |
char *contents; |
const char *contents; |
1794 |
int nchars, nbytes; |
int nchars, nbytes; |
1795 |
{ |
{ |
1796 |
register Lisp_Object val; |
register Lisp_Object val; |
1797 |
val = make_uninit_multibyte_string (nchars, nbytes); |
val = make_uninit_multibyte_string (nchars, nbytes); |
1798 |
bcopy (contents, XSTRING (val)->data, nbytes); |
bcopy (contents, SDATA (val), nbytes); |
1799 |
return val; |
return val; |
1800 |
} |
} |
1801 |
|
|
1805 |
|
|
1806 |
Lisp_Object |
Lisp_Object |
1807 |
make_string_from_bytes (contents, nchars, nbytes) |
make_string_from_bytes (contents, nchars, nbytes) |
1808 |
char *contents; |
const char *contents; |
1809 |
int nchars, nbytes; |
int nchars, nbytes; |
1810 |
{ |
{ |
1811 |
register Lisp_Object val; |
register Lisp_Object val; |
1812 |
val = make_uninit_multibyte_string (nchars, nbytes); |
val = make_uninit_multibyte_string (nchars, nbytes); |
1813 |
bcopy (contents, XSTRING (val)->data, nbytes); |
bcopy (contents, SDATA (val), nbytes); |
1814 |
if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size) |
if (SBYTES (val) == SCHARS (val)) |
1815 |
SET_STRING_BYTES (XSTRING (val), -1); |
STRING_SET_UNIBYTE (val); |
1816 |
return val; |
return val; |
1817 |
} |
} |
1818 |
|
|
1819 |
|
|
1820 |
/* Make a string from NCHARS characters occupying NBYTES bytes at |
/* Make a string from NCHARS characters occupying NBYTES bytes at |
1821 |
CONTENTS. The argument MULTIBYTE controls whether to label the |
CONTENTS. The argument MULTIBYTE controls whether to label the |
1822 |
string as multibyte. */ |
string as multibyte. If NCHARS is negative, it counts the number of |
1823 |
|
characters by itself. */ |
1824 |
|
|
1825 |
Lisp_Object |
Lisp_Object |
1826 |
make_specified_string (contents, nchars, nbytes, multibyte) |
make_specified_string (contents, nchars, nbytes, multibyte) |
1827 |
char *contents; |
const char *contents; |
1828 |
int nchars, nbytes; |
int nchars, nbytes; |
1829 |
int multibyte; |
int multibyte; |
1830 |
{ |
{ |
1831 |
register Lisp_Object val; |
register Lisp_Object val; |
1832 |
|
|
1833 |
|
if (nchars < 0) |
1834 |
|
{ |
1835 |
|
if (multibyte) |
1836 |
|
nchars = multibyte_chars_in_text (contents, nbytes); |
1837 |
|
else |
1838 |
|
nchars = nbytes; |
1839 |
|
} |
1840 |
val = make_uninit_multibyte_string (nchars, nbytes); |
val = make_uninit_multibyte_string (nchars, nbytes); |
1841 |
bcopy (contents, XSTRING (val)->data, nbytes); |
bcopy (contents, SDATA (val), nbytes); |
1842 |
if (!multibyte) |
if (!multibyte) |
1843 |
SET_STRING_BYTES (XSTRING (val), -1); |
STRING_SET_UNIBYTE (val); |
1844 |
return val; |
return val; |
1845 |
} |
} |
1846 |
|
|
1850 |
|
|
1851 |
Lisp_Object |
Lisp_Object |
1852 |
build_string (str) |
build_string (str) |
1853 |
char *str; |
const char *str; |
1854 |
{ |
{ |
1855 |
return make_string (str, strlen (str)); |
return make_string (str, strlen (str)); |
1856 |
} |
} |
1865 |
{ |
{ |
1866 |
Lisp_Object val; |
Lisp_Object val; |
1867 |
val = make_uninit_multibyte_string (length, length); |
val = make_uninit_multibyte_string (length, length); |
1868 |
SET_STRING_BYTES (XSTRING (val), -1); |
STRING_SET_UNIBYTE (val); |
1869 |
return val; |
return val; |
1870 |
} |
} |
1871 |
|
|
1991 |
} |
} |
1992 |
XSETFLOAT (val, &float_block->floats[float_block_index++]); |
XSETFLOAT (val, &float_block->floats[float_block_index++]); |
1993 |
} |
} |
1994 |
|
|
1995 |
XFLOAT_DATA (val) = float_value; |
XFLOAT_DATA (val) = float_value; |
1996 |
XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */ |
XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */ |
1997 |
consing_since_gc += sizeof (struct Lisp_Float); |
consing_since_gc += sizeof (struct Lisp_Float); |
2098 |
} |
} |
2099 |
XSETCONS (val, &cons_block->conses[cons_block_index++]); |
XSETCONS (val, &cons_block->conses[cons_block_index++]); |
2100 |
} |
} |
2101 |
|
|
2102 |
XSETCAR (val, car); |
XSETCAR (val, car); |
2103 |
XSETCDR (val, cdr); |
XSETCDR (val, cdr); |
2104 |
consing_since_gc += sizeof (struct Lisp_Cons); |
consing_since_gc += sizeof (struct Lisp_Cons); |
2183 |
{ |
{ |
2184 |
val = Fcons (init, val); |
val = Fcons (init, val); |
2185 |
--size; |
--size; |
2186 |
|
|
2187 |
if (size > 0) |
if (size > 0) |
2188 |
{ |
{ |
2189 |
val = Fcons (init, val); |
val = Fcons (init, val); |
2190 |
--size; |
--size; |
2191 |
|
|
2192 |
if (size > 0) |
if (size > 0) |
2193 |
{ |
{ |
2194 |
val = Fcons (init, val); |
val = Fcons (init, val); |
2195 |
--size; |
--size; |
2196 |
|
|
2197 |
if (size > 0) |
if (size > 0) |
2198 |
{ |
{ |
2199 |
val = Fcons (init, val); |
val = Fcons (init, val); |
2205 |
|
|
2206 |
QUIT; |
QUIT; |
2207 |
} |
} |
2208 |
|
|
2209 |
return val; |
return val; |
2210 |
} |
} |
2211 |
|
|
2241 |
a dumped Emacs. */ |
a dumped Emacs. */ |
2242 |
mallopt (M_MMAP_MAX, 0); |
mallopt (M_MMAP_MAX, 0); |
2243 |
#endif |
#endif |
2244 |
|
|
2245 |
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0]; |
nbytes = sizeof *p + (len - 1) * sizeof p->contents[0]; |
2246 |
p = (struct Lisp_Vector *) lisp_malloc (nbytes, type); |
p = (struct Lisp_Vector *) lisp_malloc (nbytes, type); |
2247 |
|
|
2248 |
#ifdef DOUG_LEA_MALLOC |
#ifdef DOUG_LEA_MALLOC |
2249 |
/* Back to a reasonable maximum of mmap'ed areas. */ |
/* Back to a reasonable maximum of mmap'ed areas. */ |
2250 |
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); |
mallopt (M_MMAP_MAX, MMAP_MAX_AREAS); |
2251 |
#endif |
#endif |
2252 |
|
|
2253 |
VALIDATE_LISP_STORAGE (p, 0); |
VALIDATE_LISP_STORAGE (p, 0); |
2254 |
consing_since_gc += nbytes; |
consing_since_gc += nbytes; |
2255 |
vector_cells_consed += len; |
vector_cells_consed += len; |
2281 |
EMACS_INT len = VECSIZE (struct Lisp_Hash_Table); |
EMACS_INT len = VECSIZE (struct Lisp_Hash_Table); |
2282 |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE); |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_HASH_TABLE); |
2283 |
EMACS_INT i; |
EMACS_INT i; |
2284 |
|
|
2285 |
v->size = len; |
v->size = len; |
2286 |
for (i = 0; i < len; ++i) |
for (i = 0; i < len; ++i) |
2287 |
v->contents[i] = Qnil; |
v->contents[i] = Qnil; |
2288 |
|
|
2289 |
return (struct Lisp_Hash_Table *) v; |
return (struct Lisp_Hash_Table *) v; |
2290 |
} |
} |
2291 |
|
|
2296 |
EMACS_INT len = VECSIZE (struct window); |
EMACS_INT len = VECSIZE (struct window); |
2297 |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW); |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_WINDOW); |
2298 |
EMACS_INT i; |
EMACS_INT i; |
2299 |
|
|
2300 |
for (i = 0; i < len; ++i) |
for (i = 0; i < len; ++i) |
2301 |
v->contents[i] = Qnil; |
v->contents[i] = Qnil; |
2302 |
v->size = len; |
v->size = len; |
2303 |
|
|
2304 |
return (struct window *) v; |
return (struct window *) v; |
2305 |
} |
} |
2306 |
|
|
2311 |
EMACS_INT len = VECSIZE (struct frame); |
EMACS_INT len = VECSIZE (struct frame); |
2312 |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME); |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_FRAME); |
2313 |
EMACS_INT i; |
EMACS_INT i; |
2314 |
|
|
2315 |
for (i = 0; i < len; ++i) |
for (i = 0; i < len; ++i) |
2316 |
v->contents[i] = make_number (0); |
v->contents[i] = make_number (0); |
2317 |
v->size = len; |
v->size = len; |
2325 |
EMACS_INT len = VECSIZE (struct Lisp_Process); |
EMACS_INT len = VECSIZE (struct Lisp_Process); |
2326 |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS); |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_PROCESS); |
2327 |
EMACS_INT i; |
EMACS_INT i; |
2328 |
|
|
2329 |
for (i = 0; i < len; ++i) |
for (i = 0; i < len; ++i) |
2330 |
v->contents[i] = Qnil; |
v->contents[i] = Qnil; |
2331 |
v->size = len; |
v->size = len; |
2332 |
|
|
2333 |
return (struct Lisp_Process *) v; |
return (struct Lisp_Process *) v; |
2334 |
} |
} |
2335 |
|
|
2340 |
{ |
{ |
2341 |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR); |
struct Lisp_Vector *v = allocate_vectorlike (len, MEM_TYPE_VECTOR); |
2342 |
EMACS_INT i; |
EMACS_INT i; |
2343 |
|
|
2344 |
for (i = 0; i < len; ++i) |
for (i = 0; i < len; ++i) |
2345 |
v->contents[i] = Qnil; |
v->contents[i] = Qnil; |
2346 |
v->size = len; |
v->size = len; |
2347 |
|
|
2348 |
return v; |
return v; |
2349 |
} |
} |
2350 |
|
|
2556 |
} |
} |
2557 |
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]); |
XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index++]); |
2558 |
} |
} |
2559 |
|
|
2560 |
p = XSYMBOL (val); |
p = XSYMBOL (val); |
2561 |
p->xname = name; |
p->xname = name; |
2562 |
p->plist = Qnil; |
p->plist = Qnil; |
2638 |
} |
} |
2639 |
XSETMISC (val, &marker_block->markers[marker_block_index++]); |
XSETMISC (val, &marker_block->markers[marker_block_index++]); |
2640 |
} |
} |
2641 |
|
|
2642 |
consing_since_gc += sizeof (union Lisp_Misc); |
consing_since_gc += sizeof (union Lisp_Misc); |
2643 |
misc_objects_consed++; |
misc_objects_consed++; |
2644 |
return val; |
return val; |
2645 |
} |
} |
2646 |
|
|
2647 |
|
/* Return a Lisp_Misc_Save_Value object containing POINTER and |
2648 |
|
INTEGER. This is used to package C values to call record_unwind_protect. |
2649 |
|
The unwind function can get the C values back using XSAVE_VALUE. */ |
2650 |
|
|
2651 |
|
Lisp_Object |
2652 |
|
make_save_value (pointer, integer) |
2653 |
|
void *pointer; |
2654 |
|
int integer; |
2655 |
|
{ |
2656 |
|
register Lisp_Object val; |
2657 |
|
register struct Lisp_Save_Value *p; |
2658 |
|
|
2659 |
|
val = allocate_misc (); |
2660 |
|
XMISCTYPE (val) = Lisp_Misc_Save_Value; |
2661 |
|
p = XSAVE_VALUE (val); |
2662 |
|
p->pointer = pointer; |
2663 |
|
p->integer = integer; |
2664 |
|
return val; |
2665 |
|
} |
2666 |
|
|
2667 |
DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, |
DEFUN ("make-marker", Fmake_marker, Smake_marker, 0, 0, 0, |
2668 |
doc: /* Return a newly allocated marker which does not point at any place. */) |
doc: /* Return a newly allocated marker which does not point at any place. */) |
2669 |
() |
() |
2723 |
characters, so we can make a string. */ |
characters, so we can make a string. */ |
2724 |
{ |
{ |
2725 |
Lisp_Object result; |
Lisp_Object result; |
2726 |
|
|
2727 |
result = Fmake_string (make_number (nargs), make_number (0)); |
result = Fmake_string (make_number (nargs), make_number (0)); |
2728 |
for (i = 0; i < nargs; i++) |
for (i = 0; i < nargs; i++) |
2729 |
{ |
{ |
2730 |
XSTRING (result)->data[i] = XINT (args[i]); |
SSET (result, i, XINT (args[i])); |
2731 |
/* Move the meta bit to the right place for a string char. */ |
/* Move the meta bit to the right place for a string char. */ |
2732 |
if (XINT (args[i]) & CHAR_META) |
if (XINT (args[i]) & CHAR_META) |
2733 |
XSTRING (result)->data[i] |= 0x80; |
SSET (result, i, SREF (result, i) | 0x80); |
2734 |
} |
} |
2735 |
|
|
2736 |
return result; |
return result; |
2737 |
} |
} |
2738 |
} |
} |
2815 |
parent = NULL; |
parent = NULL; |
2816 |
|
|
2817 |
#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS |
#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS |
2818 |
|
|
2819 |
while (c != MEM_NIL) |
while (c != MEM_NIL) |
2820 |
{ |
{ |
2821 |
if (start >= c->start && start < c->end) |
if (start >= c->start && start < c->end) |
2823 |
parent = c; |
parent = c; |
2824 |
c = start < c->start ? c->left : c->right; |
c = start < c->start ? c->left : c->right; |
2825 |
} |
} |
2826 |
|
|
2827 |
#else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */ |
#else /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */ |
2828 |
|
|
2829 |
while (c != MEM_NIL) |
while (c != MEM_NIL) |
2830 |
{ |
{ |
2831 |
parent = c; |
parent = c; |
2832 |
c = start < c->start ? c->left : c->right; |
c = start < c->start ? c->left : c->right; |
2833 |
} |
} |
2834 |
|
|
2835 |
#endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */ |
#endif /* GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS */ |
2836 |
|
|
2837 |
/* Create a new node. */ |
/* Create a new node. */ |
2857 |
else |
else |
2858 |
parent->right = x; |
parent->right = x; |
2859 |
} |
} |
2860 |
else |
else |
2861 |
mem_root = x; |
mem_root = x; |
2862 |
|
|
2863 |
/* Re-establish red-black tree properties. */ |
/* Re-establish red-black tree properties. */ |
2878 |
{ |
{ |
2879 |
/* X is red and its parent is red. This is a violation of |
/* X is red and its parent is red. This is a violation of |
2880 |
red-black tree property #3. */ |
red-black tree property #3. */ |
2881 |
|
|
2882 |
if (x->parent == x->parent->parent->left) |
if (x->parent == x->parent->parent->left) |
2883 |
{ |
{ |
2884 |
/* We're on the left side of our grandparent, and Y is our |
/* We're on the left side of our grandparent, and Y is our |
2885 |
"uncle". */ |
"uncle". */ |
2886 |
struct mem_node *y = x->parent->parent->right; |
struct mem_node *y = x->parent->parent->right; |
2887 |
|
|
2888 |
if (y->color == MEM_RED) |
if (y->color == MEM_RED) |
2889 |
{ |
{ |
2890 |
/* Uncle and parent are red but should be black because |
/* Uncle and parent are red but should be black because |
2914 |
{ |
{ |
2915 |
/* This is the symmetrical case of above. */ |
/* This is the symmetrical case of above. */ |
2916 |
struct mem_node *y = x->parent->parent->left; |
struct mem_node *y = x->parent->parent->left; |
2917 |
|
|
2918 |
if (y->color == MEM_RED) |
if (y->color == MEM_RED) |
2919 |
{ |
{ |
2920 |
x->parent->color = MEM_BLACK; |
x->parent->color = MEM_BLACK; |
2929 |
x = x->parent; |
x = x->parent; |
2930 |
mem_rotate_right (x); |
mem_rotate_right (x); |
2931 |
} |
} |
2932 |
|
|
2933 |
x->parent->color = MEM_BLACK; |
x->parent->color = MEM_BLACK; |
2934 |
x->parent->parent->color = MEM_RED; |
x->parent->parent->color = MEM_RED; |
2935 |
mem_rotate_left (x->parent->parent); |
mem_rotate_left (x->parent->parent); |
2943 |
} |
} |
2944 |
|
|
2945 |
|
|
2946 |
/* (x) (y) |
/* (x) (y) |
2947 |
/ \ / \ |
/ \ / \ |
2948 |
a (y) ===> (x) c |
a (y) ===> (x) c |
2949 |
/ \ / \ |
/ \ / \ |
2950 |
b c a b */ |
b c a b */ |
2983 |
} |
} |
2984 |
|
|
2985 |
|
|
2986 |
/* (x) (Y) |
/* (x) (Y) |
2987 |
/ \ / \ |
/ \ / \ |
2988 |
(y) c ===> a (x) |
(y) c ===> a (x) |
2989 |
/ \ / \ |
/ \ / \ |
2990 |
a b b c */ |
a b b c */ |
2991 |
|
|
2992 |
static void |
static void |
2998 |
x->left = y->right; |
x->left = y->right; |
2999 |
if (y->right != MEM_NIL) |
if (y->right != MEM_NIL) |
3000 |
y->right->parent = x; |
y->right->parent = x; |
3001 |
|
|
3002 |
if (y != MEM_NIL) |
if (y != MEM_NIL) |
3003 |
y->parent = x->parent; |
y->parent = x->parent; |
3004 |
if (x->parent) |
if (x->parent) |
3010 |
} |
} |
3011 |
else |
else |
3012 |
mem_root = y; |
mem_root = y; |
3013 |
|
|
3014 |
y->right = x; |
y->right = x; |
3015 |
if (x != MEM_NIL) |
if (x != MEM_NIL) |
3016 |
x->parent = y; |
x->parent = y; |
3059 |
z->end = y->end; |
z->end = y->end; |
3060 |
z->type = y->type; |
z->type = y->type; |
3061 |
} |
} |
3062 |
|
|
3063 |
if (y->color == MEM_BLACK) |
if (y->color == MEM_BLACK) |
3064 |
mem_delete_fixup (x); |
mem_delete_fixup (x); |
3065 |
|
|
3083 |
if (x == x->parent->left) |
if (x == x->parent->left) |
3084 |
{ |
{ |
3085 |
struct mem_node *w = x->parent->right; |
struct mem_node *w = x->parent->right; |
3086 |
|
|
3087 |
if (w->color == MEM_RED) |
if (w->color == MEM_RED) |
3088 |
{ |
{ |
3089 |
w->color = MEM_BLACK; |
w->color = MEM_BLACK; |
3091 |
mem_rotate_left (x->parent); |
mem_rotate_left (x->parent); |
3092 |
w = x->parent->right; |
w = x->parent->right; |
3093 |
} |
} |
3094 |
|
|
3095 |
if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK) |
if (w->left->color == MEM_BLACK && w->right->color == MEM_BLACK) |
3096 |
{ |
{ |
3097 |
w->color = MEM_RED; |
w->color = MEM_RED; |
3116 |
else |
else |
3117 |
{ |
{ |
3118 |
struct mem_node *w = x->parent->left; |
struct mem_node *w = x->parent->left; |
3119 |
|
|
3120 |
if (w->color == MEM_RED) |
if (w->color == MEM_RED) |
3121 |
{ |
{ |
3122 |
w->color = MEM_BLACK; |
w->color = MEM_BLACK; |
3124 |
mem_rotate_right (x->parent); |
mem_rotate_right (x->parent); |
3125 |
w = x->parent->left; |
w = x->parent->left; |
3126 |
} |
} |
3127 |
|
|
3128 |
if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK) |
if (w->right->color == MEM_BLACK && w->left->color == MEM_BLACK) |
3129 |
{ |
{ |
3130 |
w->color = MEM_RED; |
w->color = MEM_RED; |
3139 |
mem_rotate_left (w); |
mem_rotate_left (w); |
3140 |
w = x->parent->left; |
w = x->parent->left; |
3141 |
} |
} |
3142 |
|
|
3143 |
w->color = x->parent->color; |
w->color = x->parent->color; |
3144 |
x->parent->color = MEM_BLACK; |
x->parent->color = MEM_BLACK; |
3145 |
w->left->color = MEM_BLACK; |
w->left->color = MEM_BLACK; |
3148 |
} |
} |
3149 |
} |
} |
3150 |
} |
} |
3151 |
|
|
3152 |
x->color = MEM_BLACK; |
x->color = MEM_BLACK; |
3153 |
} |
} |
3154 |
|
|
3216 |
{ |
{ |
3217 |
struct symbol_block *b = (struct symbol_block *) m->start; |
struct symbol_block *b = (struct symbol_block *) m->start; |
3218 |
int offset = (char *) p - (char *) &b->symbols[0]; |
int offset = (char *) p - (char *) &b->symbols[0]; |
3219 |
|
|
3220 |
/* P must point to the start of a Lisp_Symbol, not be |
/* P must point to the start of a Lisp_Symbol, not be |
3221 |
one of the unused cells in the current symbol block, |
one of the unused cells in the current symbol block, |
3222 |
and not be on the free-list. */ |
and not be on the free-list. */ |
3243 |
{ |
{ |
3244 |
struct float_block *b = (struct float_block *) m->start; |
struct float_block *b = (struct float_block *) m->start; |
3245 |
int offset = (char *) p - (char *) &b->floats[0]; |
int offset = (char *) p - (char *) &b->floats[0]; |
3246 |
|
|
3247 |
/* P must point to the start of a Lisp_Float, not be |
/* P must point to the start of a Lisp_Float, not be |
3248 |
one of the unused cells in the current float block, |
one of the unused cells in the current float block, |
3249 |
and not be on the free-list. */ |
and not be on the free-list. */ |
3270 |
{ |
{ |
3271 |
struct marker_block *b = (struct marker_block *) m->start; |
struct marker_block *b = (struct marker_block *) m->start; |
3272 |
int offset = (char *) p - (char *) &b->markers[0]; |
int offset = (char *) p - (char *) &b->markers[0]; |
3273 |
|
|
3274 |
/* P must point to the start of a Lisp_Misc, not be |
/* P must point to the start of a Lisp_Misc, not be |
3275 |
one of the unused cells in the current misc block, |
one of the unused cells in the current misc block, |
3276 |
and not be on the free-list. */ |
and not be on the free-list. */ |
3350 |
doc: /* Show information about live and zombie objects. */) |
doc: /* Show information about live and zombie objects. */) |
3351 |
() |
() |
3352 |
{ |
{ |
3353 |
Lisp_Object args[7]; |
Lisp_Object args[8], zombie_list = Qnil; |
3354 |
args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d"); |
int i; |
3355 |
|
for (i = 0; i < nzombies; i++) |
3356 |
|
zombie_list = Fcons (zombies[i], zombie_list); |
3357 |
|
args[0] = build_string ("%d GCs, avg live/zombies = %.2f/%.2f (%f%%), max %d/%d\nzombies: %S"); |
3358 |
args[1] = make_number (ngcs); |
args[1] = make_number (ngcs); |
3359 |
args[2] = make_float (avg_live); |
args[2] = make_float (avg_live); |
3360 |
args[3] = make_float (avg_zombies); |
args[3] = make_float (avg_zombies); |
3361 |
args[4] = make_float (avg_zombies / avg_live / 100); |
args[4] = make_float (avg_zombies / avg_live / 100); |
3362 |
args[5] = make_number (max_live); |
args[5] = make_number (max_live); |
3363 |
args[6] = make_number (max_zombies); |
args[6] = make_number (max_zombies); |
3364 |
return Fmessage (7, args); |
args[7] = zombie_list; |
3365 |
|
return Fmessage (8, args); |
3366 |
} |
} |
3367 |
|
|
3368 |
#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */ |
#endif /* GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES */ |
3376 |
{ |
{ |
3377 |
void *po = (void *) XPNTR (obj); |
void *po = (void *) XPNTR (obj); |
3378 |
struct mem_node *m = mem_find (po); |
struct mem_node *m = mem_find (po); |
3379 |
|
|
3380 |
if (m != MEM_NIL) |
if (m != MEM_NIL) |
3381 |
{ |
{ |
3382 |
int mark_p = 0; |
int mark_p = 0; |
3422 |
case Lisp_Misc_Marker: |
case Lisp_Misc_Marker: |
3423 |
mark_p = !XMARKBIT (XMARKER (obj)->chain); |
mark_p = !XMARKBIT (XMARKER (obj)->chain); |
3424 |
break; |
break; |
3425 |
|
|
3426 |
case Lisp_Misc_Buffer_Local_Value: |
case Lisp_Misc_Buffer_Local_Value: |
3427 |
case Lisp_Misc_Some_Buffer_Local_Value: |
case Lisp_Misc_Some_Buffer_Local_Value: |
3428 |
mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue); |
mark_p = !XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue); |
3429 |
break; |
break; |
3430 |
|
|
3431 |
case Lisp_Misc_Overlay: |
case Lisp_Misc_Overlay: |
3432 |
mark_p = !XMARKBIT (XOVERLAY (obj)->plist); |
mark_p = !XMARKBIT (XOVERLAY (obj)->plist); |
3433 |
break; |
break; |
3444 |
{ |
{ |
3445 |
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES |
#if GC_MARK_STACK == GC_USE_GCPROS_CHECK_ZOMBIES |
3446 |
if (nzombies < MAX_ZOMBIES) |
if (nzombies < MAX_ZOMBIES) |
3447 |
zombies[nzombies] = *p; |
zombies[nzombies] = obj; |
3448 |
++nzombies; |
++nzombies; |
3449 |
#endif |
#endif |
3450 |
mark_object (&obj); |
mark_object (&obj); |
3466 |
assume that Lisp data is aligned on even addresses. */ |
assume that Lisp data is aligned on even addresses. */ |
3467 |
if ((EMACS_INT) p & 1) |
if ((EMACS_INT) p & 1) |
3468 |
return; |
return; |
3469 |
|
|
3470 |
m = mem_find (p); |
m = mem_find (p); |
3471 |
if (m != MEM_NIL) |
if (m != MEM_NIL) |
3472 |
{ |
{ |
3473 |
Lisp_Object obj = Qnil; |
Lisp_Object obj = Qnil; |
3474 |
|
|
3475 |
switch (m->type) |
switch (m->type) |
3476 |
{ |
{ |
3477 |
case MEM_TYPE_NON_LISP: |
case MEM_TYPE_NON_LISP: |
3478 |
/* Nothing to do; not a pointer to Lisp memory. */ |
/* Nothing to do; not a pointer to Lisp memory. */ |
3479 |
break; |
break; |
3480 |
|
|
3481 |
case MEM_TYPE_BUFFER: |
case MEM_TYPE_BUFFER: |
3482 |
if (live_buffer_p (m, p) |
if (live_buffer_p (m, p) |
3483 |
&& !XMARKBIT (((struct buffer *) p)->name)) |
&& !XMARKBIT (((struct buffer *) p)->name)) |
3484 |
XSETVECTOR (obj, p); |
XSETVECTOR (obj, p); |
3485 |
break; |
break; |
3486 |
|
|
3487 |
case MEM_TYPE_CONS: |
case MEM_TYPE_CONS: |
3488 |
if (live_cons_p (m, p) |
if (live_cons_p (m, p) |
3489 |
&& !XMARKBIT (((struct Lisp_Cons *) p)->car)) |
&& !XMARKBIT (((struct Lisp_Cons *) p)->car)) |
3490 |
XSETCONS (obj, p); |
XSETCONS (obj, p); |
3491 |
break; |
break; |
3492 |
|
|
3493 |
case MEM_TYPE_STRING: |
case MEM_TYPE_STRING: |
3494 |
if (live_string_p (m, p) |
if (live_string_p (m, p) |
3495 |
&& !STRING_MARKED_P ((struct Lisp_String *) p)) |
&& !STRING_MARKED_P ((struct Lisp_String *) p)) |
3501 |
{ |
{ |
3502 |
Lisp_Object tem; |
Lisp_Object tem; |
3503 |
XSETMISC (tem, p); |
XSETMISC (tem, p); |
3504 |
|
|
3505 |
switch (XMISCTYPE (tem)) |
switch (XMISCTYPE (tem)) |
3506 |
{ |
{ |
3507 |
case Lisp_Misc_Marker: |
case Lisp_Misc_Marker: |
3508 |
if (!XMARKBIT (XMARKER (tem)->chain)) |
if (!XMARKBIT (XMARKER (tem)->chain)) |
3509 |
obj = tem; |
obj = tem; |
3510 |
break; |
break; |
3511 |
|
|
3512 |
case Lisp_Misc_Buffer_Local_Value: |
case Lisp_Misc_Buffer_Local_Value: |
3513 |
case Lisp_Misc_Some_Buffer_Local_Value: |
case Lisp_Misc_Some_Buffer_Local_Value: |
3514 |
if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue)) |
if (!XMARKBIT (XBUFFER_LOCAL_VALUE (tem)->realvalue)) |
3515 |
obj = tem; |
obj = tem; |
3516 |
break; |
break; |
3517 |
|
|
3518 |
case Lisp_Misc_Overlay: |
case Lisp_Misc_Overlay: |
3519 |
if (!XMARKBIT (XOVERLAY (tem)->plist)) |
if (!XMARKBIT (XOVERLAY (tem)->plist)) |
3520 |
obj = tem; |
obj = tem; |
3522 |
} |
} |
3523 |
} |
} |
3524 |
break; |
break; |
3525 |
|
|
3526 |
case MEM_TYPE_SYMBOL: |
case MEM_TYPE_SYMBOL: |
3527 |
if (live_symbol_p (m, p) |
if (live_symbol_p (m, p) |
3528 |
&& !XMARKBIT (((struct Lisp_Symbol *) p)->plist)) |
&& !XMARKBIT (((struct Lisp_Symbol *) p)->plist)) |
3529 |
XSETSYMBOL (obj, p); |
XSETSYMBOL (obj, p); |
3530 |
break; |
break; |
3531 |
|
|
3532 |
case MEM_TYPE_FLOAT: |
case MEM_TYPE_FLOAT: |
3533 |
if (live_float_p (m, p) |
if (live_float_p (m, p) |
3534 |
&& !XMARKBIT (((struct Lisp_Float *) p)->type)) |
&& !XMARKBIT (((struct Lisp_Float *) p)->type)) |
3535 |
XSETFLOAT (obj, p); |
XSETFLOAT (obj, p); |
3536 |
break; |
break; |
3537 |
|
|
3538 |
case MEM_TYPE_VECTOR: |
case MEM_TYPE_VECTOR: |
3539 |
case MEM_TYPE_PROCESS: |
case MEM_TYPE_PROCESS: |
3540 |
case MEM_TYPE_HASH_TABLE: |
case MEM_TYPE_HASH_TABLE: |
3562 |
|
|
3563 |
/* Mark Lisp objects referenced from the address range START..END. */ |
/* Mark Lisp objects referenced from the address range START..END. */ |
3564 |
|
|
3565 |
static void |
static void |
3566 |
mark_memory (start, end) |
mark_memory (start, end) |
3567 |
void *start, *end; |
void *start, *end; |
3568 |
{ |
{ |
3603 |
Here, `obj' isn't really used, and the compiler optimizes it |
Here, `obj' isn't really used, and the compiler optimizes it |
3604 |
away. The only reference to the life string is through the |
away. The only reference to the life string is through the |
3605 |
pointer `s'. */ |
pointer `s'. */ |
3606 |
|
|
3607 |
for (pp = (void **) start; (void *) pp < end; ++pp) |
for (pp = (void **) start; (void *) pp < end; ++pp) |
3608 |
mark_maybe_pointer (*pp); |
mark_maybe_pointer (*pp); |
3609 |
} |
} |
3610 |
|
|
3611 |
|
/* setjmp will work with GCC unless NON_SAVING_SETJMP is defined in |
3612 |
|
the GCC system configuration. In gcc 3.2, the only systems for |
3613 |
|
which this is so are i386-sco5 non-ELF, i386-sysv3 (maybe included |
3614 |
|
by others?) and ns32k-pc532-min. */ |
3615 |
|
|
3616 |
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS |
#if !defined GC_SAVE_REGISTERS_ON_STACK && !defined GC_SETJMP_WORKS |
3617 |
|
|
3639 |
\n\ |
\n\ |
3640 |
Please take a look at the function mark_stack in alloc.c, and\n\ |
Please take a look at the function mark_stack in alloc.c, and\n\ |
3641 |
try to find a way to make it work on your system.\n\ |
try to find a way to make it work on your system.\n\ |
3642 |
|
\n\ |
3643 |
|
Note that you may get false negatives, depending on the compiler.\n\ |
3644 |
|
In particular, you need to use -O with GCC for this test.\n\ |
3645 |
|
\n\ |
3646 |
Please mail the result to <emacs-devel@gnu.org>.\n\ |
Please mail the result to <emacs-devel@gnu.org>.\n\ |
3647 |
" |
" |
3648 |
|
|
3787 |
|
|
3788 |
/* This trick flushes the register windows so that all the state of |
/* This trick flushes the register windows so that all the state of |
3789 |
the process is contained in the stack. */ |
the process is contained in the stack. */ |
3790 |
|
/* Fixme: Code in the Boehm GC sugests flushing (with `flushrs') is |
3791 |
|
needed on ia64 too. See mach_dep.c, where it also says inline |
3792 |
|
assembler doesn't work with relevant proprietary compilers. */ |
3793 |
#ifdef sparc |
#ifdef sparc |
3794 |
asm ("ta 3"); |
asm ("ta 3"); |
3795 |
#endif |
#endif |
3796 |
|
|
3797 |
/* Save registers that we need to see on the stack. We need to see |
/* Save registers that we need to see on the stack. We need to see |
3798 |
registers used to hold register variables and registers used to |
registers used to hold register variables and registers used to |
3799 |
pass parameters. */ |
pass parameters. */ |
3800 |
#ifdef GC_SAVE_REGISTERS_ON_STACK |
#ifdef GC_SAVE_REGISTERS_ON_STACK |
3801 |
GC_SAVE_REGISTERS_ON_STACK (end); |
GC_SAVE_REGISTERS_ON_STACK (end); |
3802 |
#else /* not GC_SAVE_REGISTERS_ON_STACK */ |
#else /* not GC_SAVE_REGISTERS_ON_STACK */ |
3803 |
|
|
3804 |
#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that |
#ifndef GC_SETJMP_WORKS /* If it hasn't been checked yet that |
3805 |
setjmp will definitely work, test it |
setjmp will definitely work, test it |
3806 |
and print a message with the result |
and print a message with the result |
3811 |
test_setjmp (); |
test_setjmp (); |
3812 |
} |
} |
3813 |
#endif /* GC_SETJMP_WORKS */ |
#endif /* GC_SETJMP_WORKS */ |
3814 |
|
|
3815 |
setjmp (j); |
setjmp (j); |
3816 |
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; |
end = stack_grows_down_p ? (char *) &j + sizeof j : (char *) &j; |
3817 |
#endif /* not GC_SAVE_REGISTERS_ON_STACK */ |
#endif /* not GC_SAVE_REGISTERS_ON_STACK */ |
3820 |
that's not the case, something has to be done here to iterate |
that's not the case, something has to be done here to iterate |
3821 |
over the stack segments. */ |
over the stack segments. */ |
3822 |
#ifndef GC_LISP_OBJECT_ALIGNMENT |
#ifndef GC_LISP_OBJECT_ALIGNMENT |
3823 |
|
#ifdef __GNUC__ |
3824 |
|
#define GC_LISP_OBJECT_ALIGNMENT __alignof__ (Lisp_Object) |
3825 |
|
#else |
3826 |
#define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object) |
#define GC_LISP_OBJECT_ALIGNMENT sizeof (Lisp_Object) |
3827 |
#endif |
#endif |
3828 |
|
#endif |
3829 |
for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT) |
for (i = 0; i < sizeof (Lisp_Object); i += GC_LISP_OBJECT_ALIGNMENT) |
3830 |
mark_memory ((char *) stack_base + i, end); |
mark_memory ((char *) stack_base + i, end); |
3831 |
|
|
3855 |
size_t size; |
size_t size; |
3856 |
int type; |
int type; |
3857 |
{ |
{ |
|
size_t nbytes; |
|
3858 |
POINTER_TYPE *result; |
POINTER_TYPE *result; |
3859 |
char *beg = purebeg; |
size_t alignment = sizeof (EMACS_INT); |
3860 |
|
|
3861 |
/* Give Lisp_Floats an extra alignment. */ |
/* Give Lisp_Floats an extra alignment. */ |
3862 |
if (type == Lisp_Float) |
if (type == Lisp_Float) |
3863 |
{ |
{ |
|
size_t alignment; |
|
3864 |
#if defined __GNUC__ && __GNUC__ >= 2 |
#if defined __GNUC__ && __GNUC__ >= 2 |
3865 |
alignment = __alignof (struct Lisp_Float); |
alignment = __alignof (struct Lisp_Float); |
3866 |
#else |
#else |
3867 |
alignment = sizeof (struct Lisp_Float); |
alignment = sizeof (struct Lisp_Float); |
3868 |
#endif |
#endif |
|
pure_bytes_used = ALIGN (pure_bytes_used, alignment); |
|
3869 |
} |
} |
3870 |
|
|
3871 |
nbytes = ALIGN (size, sizeof (EMACS_INT)); |
again: |
3872 |
|
result = (POINTER_TYPE *) ALIGN ((EMACS_UINT)purebeg + pure_bytes_used, alignment); |
3873 |
if (pure_bytes_used + nbytes > pure_size) |
pure_bytes_used = ((char *)result - (char *)purebeg) + size; |
3874 |
{ |
|
3875 |
/* Don't allocate a large amount here, |
if (pure_bytes_used <= pure_size) |
3876 |
because it might get mmap'd and then its address |
return result; |
3877 |
might not be usable. */ |
|
3878 |
beg = purebeg = (char *) xmalloc (10000); |
/* Don't allocate a large amount here, |
3879 |
pure_size = 10000; |
because it might get mmap'd and then its address |
3880 |
pure_bytes_used_before_overflow += pure_bytes_used; |
might not be usable. */ |
3881 |
pure_bytes_used = 0; |
purebeg = (char *) xmalloc (10000); |
3882 |
} |
pure_size = 10000; |
3883 |
|
pure_bytes_used_before_overflow += pure_bytes_used - size; |
3884 |
result = (POINTER_TYPE *) (beg + pure_bytes_used); |
pure_bytes_used = 0; |
3885 |
pure_bytes_used += nbytes; |
goto again; |
|
return result; |
|
3886 |
} |
} |
3887 |
|
|
3888 |
|
|
3996 |
else if (FLOATP (obj)) |
else if (FLOATP (obj)) |
3997 |
return make_pure_float (XFLOAT_DATA (obj)); |
return make_pure_float (XFLOAT_DATA (obj)); |
3998 |
else if (STRINGP (obj)) |
else if (STRINGP (obj)) |
3999 |
return make_pure_string (XSTRING (obj)->data, XSTRING (obj)->size, |
return make_pure_string (SDATA (obj), SCHARS (obj), |
4000 |
STRING_BYTES (XSTRING (obj)), |
SBYTES (obj), |
4001 |
STRING_MULTIBYTE (obj)); |
STRING_MULTIBYTE (obj)); |
4002 |
else if (COMPILEDP (obj) || VECTORP (obj)) |
else if (COMPILEDP (obj) || VECTORP (obj)) |
4003 |
{ |
{ |
4069 |
int |
int |
4070 |
inhibit_garbage_collection () |
inhibit_garbage_collection () |
4071 |
{ |
{ |
4072 |
int count = specpdl_ptr - specpdl; |
int count = SPECPDL_INDEX (); |
4073 |
int nbits = min (VALBITS, BITS_PER_INT); |
int nbits = min (VALBITS, BITS_PER_INT); |
4074 |
|
|
4075 |
specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1)); |
specbind (Qgc_cons_threshold, make_number (((EMACS_INT) 1 << (nbits - 1)) - 1)); |
4097 |
register int i; |
register int i; |
4098 |
int message_p; |
int message_p; |
4099 |
Lisp_Object total[8]; |
Lisp_Object total[8]; |
4100 |
int count = BINDING_STACK_SIZE (); |
int count = SPECPDL_INDEX (); |
4101 |
|
EMACS_TIME t1, t2, t3; |
4102 |
|
|
4103 |
|
EMACS_GET_TIME (t1); |
4104 |
|
|
4105 |
/* Can't GC if pure storage overflowed because we can't determine |
/* Can't GC if pure storage overflowed because we can't determine |
4106 |
if something is a pure object or not. */ |
if something is a pure object or not. */ |
4113 |
|
|
4114 |
/* Save what's currently displayed in the echo area. */ |
/* Save what's currently displayed in the echo area. */ |
4115 |
message_p = push_message (); |
message_p = push_message (); |
4116 |
record_unwind_protect (push_message_unwind, Qnil); |
record_unwind_protect (pop_message_unwind, Qnil); |
4117 |
|
|
4118 |
/* Save a copy of the contents of the stack, for debugging. */ |
/* Save a copy of the contents of the stack, for debugging. */ |
4119 |
#if MAX_SAVE_STACK > 0 |
#if MAX_SAVE_STACK > 0 |
4156 |
Qt tends to return NULL, which effectively turns undo back on. |
Qt tends to return NULL, which effectively turns undo back on. |
4157 |
So don't call truncate_undo_list if undo_list is Qt. */ |
So don't call truncate_undo_list if undo_list is Qt. */ |
4158 |
if (! EQ (nextb->undo_list, Qt)) |
if (! EQ (nextb->undo_list, Qt)) |
4159 |
nextb->undo_list |
nextb->undo_list |
4160 |
= truncate_undo_list (nextb->undo_list, undo_limit, |
= truncate_undo_list (nextb->undo_list, undo_limit, |
4161 |
undo_strong_limit); |
undo_strong_limit); |
4162 |
|
|
4209 |
XMARK (tail->var[i]); |
XMARK (tail->var[i]); |
4210 |
} |
} |
4211 |
#endif |
#endif |
4212 |
|
|
4213 |
mark_byte_stack (); |
mark_byte_stack (); |
4214 |
for (bind = specpdl; bind != specpdl_ptr; bind++) |
for (bind = specpdl; bind != specpdl_ptr; bind++) |
4215 |
{ |
{ |
4220 |
{ |
{ |
4221 |
mark_object (&catch->tag); |
mark_object (&catch->tag); |
4222 |
mark_object (&catch->val); |
mark_object (&catch->val); |
4223 |
} |
} |
4224 |
for (handler = handlerlist; handler; handler = handler->next) |
for (handler = handlerlist; handler; handler = handler->next) |
4225 |
{ |
{ |
4226 |
mark_object (&handler->handler); |
mark_object (&handler->handler); |
4227 |
mark_object (&handler->var); |
mark_object (&handler->var); |
4228 |
} |
} |
4229 |
for (backlist = backtrace_list; backlist; backlist = backlist->next) |
for (backlist = backtrace_list; backlist; backlist = backlist->next) |
4230 |
{ |
{ |
4231 |
if (!XMARKBIT (*backlist->function)) |
if (!XMARKBIT (*backlist->function)) |
4243 |
mark_object (&backlist->args[i]); |
mark_object (&backlist->args[i]); |
4244 |
XMARK (backlist->args[i]); |
XMARK (backlist->args[i]); |
4245 |
} |
} |
4246 |
} |
} |
4247 |
mark_kboards (); |
mark_kboards (); |
4248 |
|
|
4249 |
/* Look thru every buffer's undo list |
/* Look thru every buffer's undo list |
4293 |
mark_stack (); |
mark_stack (); |
4294 |
#endif |
#endif |
4295 |
|
|
4296 |
|
#ifdef USE_GTK |
4297 |
|
{ |
4298 |
|
extern void xg_mark_data (); |
4299 |
|
xg_mark_data (); |
4300 |
|
} |
4301 |
|
#endif |
4302 |
|
|
4303 |
gc_sweep (); |
gc_sweep (); |
4304 |
|
|
4305 |
/* Clear the mark bits that we set in certain root slots. */ |
/* Clear the mark bits that we set in certain root slots. */ |
4310 |
for (i = 0; i < tail->nvars; i++) |
for (i = 0; i < tail->nvars; i++) |
4311 |
XUNMARK (tail->var[i]); |
XUNMARK (tail->var[i]); |
4312 |
#endif |
#endif |
4313 |
|
|
4314 |
unmark_byte_stack (); |
unmark_byte_stack (); |
4315 |
for (backlist = backtrace_list; backlist; backlist = backlist->next) |
for (backlist = backtrace_list; backlist; backlist = backlist->next) |
4316 |
{ |
{ |
4321 |
i = backlist->nargs - 1; |
i = backlist->nargs - 1; |
4322 |
for (; i >= 0; i--) |
for (; i >= 0; i--) |
4323 |
XUNMARK (backlist->args[i]); |
XUNMARK (backlist->args[i]); |
4324 |
} |
} |
4325 |
XUNMARK (buffer_defaults.name); |
XUNMARK (buffer_defaults.name); |
4326 |
XUNMARK (buffer_local_symbols.name); |
XUNMARK (buffer_local_symbols.name); |
4327 |
|
|
4367 |
{ |
{ |
4368 |
/* Compute average percentage of zombies. */ |
/* Compute average percentage of zombies. */ |
4369 |
double nlive = 0; |
double nlive = 0; |
4370 |
|
|
4371 |
for (i = 0; i < 7; ++i) |
for (i = 0; i < 7; ++i) |
4372 |
nlive += XFASTINT (XCAR (total[i])); |
if (CONSP (total[i])) |
4373 |
|
nlive += XFASTINT (XCAR (total[i])); |
4374 |
|
|
4375 |
avg_live = (avg_live * ngcs + nlive) / (ngcs + 1); |
avg_live = (avg_live * ngcs + nlive) / (ngcs + 1); |
4376 |
max_live = max (nlive, max_live); |
max_live = max (nlive, max_live); |
4386 |
safe_run_hooks (Qpost_gc_hook); |
safe_run_hooks (Qpost_gc_hook); |
4387 |
unbind_to (count, Qnil); |
unbind_to (count, Qnil); |
4388 |
} |
} |
4389 |
|
|
4390 |
|
/* Accumulate statistics. */ |
4391 |
|
EMACS_GET_TIME (t2); |
4392 |
|
EMACS_SUB_TIME (t3, t2, t1); |
4393 |
|
if (FLOATP (Vgc_elapsed)) |
4394 |
|
Vgc_elapsed = make_float (XFLOAT_DATA (Vgc_elapsed) + |
4395 |
|
EMACS_SECS (t3) + |
4396 |
|
EMACS_USECS (t3) * 1.0e-6); |
4397 |
|
gcs_done++; |
4398 |
|
|
4399 |
return Flist (sizeof total / sizeof *total, total); |
return Flist (sizeof total / sizeof *total, total); |
4400 |
} |
} |
4401 |
|
|
4418 |
{ |
{ |
4419 |
struct glyph *glyph = row->glyphs[area]; |
struct glyph *glyph = row->glyphs[area]; |
4420 |
struct glyph *end_glyph = glyph + row->used[area]; |
struct glyph *end_glyph = glyph + row->used[area]; |
4421 |
|
|
4422 |
for (; glyph < end_glyph; ++glyph) |
for (; glyph < end_glyph; ++glyph) |
4423 |
if (GC_STRINGP (glyph->object) |
if (GC_STRINGP (glyph->object) |
4424 |
&& !STRING_MARKED_P (XSTRING (glyph->object))) |
&& !STRING_MARKED_P (XSTRING (glyph->object))) |
4460 |
struct image *img; |
struct image *img; |
4461 |
{ |
{ |
4462 |
mark_object (&img->spec); |
mark_object (&img->spec); |
4463 |
|
|
4464 |
if (!NILP (img->data.lisp_val)) |
if (!NILP (img->data.lisp_val)) |
4465 |
mark_object (&img->data.lisp_val); |
mark_object (&img->data.lisp_val); |
4466 |
} |
} |
4488 |
Lisp_Object *last_marked[LAST_MARKED_SIZE]; |
Lisp_Object *last_marked[LAST_MARKED_SIZE]; |
4489 |
int last_marked_index; |
int last_marked_index; |
4490 |
|
|
4491 |
|
/* For debugging--call abort when we cdr down this many |
4492 |
|
links of a list, in mark_object. In debugging, |
4493 |
|
the call to abort will hit a breakpoint. |
4494 |
|
Normally this is zero and the check never goes off. */ |
4495 |
|
int mark_object_loop_halt; |
4496 |
|
|
4497 |
void |
void |
4498 |
mark_object (argptr) |
mark_object (argptr) |
4499 |
Lisp_Object *argptr; |
Lisp_Object *argptr; |
4504 |
void *po; |
void *po; |
4505 |
struct mem_node *m; |
struct mem_node *m; |
4506 |
#endif |
#endif |
4507 |
|
int cdr_count = 0; |
4508 |
|
|
4509 |
loop: |
loop: |
4510 |
obj = *objptr; |
obj = *objptr; |
4548 |
CHECK_ALLOCATED (); \ |
CHECK_ALLOCATED (); \ |
4549 |
CHECK_LIVE (LIVEP); \ |
CHECK_LIVE (LIVEP); \ |
4550 |
} while (0) \ |
} while (0) \ |
4551 |
|
|
4552 |
#else /* not GC_CHECK_MARKED_OBJECTS */ |
#else /* not GC_CHECK_MARKED_OBJECTS */ |
4553 |
|
|
4554 |
#define CHECK_ALLOCATED() (void) 0 |
#define CHECK_ALLOCATED() (void) 0 |
4555 |
#define CHECK_LIVE(LIVEP) (void) 0 |
#define CHECK_LIVE(LIVEP) (void) 0 |
4556 |
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0 |
#define CHECK_ALLOCATED_AND_LIVE(LIVEP) (void) 0 |
4557 |
|
|
4558 |
#endif /* not GC_CHECK_MARKED_OBJECTS */ |
#endif /* not GC_CHECK_MARKED_OBJECTS */ |
4559 |
|
|
4560 |
switch (SWITCH_ENUM_CAST (XGCTYPE (obj))) |
switch (SWITCH_ENUM_CAST (XGCTYPE (obj))) |
4581 |
&& po != &buffer_local_symbols) |
&& po != &buffer_local_symbols) |
4582 |
abort (); |
abort (); |
4583 |
#endif /* GC_CHECK_MARKED_OBJECTS */ |
#endif /* GC_CHECK_MARKED_OBJECTS */ |
4584 |
|
|
4585 |
if (GC_BUFFERP (obj)) |
if (GC_BUFFERP (obj)) |
4586 |
{ |
{ |
4587 |
if (!XMARKBIT (XBUFFER (obj)->name)) |
if (!XMARKBIT (XBUFFER (obj)->name)) |
4612 |
|
|
4613 |
if (size & ARRAY_MARK_FLAG) |
if (size & ARRAY_MARK_FLAG) |
4614 |
break; /* Already marked */ |
break; /* Already marked */ |
4615 |
|
|
4616 |
CHECK_LIVE (live_vector_p); |
CHECK_LIVE (live_vector_p); |
4617 |
ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ |
ptr->size |= ARRAY_MARK_FLAG; /* Else mark it */ |
4618 |
size &= PSEUDOVECTOR_SIZE_MASK; |
size &= PSEUDOVECTOR_SIZE_MASK; |
4705 |
{ |
{ |
4706 |
struct Lisp_Hash_Table *h = XHASH_TABLE (obj); |
struct Lisp_Hash_Table *h = XHASH_TABLE (obj); |
4707 |
EMACS_INT size = h->size; |
EMACS_INT size = h->size; |
4708 |
|
|
4709 |
/* Stop if already marked. */ |
/* Stop if already marked. */ |
4710 |
if (size & ARRAY_MARK_FLAG) |
if (size & ARRAY_MARK_FLAG) |
4711 |
break; |
break; |
4712 |
|
|
4713 |
/* Mark it. */ |
/* Mark it. */ |
4714 |
CHECK_LIVE (live_vector_p); |
CHECK_LIVE (live_vector_p); |
4715 |
h->size |= ARRAY_MARK_FLAG; |
h->size |= ARRAY_MARK_FLAG; |
4716 |
|
|
4717 |
/* Mark contents. */ |
/* Mark contents. */ |
4718 |
/* Do not mark next_free or next_weak. |
/* Do not mark next_free or next_weak. |
4719 |
Being in the next_weak chain |
Being in the next_weak chain |
4720 |
should not keep the hash table alive. |
should not keep the hash table alive. |
4721 |
No need to mark `count' since it is an integer. */ |
No need to mark `count' since it is an integer. */ |
4722 |
mark_object (&h->test); |
mark_object (&h->test); |
4735 |
mark_object (&h->key_and_value); |
mark_object (&h->key_and_value); |
4736 |
else |
else |
4737 |
XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG; |
XVECTOR (h->key_and_value)->size |= ARRAY_MARK_FLAG; |
4738 |
|
|
4739 |
} |
} |
4740 |
else |
else |
4741 |
{ |
{ |
4768 |
|
|
4769 |
if (!PURE_POINTER_P (XSTRING (ptr->xname))) |
if (!PURE_POINTER_P (XSTRING (ptr->xname))) |
4770 |
MARK_STRING (XSTRING (ptr->xname)); |
MARK_STRING (XSTRING (ptr->xname)); |
4771 |
MARK_INTERVAL_TREE (XSTRING (ptr->xname)->intervals); |
MARK_INTERVAL_TREE (STRING_INTERVALS (ptr->xname)); |
4772 |
|
|
4773 |
/* Note that we do not mark the obarray of the symbol. |
/* Note that we do not mark the obarray of the symbol. |
4774 |
It is safe not to do so because nothing accesses that |
It is safe not to do so because nothing accesses that |
4775 |
slot except to check whether it is nil. */ |
slot except to check whether it is nil. */ |
4858 |
if (EQ (ptr->cdr, Qnil)) |
if (EQ (ptr->cdr, Qnil)) |
4859 |
{ |
{ |
4860 |
objptr = &ptr->car; |
objptr = &ptr->car; |
4861 |
|
cdr_count = 0; |
4862 |
goto loop; |
goto loop; |
4863 |
} |
} |
4864 |
mark_object (&ptr->car); |
mark_object (&ptr->car); |
4865 |
objptr = &ptr->cdr; |
objptr = &ptr->cdr; |
4866 |
|
cdr_count++; |
4867 |
|
if (cdr_count == mark_object_loop_halt) |
4868 |
|
abort (); |
4869 |
goto loop; |
goto loop; |
4870 |
} |
} |
4871 |
|
|
4943 |
/* If this is an indirect buffer, mark its base buffer. */ |
/* If this is an indirect buffer, mark its base buffer. */ |
4944 |
if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name)) |
if (buffer->base_buffer && !XMARKBIT (buffer->base_buffer->name)) |
4945 |
{ |
{ |
4946 |
XSETBUFFER (base_buffer, buffer->base_buffer); |
XSETBUFFER (base_buffer, buffer->base_buffer); |
4947 |
mark_buffer (base_buffer); |
mark_buffer (base_buffer); |
4948 |
} |
} |
4949 |
} |
} |
4985 |
Lisp_Object obj; |
Lisp_Object obj; |
4986 |
{ |
{ |
4987 |
int survives_p; |
int survives_p; |
4988 |
|
|
4989 |
switch (XGCTYPE (obj)) |
switch (XGCTYPE (obj)) |
4990 |
{ |
{ |
4991 |
case Lisp_Int: |
case Lisp_Int: |
5002 |
case Lisp_Misc_Marker: |
case Lisp_Misc_Marker: |
5003 |
survives_p = XMARKBIT (obj); |
survives_p = XMARKBIT (obj); |
5004 |
break; |
break; |
5005 |
|
|
5006 |
case Lisp_Misc_Buffer_Local_Value: |
case Lisp_Misc_Buffer_Local_Value: |
5007 |
case Lisp_Misc_Some_Buffer_Local_Value: |
case Lisp_Misc_Some_Buffer_Local_Value: |
5008 |
survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue); |
survives_p = XMARKBIT (XBUFFER_LOCAL_VALUE (obj)->realvalue); |
5009 |
break; |
break; |
5010 |
|
|
5011 |
case Lisp_Misc_Intfwd: |
case Lisp_Misc_Intfwd: |
5012 |
case Lisp_Misc_Boolfwd: |
case Lisp_Misc_Boolfwd: |
5013 |
case Lisp_Misc_Objfwd: |
case Lisp_Misc_Objfwd: |
5015 |
case Lisp_Misc_Kboard_Objfwd: |
case Lisp_Misc_Kboard_Objfwd: |
5016 |
survives_p = 1; |
survives_p = 1; |
5017 |
break; |
break; |
5018 |
|
|
5019 |
case Lisp_Misc_Overlay: |
case Lisp_Misc_Overlay: |
5020 |
survives_p = XMARKBIT (XOVERLAY (obj)->plist); |
survives_p = XMARKBIT (XOVERLAY (obj)->plist); |
5021 |
break; |
break; |
5081 |
register int num_free = 0, num_used = 0; |
register int num_free = 0, num_used = 0; |
5082 |
|
|
5083 |
cons_free_list = 0; |
cons_free_list = 0; |
5084 |
|
|
5085 |
for (cblk = cons_block; cblk; cblk = *cprev) |
for (cblk = cons_block; cblk; cblk = *cprev) |
5086 |
{ |
{ |
5087 |
register int i; |
register int i; |
5131 |
register int num_free = 0, num_used = 0; |
register int num_free = 0, num_used = 0; |
5132 |
|
|
5133 |
float_free_list = 0; |
float_free_list = 0; |
5134 |
|
|
5135 |
for (fblk = float_block; fblk; fblk = *fprev) |
for (fblk = float_block; fblk; fblk = *fprev) |
5136 |
{ |
{ |
5137 |
register int i; |
register int i; |
5231 |
register int num_free = 0, num_used = 0; |
register int num_free = 0, num_used = 0; |
5232 |
|
|
5233 |
symbol_free_list = NULL; |
symbol_free_list = NULL; |
5234 |
|
|
5235 |
for (sblk = symbol_block; sblk; sblk = *sprev) |
for (sblk = symbol_block; sblk; sblk = *sprev) |
5236 |
{ |
{ |
5237 |
int this_free = 0; |
int this_free = 0; |
5244 |
it might be pointed to by pure bytecode which we don't trace, |
it might be pointed to by pure bytecode which we don't trace, |
5245 |
so we conservatively assume that it is live. */ |
so we conservatively assume that it is live. */ |
5246 |
int pure_p = PURE_POINTER_P (XSTRING (sym->xname)); |
int pure_p = PURE_POINTER_P (XSTRING (sym->xname)); |
5247 |
|
|
5248 |
if (!XMARKBIT (sym->plist) && !pure_p) |
if (!XMARKBIT (sym->plist) && !pure_p) |
5249 |
{ |
{ |
5250 |
*(struct Lisp_Symbol **) &sym->value = symbol_free_list; |
*(struct Lisp_Symbol **) &sym->value = symbol_free_list; |
5262 |
XUNMARK (sym->plist); |
XUNMARK (sym->plist); |
5263 |
} |
} |
5264 |
} |
} |
5265 |
|
|
5266 |
lim = SYMBOL_BLOCK_SIZE; |
lim = SYMBOL_BLOCK_SIZE; |
5267 |
/* If this block contains only free symbols and we have already |
/* If this block contains only free symbols and we have already |
5268 |
seen more than two blocks worth of free symbols then deallocate |
seen more than two blocks worth of free symbols then deallocate |
5294 |
register int num_free = 0, num_used = 0; |
register int num_free = 0, num_used = 0; |
5295 |
|
|
5296 |
marker_free_list = 0; |
marker_free_list = 0; |
5297 |
|
|
5298 |
for (mblk = marker_block; mblk; mblk = *mprev) |
for (mblk = marker_block; mblk; mblk = *mprev) |
5299 |
{ |
{ |
5300 |
register int i; |
register int i; |
5424 |
prev = vector, vector = vector->next; |
prev = vector, vector = vector->next; |
5425 |
} |
} |
5426 |
} |
} |
5427 |
|
|
5428 |
#ifdef GC_CHECK_STRING_BYTES |
#ifdef GC_CHECK_STRING_BYTES |
5429 |
if (!noninteractive) |
if (!noninteractive) |
5430 |
check_string_bytes (1); |
check_string_bytes (1); |
5550 |
setjmp_tested_p = longjmps_done = 0; |
setjmp_tested_p = longjmps_done = 0; |
5551 |
#endif |
#endif |
5552 |
#endif |
#endif |
5553 |
|
Vgc_elapsed = make_float (0.0); |
5554 |
|
gcs_done = 0; |
5555 |
} |
} |
5556 |
|
|
5557 |
void |
void |
5623 |
Qpost_gc_hook = intern ("post-gc-hook"); |
Qpost_gc_hook = intern ("post-gc-hook"); |
5624 |
staticpro (&Qpost_gc_hook); |
staticpro (&Qpost_gc_hook); |
5625 |
|
|
5626 |
|
DEFVAR_LISP ("memory-signal-data", &Vmemory_signal_data, |
5627 |
|
doc: /* Precomputed `signal' argument for memory-full error. */); |
5628 |
/* We build this in advance because if we wait until we need it, we might |
/* We build this in advance because if we wait until we need it, we might |
5629 |
not be able to allocate the memory to hold it. */ |
not be able to allocate the memory to hold it. */ |
5630 |
memory_signal_data |
Vmemory_signal_data |
5631 |
= Fcons (Qerror, Fcons (build_string ("Memory exhausted--use M-x save-some-buffers RET"), Qnil)); |
= list2 (Qerror, |
5632 |
staticpro (&memory_signal_data); |
build_string ("Memory exhausted--use M-x save-some-buffers then exit and restart Emacs")); |
5633 |
|
|
5634 |
|
DEFVAR_LISP ("memory-full", &Vmemory_full, |
5635 |
|
doc: /* Non-nil means we are handling a memory-full error. */); |
5636 |
|
Vmemory_full = Qnil; |
5637 |
|
|
5638 |
staticpro (&Qgc_cons_threshold); |
staticpro (&Qgc_cons_threshold); |
5639 |
Qgc_cons_threshold = intern ("gc-cons-threshold"); |
Qgc_cons_threshold = intern ("gc-cons-threshold"); |
5641 |
staticpro (&Qchar_table_extra_slots); |
staticpro (&Qchar_table_extra_slots); |
5642 |
Qchar_table_extra_slots = intern ("char-table-extra-slots"); |
Qchar_table_extra_slots = intern ("char-table-extra-slots"); |
5643 |
|
|
5644 |
|
DEFVAR_LISP ("gc-elapsed", &Vgc_elapsed, |
5645 |
|
doc: /* Accumulated time elapsed in garbage collections. |
5646 |
|
The time is in seconds as a floating point value. |
5647 |
|
Programs may reset this to get statistics in a specific period. */); |
5648 |
|
DEFVAR_INT ("gcs-done", &gcs_done, |
5649 |
|
doc: /* Accumulated number of garbage collections done. |
5650 |
|
Programs may reset this to get statistics in a specific period. */); |
5651 |
|
|
5652 |
defsubr (&Scons); |
defsubr (&Scons); |
5653 |
defsubr (&Slist); |
defsubr (&Slist); |
5654 |
defsubr (&Svector); |
defsubr (&Svector); |