+ if (nbytes > LARGE_STRING_BYTES)
+ {
+ size_t size = sizeof *b - sizeof (struct sdata) + needed;
+
+#ifdef DOUG_LEA_MALLOC
+ /* Prevent mmap'ing the chunk. Lisp data may not be mmap'ed
+ because mapped region contents are not preserved in
+ a dumped Emacs. */
+ mallopt (M_MMAP_MAX, 0);
+#endif
+
+ b = (struct sblock *) lisp_malloc (size, MEM_TYPE_NON_LISP);
+
+#ifdef DOUG_LEA_MALLOC
+ /* Back to a reasonable maximum of mmap'ed areas. */
+ mallopt (M_MMAP_MAX, MMAP_MAX_AREAS);
+#endif
+
+ b->next_free = &b->first_data;
+ b->first_data.string = NULL;
+ b->next = large_sblocks;
+ large_sblocks = b;
+ }
+ else if (current_sblock == NULL
+ || (((char *) current_sblock + SBLOCK_SIZE
+ - (char *) current_sblock->next_free)
+ < needed))
+ {
+ /* Not enough room in the current sblock. */
+ b = (struct sblock *) lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP);
+ b->next_free = &b->first_data;
+ b->first_data.string = NULL;
+ b->next = NULL;
+
+ if (current_sblock)
+ current_sblock->next = b;
+ else
+ oldest_sblock = b;
+ 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 = data->u.data;
+ s->size = nchars;
+ s->size_byte = nbytes;
+ s->data[nbytes] = '\0';
+ b->next_free = (struct sdata *) ((char *) data + needed);
+
+ /* If S had already data assigned, mark that as free by setting its
+ string back-pointer to null, and recording the size of the data
+ in it. */
+ if (old_data)
+ {
+ old_data->u.nbytes = old_nbytes;
+ old_data->string = NULL;
+ }
+
+ consing_since_gc += needed;
+}
+
+
+/* Sweep and compact strings. */
+
+static void
+sweep_strings ()
+{
+ struct string_block *b, *next;
+ struct string_block *live_blocks = NULL;
+
+ string_free_list = NULL;
+ total_strings = total_free_strings = 0;
+ total_string_size = 0;
+
+ /* Scan strings_blocks, free Lisp_Strings that aren't marked. */
+ for (b = string_blocks; b; b = next)
+ {
+ int i, nfree = 0;
+ struct Lisp_String *free_list_before = string_free_list;
+
+ next = b->next;
+
+ for (i = 0; i < STRINGS_IN_STRING_BLOCK; ++i)
+ {
+ struct Lisp_String *s = b->strings + i;
+
+ if (s->data)
+ {
+ /* String was not on free-list before. */
+ if (STRING_MARKED_P (s))
+ {
+ /* String is live; unmark it and its intervals. */
+ UNMARK_STRING (s);
+
+ if (!NULL_INTERVAL_P (s->intervals))
+ UNMARK_BALANCE_INTERVALS (s->intervals);
+
+ ++total_strings;
+ total_string_size += STRING_BYTES (s);
+ }
+ else
+ {
+ /* String is dead. Put it on the free-list. */
+ struct sdata *data = SDATA_OF_STRING (s);
+
+ /* Save the size of S in its sdata so that we know
+ how large that is. Reset the sdata's string
+ back-pointer so that we know it's free. */
+ data->u.nbytes = GC_STRING_BYTES (s);
+ data->string = NULL;
+
+ /* Reset the strings's `data' member so that we
+ know it's free. */
+ s->data = NULL;
+
+ /* Put the string on the free-list. */
+ NEXT_FREE_LISP_STRING (s) = string_free_list;
+ string_free_list = s;
+ ++nfree;
+ }
+ }
+ else
+ {
+ /* S was on the free-list before. Put it there again. */
+ NEXT_FREE_LISP_STRING (s) = string_free_list;
+ string_free_list = s;
+ ++nfree;
+ }
+ }
+
+ /* Free blocks that contain free Lisp_Strings only, except
+ the first two of them. */
+ if (nfree == STRINGS_IN_STRING_BLOCK
+ && total_free_strings > STRINGS_IN_STRING_BLOCK)
+ {
+ lisp_free (b);
+ --n_string_blocks;
+ string_free_list = free_list_before;
+ }
+ else
+ {
+ total_free_strings += nfree;
+ b->next = live_blocks;
+ live_blocks = b;
+ }
+ }
+
+ string_blocks = live_blocks;
+ free_large_strings ();
+ compact_small_strings ();
+}
+
+
+/* Free dead large strings. */
+
+static void
+free_large_strings ()
+{
+ struct sblock *b, *next;
+ struct sblock *live_blocks = NULL;
+
+ for (b = large_sblocks; b; b = next)
+ {
+ next = b->next;
+
+ if (b->first_data.string == NULL)
+ lisp_free (b);
+ else
+ {
+ b->next = live_blocks;
+ live_blocks = b;
+ }
+ }
+
+ large_sblocks = live_blocks;
+}
+
+
+/* Compact data of small strings. Free sblocks that don't contain
+ data of live strings after compaction. */
+
+static void
+compact_small_strings ()
+{
+ struct sblock *b, *tb, *next;
+ struct sdata *from, *to, *end, *tb_end;
+ struct sdata *to_end, *from_end;
+
+ /* TB is the sblock we copy to, TO is the sdata within TB we copy
+ to, and TB_END is the end of TB. */
+ tb = oldest_sblock;
+ tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
+ to = &tb->first_data;
+
+ /* Step through the blocks from the oldest to the youngest. We
+ expect that old blocks will stabilize over time, so that less
+ copying will happen this way. */
+ for (b = oldest_sblock; b; b = b->next)
+ {
+ end = b->next_free;
+ xassert ((char *) end <= (char *) b + SBLOCK_SIZE);
+
+ for (from = &b->first_data; from < end; from = from_end)
+ {
+ /* Compute the next FROM here because copying below may
+ overwrite data we need to compute it. */
+ int nbytes;
+
+ if (from->string)
+ nbytes = GC_STRING_BYTES (from->string);
+ else
+ nbytes = from->u.nbytes;
+
+ nbytes = SDATA_SIZE (nbytes);
+ from_end = (struct sdata *) ((char *) from + nbytes);
+
+ /* FROM->string non-null means it's alive. Copy its data. */
+ if (from->string)
+ {
+ /* If TB is full, proceed with the next sblock. */
+ to_end = (struct sdata *) ((char *) to + nbytes);
+ if (to_end > tb_end)
+ {
+ tb->next_free = to;
+ tb = tb->next;
+ tb_end = (struct sdata *) ((char *) tb + SBLOCK_SIZE);
+ to = &tb->first_data;
+ to_end = (struct sdata *) ((char *) to + nbytes);
+ }
+
+ /* Copy, and update the string's `data' pointer. */
+ if (from != to)
+ {
+ xassert (tb != b || to <= from);
+ safe_bcopy ((char *) from, (char *) to, nbytes);
+ to->string->data = to->u.data;
+ }
+
+ /* Advance past the sdata we copied to. */
+ to = to_end;
+ }
+ }
+ }
+
+ /* The rest of the sblocks following TB don't contain live data, so
+ we can free them. */
+ for (b = tb->next; b; b = next)
+ {
+ next = b->next;
+ lisp_free (b);
+ }
+
+ tb->next_free = to;
+ tb->next = NULL;
+ current_sblock = tb;
+}
+
+
+DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0,
+ "Return a newly created string of length LENGTH, with each element being INIT.\n\
+Both LENGTH and INIT must be numbers.")
+ (length, init)
+ Lisp_Object length, init;
+{
+ register Lisp_Object val;
+ register unsigned char *p, *end;
+ int c, nbytes;
+
+ CHECK_NATNUM (length, 0);
+ CHECK_NUMBER (init, 1);
+
+ c = XINT (init);
+ if (SINGLE_BYTE_CHAR_P (c))
+ {
+ nbytes = XINT (length);
+ val = make_uninit_string (nbytes);
+ p = XSTRING (val)->data;
+ end = p + XSTRING (val)->size;
+ while (p != end)
+ *p++ = c;
+ }
+ else
+ {
+ unsigned char str[4];
+ int len = CHAR_STRING (c, str);
+
+ nbytes = len * XINT (length);
+ val = make_uninit_multibyte_string (XINT (length), nbytes);
+ p = XSTRING (val)->data;
+ end = p + nbytes;
+ while (p != end)
+ {
+ bcopy (str, p, len);
+ p += len;
+ }
+ }
+
+ *p = 0;
+ return val;
+}
+
+
+DEFUN ("make-bool-vector", Fmake_bool_vector, Smake_bool_vector, 2, 2, 0,
+ "Return a new bool-vector of length LENGTH, using INIT for as each element.\n\
+LENGTH must be a number. INIT matters only in whether it is t or nil.")
+ (length, init)
+ Lisp_Object length, init;
+{
+ register Lisp_Object val;
+ struct Lisp_Bool_Vector *p;
+ int real_init, i;
+ int length_in_chars, length_in_elts, bits_per_value;
+
+ CHECK_NATNUM (length, 0);
+
+ bits_per_value = sizeof (EMACS_INT) * BITS_PER_CHAR;
+
+ length_in_elts = (XFASTINT (length) + bits_per_value - 1) / bits_per_value;
+ length_in_chars = ((XFASTINT (length) + BITS_PER_CHAR - 1) / BITS_PER_CHAR);
+
+ /* We must allocate one more elements than LENGTH_IN_ELTS for the
+ slot `size' of the struct Lisp_Bool_Vector. */
+ val = Fmake_vector (make_number (length_in_elts + 1), Qnil);
+ p = XBOOL_VECTOR (val);
+
+ /* Get rid of any bits that would cause confusion. */
+ p->vector_size = 0;
+ XSETBOOL_VECTOR (val, p);
+ p->size = XFASTINT (length);
+
+ real_init = (NILP (init) ? 0 : -1);
+ for (i = 0; i < length_in_chars ; i++)
+ p->data[i] = real_init;
+
+ /* Clear the extraneous bits in the last byte. */
+ if (XINT (length) != length_in_chars * BITS_PER_CHAR)
+ XBOOL_VECTOR (val)->data[length_in_chars - 1]
+ &= (1 << (XINT (length) % BITS_PER_CHAR)) - 1;
+
+ return val;
+}
+
+
+/* Make a string from NBYTES bytes at CONTENTS, and compute the number
+ of characters from the contents. This string may be unibyte or
+ multibyte, depending on the contents. */
+
+Lisp_Object
+make_string (contents, nbytes)
+ char *contents;
+ int nbytes;
+{
+ register Lisp_Object val;
+ int nchars, multibyte_nbytes;
+
+ parse_str_as_multibyte (contents, nbytes, &nchars, &multibyte_nbytes);
+ val = make_uninit_multibyte_string (nchars, nbytes);
+ bcopy (contents, XSTRING (val)->data, nbytes);
+ if (nbytes == nchars || nbytes != multibyte_nbytes)
+ /* CONTENTS contains no multibyte sequences or contains an invalid
+ multibyte sequence. We must make unibyte string. */
+ SET_STRING_BYTES (XSTRING (val), -1);
+ return val;
+}
+
+
+/* Make an unibyte string from LENGTH bytes at CONTENTS. */
+
+Lisp_Object
+make_unibyte_string (contents, length)
+ char *contents;
+ int length;
+{
+ register Lisp_Object val;
+ val = make_uninit_string (length);
+ bcopy (contents, XSTRING (val)->data, length);
+ SET_STRING_BYTES (XSTRING (val), -1);
+ return val;
+}
+
+
+/* Make a multibyte string from NCHARS characters occupying NBYTES
+ bytes at CONTENTS. */
+
+Lisp_Object
+make_multibyte_string (contents, nchars, nbytes)
+ char *contents;
+ int nchars, nbytes;
+{
+ register Lisp_Object val;
+ val = make_uninit_multibyte_string (nchars, nbytes);
+ bcopy (contents, XSTRING (val)->data, nbytes);
+ return val;
+}
+
+
+/* Make a string from NCHARS characters occupying NBYTES bytes at
+ CONTENTS. It is a multibyte string if NBYTES != NCHARS. */
+
+Lisp_Object
+make_string_from_bytes (contents, nchars, nbytes)
+ char *contents;
+ int nchars, nbytes;
+{
+ register Lisp_Object val;
+ val = make_uninit_multibyte_string (nchars, nbytes);
+ bcopy (contents, XSTRING (val)->data, nbytes);
+ if (STRING_BYTES (XSTRING (val)) == XSTRING (val)->size)
+ SET_STRING_BYTES (XSTRING (val), -1);
+ return val;
+}
+
+
+/* Make a string from NCHARS characters occupying NBYTES bytes at
+ CONTENTS. The argument MULTIBYTE controls whether to label the
+ string as multibyte. */
+
+Lisp_Object
+make_specified_string (contents, nchars, nbytes, multibyte)
+ char *contents;
+ int nchars, nbytes;
+ int multibyte;
+{
+ register Lisp_Object val;
+ val = make_uninit_multibyte_string (nchars, nbytes);
+ bcopy (contents, XSTRING (val)->data, nbytes);
+ if (!multibyte)
+ SET_STRING_BYTES (XSTRING (val), -1);
+ return val;
+}
+
+
+/* Make a string from the data at STR, treating it as multibyte if the
+ data warrants. */
+
+Lisp_Object
+build_string (str)
+ char *str;
+{
+ return make_string (str, strlen (str));
+}
+
+
+/* Return an unibyte Lisp_String set up to hold LENGTH characters
+ occupying LENGTH bytes. */
+
+Lisp_Object
+make_uninit_string (length)
+ int length;
+{
+ Lisp_Object val;
+ val = make_uninit_multibyte_string (length, length);
+ SET_STRING_BYTES (XSTRING (val), -1);
+ return val;
+}
+
+
+/* Return a multibyte Lisp_String set up to hold NCHARS characters
+ which occupy NBYTES bytes. */
+
+Lisp_Object
+make_uninit_multibyte_string (nchars, nbytes)
+ int nchars, nbytes;
+{
+ Lisp_Object string;
+ struct Lisp_String *s;
+
+ if (nchars < 0)
+ abort ();
+
+ s = allocate_string ();
+ allocate_string_data (s, nchars, nbytes);
+ XSETSTRING (string, s);
+ string_chars_consed += nbytes;
+ return string;
+}
+
+
+\f
+/***********************************************************************
+ Float Allocation
+ ***********************************************************************/
+
+/* We store float cells inside of float_blocks, allocating a new
+ float_block with malloc whenever necessary. Float cells reclaimed
+ by GC are put on a free list to be reallocated before allocating
+ any new float cells from the latest float_block.
+
+ Each float_block is just under 1020 bytes long, since malloc really
+ allocates in units of powers of two and uses 4 bytes for its own
+ overhead. */
+
+#define FLOAT_BLOCK_SIZE \
+ ((1020 - sizeof (struct float_block *)) / sizeof (struct Lisp_Float))
+
+struct float_block
+{
+ struct float_block *next;
+ struct Lisp_Float floats[FLOAT_BLOCK_SIZE];
+};
+
+/* Current float_block. */
+
+struct float_block *float_block;
+
+/* Index of first unused Lisp_Float in the current float_block. */
+
+int float_block_index;
+
+/* Total number of float blocks now in use. */
+
+int n_float_blocks;
+
+/* Free-list of Lisp_Floats. */
+
+struct Lisp_Float *float_free_list;
+
+
+/* Initialze float allocation. */
+
+void
+init_float ()
+{
+ float_block = (struct float_block *) lisp_malloc (sizeof *float_block,
+ MEM_TYPE_FLOAT);
+ float_block->next = 0;
+ bzero ((char *) float_block->floats, sizeof float_block->floats);
+ float_block_index = 0;
+ float_free_list = 0;
+ n_float_blocks = 1;
+}
+
+
+/* Explicitly free a float cell by putting it on the free-list. */
+
+void
+free_float (ptr)
+ struct Lisp_Float *ptr;
+{
+ *(struct Lisp_Float **)&ptr->data = float_free_list;
+#if GC_MARK_STACK
+ ptr->type = Vdead;
+#endif
+ float_free_list = ptr;
+}
+
+
+/* Return a new float object with value FLOAT_VALUE. */
+
+Lisp_Object
+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);
+ float_free_list = *(struct Lisp_Float **)&float_free_list->data;
+ }
+ else
+ {
+ if (float_block_index == FLOAT_BLOCK_SIZE)
+ {
+ register struct float_block *new;
+
+ new = (struct float_block *) lisp_malloc (sizeof *new,
+ MEM_TYPE_FLOAT);
+ VALIDATE_LISP_STORAGE (new, sizeof *new);
+ new->next = float_block;
+ float_block = new;
+ float_block_index = 0;
+ n_float_blocks++;
+ }
+ XSETFLOAT (val, &float_block->floats[float_block_index++]);
+ }
+
+ XFLOAT_DATA (val) = float_value;
+ XSETFASTINT (XFLOAT (val)->type, 0); /* bug chasing -wsr */
+ consing_since_gc += sizeof (struct Lisp_Float);
+ floats_consed++;
+ return val;
+}
+
+
+\f
+/***********************************************************************
+ Cons Allocation
+ ***********************************************************************/
+
+/* We store cons cells inside of cons_blocks, allocating a new
+ cons_block with malloc whenever necessary. Cons cells reclaimed by
+ GC are put on a free list to be reallocated before allocating
+ any new cons cells from the latest cons_block.
+
+ Each cons_block is just under 1020 bytes long,
+ since malloc really allocates in units of powers of two
+ and uses 4 bytes for its own overhead. */
+
+#define CONS_BLOCK_SIZE \
+ ((1020 - sizeof (struct cons_block *)) / sizeof (struct Lisp_Cons))
+
+struct cons_block
+{
+ struct cons_block *next;
+ struct Lisp_Cons conses[CONS_BLOCK_SIZE];
+};
+
+/* Current cons_block. */
+
+struct cons_block *cons_block;
+
+/* Index of first unused Lisp_Cons in the current block. */
+
+int cons_block_index;
+
+/* Free-list of Lisp_Cons structures. */
+
+struct Lisp_Cons *cons_free_list;
+
+/* Total number of cons blocks now in use. */
+
+int n_cons_blocks;
+
+
+/* Initialize cons allocation. */
+
+void
+init_cons ()
+{
+ cons_block = (struct cons_block *) lisp_malloc (sizeof *cons_block,
+ MEM_TYPE_CONS);
+ cons_block->next = 0;
+ bzero ((char *) cons_block->conses, sizeof cons_block->conses);
+ cons_block_index = 0;
+ cons_free_list = 0;
+ n_cons_blocks = 1;
+}
+
+
+/* Explicitly free a cons cell by putting it on the free-list. */
+
+void
+free_cons (ptr)
+ struct Lisp_Cons *ptr;
+{