comparison src/alloc.c @ 83461:9b150bc96d33

Merged from [e-mail]--gnu-2005 (patch 187, 704) Patches applied: * [e-mail]/emacs--devo--0--base-0 tag of [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-704 * [e-mail]/emacs--devo--0--patch-1 Update from CVS * [e-mail]/emacs--devo--0--patch-2 Update from CVS * [e-mail]/emacs--devo--0--patch-3 Update from CVS * [e-mail]/emacs--devo--0--patch-4 Update from CVS * [e-mail]/emacs--devo--0--patch-5 Merge from gnus--rel--5.10 * [e-mail]/emacs--devo--0--patch-6 Update from CVS * [e-mail]/emacs--devo--0--patch-7 Update from CVS * [e-mail]/emacs--devo--0--patch-8 Update from CVS * [e-mail]/emacs--devo--0--patch-9 Update from CVS * [e-mail]/emacs--devo--0--patch-10 Update from CVS * [e-mail]/emacs--devo--0--patch-11 Update from CVS * [e-mail]/emacs--devo--0--patch-12 Update from CVS * [e-mail]/emacs--devo--0--patch-13 Update from CVS * [e-mail]/emacs--devo--0--patch-14 Merge from gnus--rel--5.10 * [e-mail]/emacs--devo--0--patch-15 Update from CVS * [e-mail]/emacs--devo--0--patch-16 Update from CVS * [e-mail]/emacs--devo--0--patch-17 Update from CVS * [e-mail]/emacs--devo--0--patch-18 Update from CVS * [e-mail]/emacs--devo--0--patch-19 Update from CVS * [e-mail]/emacs--devo--0--patch-20 Update from CVS * [e-mail]/emacs--devo--0--patch-21 Update from CVS * [e-mail]/emacs--devo--0--patch-22 Install ERC. * [e-mail]/emacs--devo--0--patch-23 Update from CVS * [e-mail]/emacs--devo--0--patch-24 Fix ERC compiler warnings. * [e-mail]/emacs--devo--0--patch-25 Use utf-8 encoding in ERC ChangeLogs. * [e-mail]/emacs--devo--0--patch-26 Update from CVS * [e-mail]/emacs--devo--0--patch-27 Merge ERC-related Viper hacks into Viper. * [e-mail]/emacs--devo--0--patch-28 Update from CVS * [e-mail]/emacs--devo--0--patch-29 Update from CVS * [e-mail]/emacs--devo--0--patch-30 Merge from erc--main--0 * [e-mail]/gnus--rel--5.10--base-0 tag of [e-mail]--gnu-2005/gnus--rel--5.10--patch-187 * [e-mail]/gnus--rel--5.10--patch-1 Update from CVS * [e-mail]/gnus--rel--5.10--patch-2 Merge from emacs--devo--0 * [e-mail]/gnus--rel--5.10--patch-3 Update from CVS * [e-mail]/gnus--rel--5.10--patch-4 Update from CVS * [e-mail]/gnus--rel--5.10--patch-5 Update from CVS * [e-mail]/gnus--rel--5.10--patch-6 Update from CVS * [e-mail]/gnus--rel--5.10--patch-7 Update from CVS * [e-mail]--gnu-2005/emacs--cvs-trunk--0--patch-704 Update from CVS * [e-mail]--gnu-2005/gnus--rel--5.10--patch-187 Update from CVS git-archimport-id: [e-mail]--2004/emacs--multi-tty--0--patch-501

83460:dbd791ef90a1

/* Storage allocation and gc for GNU Emacs Lisp interpreter.
   Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
      2000, 2001, 2002, 2003, 2004, 2005  Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

	  else
	    tem = &(*tem)->x.next_free;
	}
      eassert ((aligned & 1) == aligned);
      eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
      free (ABLOCKS_BASE (abase));
    }
  UNBLOCK_INPUT;
}

INTERVAL
make_interval ()
{
  INTERVAL val;

  if (interval_free_list)
    {
      val = interval_free_list;
      interval_free_list = INTERVAL_PARENT (interval_free_list);
    }

	  interval_block_index = 0;
	  n_interval_blocks++;
	}
      val = &interval_block->intervals[interval_block_index++];
    }
  consing_since_gc += sizeof (struct interval);
  intervals_consed++;
  RESET_INTERVAL (val);
  val->gcmarkbit = 0;
  return val;

static struct Lisp_String *
allocate_string ()
{
  struct Lisp_String *s;

  /* If the free-list is empty, allocate a new string_block, and
     add all the Lisp_Strings in it to the free-list.  */
  if (string_free_list == NULL)
    {
      struct string_block *b;

  check_string_free_list ();

  /* Pop a Lisp_String off the free-list.  */
  s = string_free_list;
  string_free_list = NEXT_FREE_LISP_STRING (s);

  /* Probably not strictly necessary, but play it safe.  */
  bzero (s, sizeof *s);

  --total_free_strings;

  int needed, old_nbytes;

  /* Determine the number of bytes needed to store NBYTES bytes
     of string data.  */
  needed = SDATA_SIZE (nbytes);

  if (nbytes > LARGE_STRING_BYTES)
    {
      size_t size = sizeof *b - sizeof (struct sdata) + needed;

      current_sblock = b;
    }
  else
    b = current_sblock;

  old_data = s->data ? SDATA_OF_STRING (s) : NULL;
  old_nbytes = GC_STRING_BYTES (s);

  data = b->next_free;
  data->string = s;
  s->data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
  SDATA_NBYTES (data) = nbytes;
#endif

  s->data[nbytes] = '\0';
#ifdef GC_CHECK_STRING_OVERRUN
  bcopy (string_overrun_cookie, (char *) data + needed,
	 GC_STRING_OVERRUN_COOKIE_SIZE);
#endif
  b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);

  /* If S had already data assigned, mark that as free by setting its
     string back-pointer to null, and recording the size of the data
     in it.  */
  if (old_data)

make_float (float_value)
     double float_value;
{
  register Lisp_Object val;

  if (float_free_list)
    {
      /* We use the data field for chaining the free list
	 so that we won't use the same field that has the mark bit.  */
      XSETFLOAT (val, float_free_list);

	}
      XSETFLOAT (val, &float_block->floats[float_block_index]);
      float_block_index++;
    }

  XFLOAT_DATA (val) = float_value;
  eassert (!FLOAT_MARKED_P (XFLOAT (val)));
  consing_since_gc += sizeof (struct Lisp_Float);
  floats_consed++;
  return val;

       doc: /* Create a new cons, give it CAR and CDR as components, and return it.  */)
     (car, cdr)
     Lisp_Object car, cdr;
{
  register Lisp_Object val;

  if (cons_free_list)
    {
      /* We use the cdr for chaining the free list
	 so that we won't use the same field that has the mark bit.  */

	}
      XSETCONS (val, &cons_block->conses[cons_block_index]);
      cons_block_index++;
    }

  XSETCAR (val, car);
  XSETCDR (val, cdr);
  eassert (!CONS_MARKED_P (XCONS (val)));
  consing_since_gc += sizeof (struct Lisp_Cons);
  cons_cells_consed++;

  BLOCK_INPUT;
  mallopt (M_MMAP_MAX, 0);
  UNBLOCK_INPUT;
