/[emacs]/emacs/src/alloc.c
ViewVC logotype

Diff of /emacs/src/alloc.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.272.2.1 by miles, Wed Jun 12 01:44:48 2002 UTC revision 1.272.2.2 by miles, Fri Apr 4 06:20:56 2003 UTC
# Line 1  Line 1 
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.
# Line 22  Boston, MA 02111-1307, USA.  */ Line 22  Boston, MA 02111-1307, USA.  */
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>
# Line 181  static int malloc_hysteresis; Line 185  static int malloc_hysteresis;
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! */
# Line 224  char *pending_malloc_warning; Line 232  char *pending_malloc_warning;
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    
# Line 248  Lisp_Object Qgc_cons_threshold, Qchar_ta Line 256  Lisp_Object Qgc_cons_threshold, Qchar_ta
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));
# Line 333  int dont_register_blocks; Line 344  int dont_register_blocks;
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  };  };
# Line 418  static POINTER_TYPE *pure_alloc P_ ((siz Line 434  static POINTER_TYPE *pure_alloc P_ ((siz
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)
# Line 444  malloc_warning (str) Line 444  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    
# Line 469  display_malloc_warning () Line 469  display_malloc_warning ()
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
# Line 483  memory_full () Line 485  memory_full ()
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    
# Line 503  buffer_memory_full () Line 505  buffer_memory_full ()
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    
# Line 567  xfree (block) Line 571  xfree (block)
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);
# Line 592  lisp_malloc (nbytes, type) Line 596  lisp_malloc (nbytes, type)
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 ();
# Line 613  lisp_malloc (nbytes, type) Line 617  lisp_malloc (nbytes, type)
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);
# Line 644  lisp_free (block) Line 648  lisp_free (block)
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
# Line 670  emacs_blocked_free (ptr) Line 674  emacs_blocked_free (ptr)
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          {          {
# Line 685  emacs_blocked_free (ptr) Line 689  emacs_blocked_free (ptr)
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.  */
# Line 758  emacs_blocked_malloc (size) Line 762  emacs_blocked_malloc (size)
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    
# Line 793  emacs_blocked_realloc (ptr, size) Line 797  emacs_blocked_realloc (ptr, size)
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 */
# Line 816  emacs_blocked_realloc (ptr, size) Line 820  emacs_blocked_realloc (ptr, size)
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    
# Line 1065  struct sdata Line 1069  struct sdata
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
# Line 1082  struct sdata Line 1086  struct sdata
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
# Line 1161  static int total_string_size; Line 1165  static int total_string_size;
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) \
# Line 1234  string_bytes (s) Line 1238  string_bytes (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      }      }
# Line 1285  check_string_bytes (all_p) Line 1289  check_string_bytes (all_p)
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      }      }
# Line 1391  allocate_string_data (s, nchars, nbytes) Line 1395  allocate_string_data (s, nchars, nbytes)
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;
# Line 1424  allocate_string_data (s, nchars, nbytes) Line 1428  allocate_string_data (s, nchars, nbytes)
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);
# Line 1435  allocate_string_data (s, nchars, nbytes) Line 1439  allocate_string_data (s, nchars, nbytes)
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.  */
# Line 1456  sweep_strings () Line 1460  sweep_strings ()
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;
# Line 1480  sweep_strings () Line 1484  sweep_strings ()
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    
# Line 1552  free_large_strings () Line 1556  free_large_strings ()
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;
# Line 1593  compact_small_strings () Line 1597  compact_small_strings ()
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
# Line 1607  compact_small_strings () Line 1611  compact_small_strings ()
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              {              {
# Line 1629  compact_small_strings () Line 1633  compact_small_strings ()
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                  {                  {
# Line 1676  Both LENGTH and INIT must be numbers.  * Line 1680  Both LENGTH and INIT must be numbers.  *
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      }      }
# Line 1688  Both LENGTH and INIT must be numbers.  * Line 1692  Both LENGTH and INIT must be numbers.  *
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          {          {
# Line 1696  Both LENGTH and INIT must be numbers.  * Line 1700  Both LENGTH and INIT must be numbers.  *
1700            p += len;            p += len;
1701          }          }
1702      }      }
1703      
1704    *p = 0;    *p = 0;
1705    return val;    return val;
1706  }  }
# Line 1724  LENGTH must be a number.  INIT matters o Line 1728  LENGTH must be a number.  INIT matters o
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]
# Line 1749  LENGTH must be a number.  INIT matters o Line 1753  LENGTH must be a number.  INIT matters o
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;
# Line 1770  make_string (contents, nbytes) Line 1774  make_string (contents, nbytes)
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    
# Line 1786  make_unibyte_string (contents, length) Line 1790  make_unibyte_string (contents, length)
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    
# Line 1801  make_multibyte_string (contents, nchars, Line 1805  make_multibyte_string (contents, nchars,
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    
# Line 1837  make_specified_string (contents, nchars, Line 1850  make_specified_string (contents, nchars,
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  }  }
# Line 1852  make_uninit_string (length) Line 1865  make_uninit_string (length)
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    
# Line 1978  make_float (float_value) Line 1991  make_float (float_value)
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);
# Line 2085  DEFUN ("cons", Fcons, Scons, 2, 2, 0, Line 2098  DEFUN ("cons", Fcons, Scons, 2, 2, 0,
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);
# Line 2170  DEFUN ("make-list", Fmake_list, Smake_li Line 2183  DEFUN ("make-list", Fmake_list, Smake_li
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);
# Line 2192  DEFUN ("make-list", Fmake_list, Smake_li Line 2205  DEFUN ("make-list", Fmake_list, Smake_li
2205    
2206        QUIT;        QUIT;
2207      }      }
2208      
2209    return val;    return val;
2210  }  }
2211    
# Line 2228  allocate_vectorlike (len, type) Line 2241  allocate_vectorlike (len, type)
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;
# Line 2268  allocate_hash_table () Line 2281  allocate_hash_table ()
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    
# Line 2283  allocate_window () Line 2296  allocate_window ()
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    
# Line 2298  allocate_frame () Line 2311  allocate_frame ()
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;
# Line 2312  allocate_process () Line 2325  allocate_process ()
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    
# Line 2327  allocate_other_vector (len) Line 2340  allocate_other_vector (len)
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    
# Line 2543  Its value and function definition are vo Line 2556  Its value and function definition are vo
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;
# Line 2625  allocate_misc () Line 2638  allocate_misc ()
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       ()       ()
# Line 2690  make_event_array (nargs, args) Line 2723  make_event_array (nargs, args)
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  }  }
# Line 2782  mem_insert (start, end, type) Line 2815  mem_insert (start, end, type)
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)
# Line 2790  mem_insert (start, end, type) Line 2823  mem_insert (start, end, type)
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.  */
# Line 2824  mem_insert (start, end, type) Line 2857  mem_insert (start, end, type)
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.  */
# Line 2845  mem_insert_fixup (x) Line 2878  mem_insert_fixup (x)
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
# Line 2881  mem_insert_fixup (x) Line 2914  mem_insert_fixup (x)
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;
# Line 2896  mem_insert_fixup (x) Line 2929  mem_insert_fixup (x)
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);
# Line 2910  mem_insert_fixup (x) Line 2943  mem_insert_fixup (x)
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  */
# Line 2950  mem_rotate_left (x) Line 2983  mem_rotate_left (x)
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
# Line 2965  mem_rotate_right (x) Line 2998  mem_rotate_right (x)
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)
# Line 2977  mem_rotate_right (x) Line 3010  mem_rotate_right (x)
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;
# Line 3026  mem_delete (z) Line 3059  mem_delete (z)
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    
# Line 3050  mem_delete_fixup (x) Line 3083  mem_delete_fixup (x)
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;
# Line 3058  mem_delete_fixup (x) Line 3091  mem_delete_fixup (x)
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;
# Line 3083  mem_delete_fixup (x) Line 3116  mem_delete_fixup (x)
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;
# Line 3091  mem_delete_fixup (x) Line 3124  mem_delete_fixup (x)
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;
# Line 3106  mem_delete_fixup (x) Line 3139  mem_delete_fixup (x)
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;
# Line 3115  mem_delete_fixup (x) Line 3148  mem_delete_fixup (x)
3148              }              }
3149          }          }
3150      }      }
3151      
3152    x->color = MEM_BLACK;    x->color = MEM_BLACK;
3153  }  }
3154    
# Line 3183  live_symbol_p (m, p) Line 3216  live_symbol_p (m, p)
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.  */
# Line 3210  live_float_p (m, p) Line 3243  live_float_p (m, p)
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.  */
# Line 3237  live_misc_p (m, p) Line 3270  live_misc_p (m, p)
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.  */
# Line 3317  DEFUN ("gc-status", Fgc_status, Sgc_stat Line 3350  DEFUN ("gc-status", Fgc_status, Sgc_stat
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 */
# Line 3339  mark_maybe_object (obj) Line 3376  mark_maybe_object (obj)
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;
# Line 3385  mark_maybe_object (obj) Line 3422  mark_maybe_object (obj)
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;
# Line 3407  mark_maybe_object (obj) Line 3444  mark_maybe_object (obj)
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);
# Line 3429  mark_maybe_pointer (p) Line 3466  mark_maybe_pointer (p)
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))
# Line 3464  mark_maybe_pointer (p) Line 3501  mark_maybe_pointer (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;
# Line 3485  mark_maybe_pointer (p) Line 3522  mark_maybe_pointer (p)
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:
# Line 3525  mark_maybe_pointer (p) Line 3562  mark_maybe_pointer (p)
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  {  {
# Line 3566  mark_memory (start, end) Line 3603  mark_memory (start, end)
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    
# Line 3598  solution for your system.\n\ Line 3639  solution for your system.\n\
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    
# Line 3742  mark_stack () Line 3787  mark_stack ()
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
# Line 3763  mark_stack () Line 3811  mark_stack ()
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 */
# Line 3772  mark_stack () Line 3820  mark_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    
# Line 3803  pure_alloc (size, type) Line 3855  pure_alloc (size, type)
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    
# Line 3948  Does not copy symbols.  Copies strings w Line 3996  Does not copy symbols.  Copies strings w
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      {      {
# Line 4021  struct backtrace Line 4069  struct backtrace
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));
# Line 4049  Garbage collection happens automatically Line 4097  Garbage collection happens automatically
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.  */
# Line 4062  Garbage collection happens automatically Line 4113  Garbage collection happens automatically
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
# Line 4105  Garbage collection happens automatically Line 4156  Garbage collection happens automatically
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    
# Line 4158  Garbage collection happens automatically Line 4209  Garbage collection happens automatically
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      {      {
# Line 4169  Garbage collection happens automatically Line 4220  Garbage collection happens automatically
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))
# Line 4192  Garbage collection happens automatically Line 4243  Garbage collection happens automatically
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
# Line 4242  Garbage collection happens automatically Line 4293  Garbage collection happens automatically
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.  */
# Line 4252  Garbage collection happens automatically Line 4310  Garbage collection happens automatically
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      {      {
# Line 4263  Garbage collection happens automatically Line 4321  Garbage collection happens automatically
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    
# Line 4309  Garbage collection happens automatically Line 4367  Garbage collection happens automatically
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);
# Line 4327  Garbage collection happens automatically Line 4386  Garbage collection happens automatically
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    
# Line 4350  mark_glyph_matrix (matrix) Line 4418  mark_glyph_matrix (matrix)
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)))
# Line 4392  mark_image (img) Line 4460  mark_image (img)
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  }  }
# Line 4420  mark_image_cache (f) Line 4488  mark_image_cache (f)
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;
# Line 4430  mark_object (argptr) Line 4504  mark_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;
# Line 4473  mark_object (argptr) Line 4548  mark_object (argptr)
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)))
# Line 4506  mark_object (argptr) Line 4581  mark_object (argptr)
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))
# Line 4537  mark_object (argptr) Line 4612  mark_object (argptr)
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;
# Line 4630  mark_object (argptr) Line 4705  mark_object (argptr)
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);
# Line 4660  mark_object (argptr) Line 4735  mark_object (argptr)
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          {          {
# Line 4693  mark_object (argptr) Line 4768  mark_object (argptr)
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.  */
# Line 4783  mark_object (argptr) Line 4858  mark_object (argptr)
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    
# Line 4864  mark_buffer (buf) Line 4943  mark_buffer (buf)
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  }  }
# Line 4906  survives_gc_p (obj) Line 4985  survives_gc_p (obj)
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:
# Line 4923  survives_gc_p (obj) Line 5002  survives_gc_p (obj)
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:
# Line 4936  survives_gc_p (obj) Line 5015  survives_gc_p (obj)
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;
# Line 5002  gc_sweep () Line 5081  gc_sweep ()
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;
# Line 5052  gc_sweep () Line 5131  gc_sweep ()
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;
# Line 5152  gc_sweep () Line 5231  gc_sweep ()
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;
# Line 5165  gc_sweep () Line 5244  gc_sweep ()
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;
# Line 5183  gc_sweep () Line 5262  gc_sweep ()
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
# Line 5215  gc_sweep () Line 5294  gc_sweep ()
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;
# Line 5345  gc_sweep () Line 5424  gc_sweep ()
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);
# Line 5471  init_alloc () Line 5550  init_alloc ()
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
# Line 5542  which includes both saved text and other Line 5623  which includes both saved text and other
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");
# Line 5554  which includes both saved text and other Line 5641  which includes both saved text and other
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);

Legend:
Removed from v.1.272.2.1  
changed lines
  Added in v.1.272.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26