#endif

  nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
  p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);

#ifdef DOUG_LEA_MALLOC
  /* Back to a reasonable maximum of mmap'ed areas.  */

#endif

  consing_since_gc += nbytes;
  vector_cells_consed += len;

  p->next = all_vectors;
  all_vectors = p;
  ++n_vectors;
  return p;
}

  register Lisp_Object val;
  register struct Lisp_Symbol *p;

  CHECK_STRING (name);

  if (symbol_free_list)
    {
      XSETSYMBOL (val, symbol_free_list);
      symbol_free_list = symbol_free_list->next;
    }

	  n_symbol_blocks++;
	}
      XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
      symbol_block_index++;
    }

  p = XSYMBOL (val);
  p->xname = name;
  p->plist = Qnil;
  p->value = Qunbound;

Lisp_Object
allocate_misc ()
{
  Lisp_Object val;

  if (marker_free_list)
    {
      XSETMISC (val, marker_free_list);
      marker_free_list = marker_free_list->u_free.chain;
    }

	  total_free_markers += MARKER_BLOCK_SIZE;
	}
      XSETMISC (val, &marker_block->markers[marker_block_index]);
      marker_block_index++;
    }

  --total_free_markers;
  consing_since_gc += sizeof (union Lisp_Misc);
  misc_objects_consed++;
  XMARKER (val)->gcmarkbit = 0;

void
check_pure_size ()
{
  if (pure_bytes_used_before_overflow)
    message ("Pure Lisp storage overflow (approx. %d bytes needed)",
	     (int) (pure_bytes_used + pure_bytes_used_before_overflow));
}


/* Return a string allocated in pure space.  DATA is a buffer holding

83461:9b150bc96d33

/* Storage allocation and gc for GNU Emacs Lisp interpreter.
   Copyright (C) 1985, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999,
      2000, 2001, 2002, 2003, 2004, 2005, 2006  Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

	  else
	    tem = &(*tem)->x.next_free;
	}
      eassert ((aligned & 1) == aligned);
      eassert (i == (aligned ? ABLOCKS_SIZE : ABLOCKS_SIZE - 1));
#ifdef HAVE_POSIX_MEMALIGN
      eassert ((unsigned long)ABLOCKS_BASE (abase) % BLOCK_ALIGN == 0);
#endif
      free (ABLOCKS_BASE (abase));
    }
  UNBLOCK_INPUT;
}

INTERVAL
make_interval ()
{
  INTERVAL val;

  /* eassert (!handling_signal); */

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  if (interval_free_list)
    {
      val = interval_free_list;
      interval_free_list = INTERVAL_PARENT (interval_free_list);
    }

	  interval_block_index = 0;
	  n_interval_blocks++;
	}
      val = &interval_block->intervals[interval_block_index++];
    }

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  consing_since_gc += sizeof (struct interval);
  intervals_consed++;
  RESET_INTERVAL (val);
  val->gcmarkbit = 0;
  return val;

static struct Lisp_String *
allocate_string ()
{
  struct Lisp_String *s;

  /* eassert (!handling_signal); */

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  /* If the free-list is empty, allocate a new string_block, and
     add all the Lisp_Strings in it to the free-list.  */
  if (string_free_list == NULL)
    {
      struct string_block *b;

  check_string_free_list ();

  /* Pop a Lisp_String off the free-list.  */
  s = string_free_list;
  string_free_list = NEXT_FREE_LISP_STRING (s);

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  /* Probably not strictly necessary, but play it safe.  */
  bzero (s, sizeof *s);

  --total_free_strings;

  int needed, old_nbytes;

  /* Determine the number of bytes needed to store NBYTES bytes
     of string data.  */
  needed = SDATA_SIZE (nbytes);
  old_data = s->data ? SDATA_OF_STRING (s) : NULL;
  old_nbytes = GC_STRING_BYTES (s);

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  if (nbytes > LARGE_STRING_BYTES)
    {
      size_t size = sizeof *b - sizeof (struct sdata) + needed;

      current_sblock = b;
    }
  else
    b = current_sblock;

  data = b->next_free;
  b->next_free = (struct sdata *) ((char *) data + needed + GC_STRING_EXTRA);

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  data->string = s;
  s->data = SDATA_DATA (data);
#ifdef GC_CHECK_STRING_BYTES
  SDATA_NBYTES (data) = nbytes;
#endif

  s->data[nbytes] = '\0';
#ifdef GC_CHECK_STRING_OVERRUN
  bcopy (string_overrun_cookie, (char *) data + needed,
	 GC_STRING_OVERRUN_COOKIE_SIZE);
#endif

  /* If S had already data assigned, mark that as free by setting its
     string back-pointer to null, and recording the size of the data
     in it.  */
  if (old_data)

make_float (float_value)
     double float_value;
{
  register Lisp_Object val;

  /* eassert (!handling_signal); */

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  if (float_free_list)
    {
      /* We use the data field for chaining the free list
	 so that we won't use the same field that has the mark bit.  */
      XSETFLOAT (val, float_free_list);

	}
      XSETFLOAT (val, &float_block->floats[float_block_index]);
      float_block_index++;
    }

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  XFLOAT_DATA (val) = float_value;
  eassert (!FLOAT_MARKED_P (XFLOAT (val)));
  consing_since_gc += sizeof (struct Lisp_Float);
  floats_consed++;
  return val;

       doc: /* Create a new cons, give it CAR and CDR as components, and return it.  */)
     (car, cdr)
     Lisp_Object car, cdr;
{
  register Lisp_Object val;

  /* eassert (!handling_signal); */

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  if (cons_free_list)
    {
      /* We use the cdr for chaining the free list
	 so that we won't use the same field that has the mark bit.  */

	}
      XSETCONS (val, &cons_block->conses[cons_block_index]);
      cons_block_index++;
    }

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  XSETCAR (val, car);
  XSETCDR (val, cdr);
  eassert (!CONS_MARKED_P (XCONS (val)));
  consing_since_gc += sizeof (struct Lisp_Cons);
  cons_cells_consed++;

  BLOCK_INPUT;
  mallopt (M_MMAP_MAX, 0);
  UNBLOCK_INPUT;
#endif

  /* This gets triggered by code which I haven't bothered to fix.  --Stef  */
  /* eassert (!handling_signal); */

  nbytes = sizeof *p + (len - 1) * sizeof p->contents[0];
  p = (struct Lisp_Vector *) lisp_malloc (nbytes, type);

#ifdef DOUG_LEA_MALLOC
  /* Back to a reasonable maximum of mmap'ed areas.  */

#endif

  consing_since_gc += nbytes;
  vector_cells_consed += len;

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  p->next = all_vectors;
  all_vectors = p;

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  ++n_vectors;
  return p;
}

  register Lisp_Object val;
  register struct Lisp_Symbol *p;

  CHECK_STRING (name);

  eassert (!handling_signal);

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  if (symbol_free_list)
    {
      XSETSYMBOL (val, symbol_free_list);
      symbol_free_list = symbol_free_list->next;
    }

	  n_symbol_blocks++;
	}
      XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
      symbol_block_index++;
    }

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  p = XSYMBOL (val);
  p->xname = name;
  p->plist = Qnil;
  p->value = Qunbound;

Lisp_Object
allocate_misc ()
{
  Lisp_Object val;

  /* eassert (!handling_signal); */

#ifndef SYNC_INPUT
  BLOCK_INPUT;
#endif

  if (marker_free_list)
    {
      XSETMISC (val, marker_free_list);
      marker_free_list = marker_free_list->u_free.chain;
    }

	  total_free_markers += MARKER_BLOCK_SIZE;
	}
      XSETMISC (val, &marker_block->markers[marker_block_index]);
      marker_block_index++;
    }

#ifndef SYNC_INPUT
  UNBLOCK_INPUT;
#endif

  --total_free_markers;
  consing_since_gc += sizeof (union Lisp_Misc);
  misc_objects_consed++;
  XMARKER (val)->gcmarkbit = 0;

void
check_pure_size ()
{
  if (pure_bytes_used_before_overflow)
    message ("emacs:0:Pure Lisp storage overflow (approx. %d bytes needed)",
	     (int) (pure_bytes_used + pure_bytes_used_before_overflow));
}


/* Return a string allocated in pure space.  DATA is a buffer holding