X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0815944ac4a190d1402079453b99d00fcc26dc25..c558890bde00f4b5079edd2c1d0d51086af3b13b:/src/alloc.c

diff --git a/src/alloc.c b/src/alloc.c
index ca86a84b06..56a535411c 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -7,8 +7,8 @@ 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
-the Free Software Foundation, either version 3 of the License, or
-(at your option) any later version.
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
 
 GNU Emacs is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -819,8 +819,10 @@ malloc_unblock_input (void)
       malloc_probe (size);			\
   } while (0)
 
+static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
+static void *lrealloc (void *, size_t);
 
-/* Like malloc but check for no memory and block interrupt input..  */
+/* Like malloc but check for no memory and block interrupt input.  */
 
 void *
 xmalloc (size_t size)
@@ -828,7 +830,7 @@ xmalloc (size_t size)
   void *val;
 
   MALLOC_BLOCK_INPUT;
-  val = malloc (size);
+  val = lmalloc (size);
   MALLOC_UNBLOCK_INPUT;
 
   if (!val && size)
@@ -845,7 +847,7 @@ xzalloc (size_t size)
   void *val;
 
   MALLOC_BLOCK_INPUT;
-  val = malloc (size);
+  val = lmalloc (size);
   MALLOC_UNBLOCK_INPUT;
 
   if (!val && size)
@@ -866,9 +868,9 @@ xrealloc (void *block, size_t size)
   /* We must call malloc explicitly when BLOCK is 0, since some
      reallocs don't do this.  */
   if (! block)
-    val = malloc (size);
+    val = lmalloc (size);
   else
-    val = realloc (block, size);
+    val = lrealloc (block, size);
   MALLOC_UNBLOCK_INPUT;
 
   if (!val && size)
@@ -1070,7 +1072,7 @@ lisp_malloc (size_t nbytes, enum mem_type type)
   allocated_mem_type = type;
 #endif
 
-  val = malloc (nbytes);
+  val = lmalloc (nbytes);
 
 #if ! USE_LSB_TAG
   /* If the memory just allocated cannot be addressed thru a Lisp
@@ -1133,6 +1135,7 @@ lisp_free (void *block)
 #  define USE_ALIGNED_ALLOC 1
 # elif !defined HYBRID_MALLOC && defined HAVE_POSIX_MEMALIGN
 #  define USE_ALIGNED_ALLOC 1
+#  define aligned_alloc my_aligned_alloc /* Avoid collision with lisp.h.  */
 static void *
 aligned_alloc (size_t alignment, size_t size)
 {
@@ -1363,6 +1366,84 @@ lisp_align_free (void *block)
   MALLOC_UNBLOCK_INPUT;
 }
 
+#if !defined __GNUC__ && !defined __alignof__
+# define __alignof__(type) alignof (type)
+#endif
+
+/* True if malloc returns a multiple of GCALIGNMENT.  In practice this
+   holds if __alignof__ (max_align_t) is a multiple.  Use __alignof__
+   if available, as otherwise this check would fail with GCC x86.
+   This is a macro, not an enum constant, for portability to HP-UX
+   10.20 cc and AIX 3.2.5 xlc.  */
+#define MALLOC_IS_GC_ALIGNED (__alignof__ (max_align_t) % GCALIGNMENT == 0)
+
+/* True if P is suitably aligned for SIZE, where Lisp alignment may be
+   needed if SIZE is Lisp-aligned.  */
+
+static bool
+laligned (void *p, size_t size)
+{
+  return (MALLOC_IS_GC_ALIGNED || (intptr_t) p % GCALIGNMENT == 0
+	  || size % GCALIGNMENT != 0);
+}
+
+/* Like malloc and realloc except that if SIZE is Lisp-aligned, make
+   sure the result is too, if necessary by reallocating (typically
+   with larger and larger sizes) until the allocator returns a
+   Lisp-aligned pointer.  Code that needs to allocate C heap memory
+   for a Lisp object should use one of these functions to obtain a
+   pointer P; that way, if T is an enum Lisp_Type value and L ==
+   make_lisp_ptr (P, T), then XPNTR (L) == P and XTYPE (L) == T.
+
+   On typical modern platforms these functions' loops do not iterate.
+   On now-rare (and perhaps nonexistent) platforms, the loops in
+   theory could repeat forever.  If an infinite loop is possible on a
+   platform, a build would surely loop and the builder can then send
+   us a bug report.  Adding a counter to try to detect any such loop
+   would complicate the code (and possibly introduce bugs, in code
+   that's never really exercised) for little benefit.  */
+
+static void *
+lmalloc (size_t size)
+{
+#if USE_ALIGNED_ALLOC
+  if (! MALLOC_IS_GC_ALIGNED)
+    return aligned_alloc (GCALIGNMENT, size);
+#endif
+
+  void *p;
+  while (true)
+    {
+      p = malloc (size);
+      if (laligned (p, size))
+	break;
+      free (p);
+      size_t bigger;
+      if (! INT_ADD_WRAPV (size, GCALIGNMENT, &bigger))
+	size = bigger;
+    }
+
+  eassert ((intptr_t) p % GCALIGNMENT == 0);
+  return p;
+}
+
+static void *
+lrealloc (void *p, size_t size)
+{
+  while (true)
+    {
+      p = realloc (p, size);
+      if (laligned (p, size))
+	break;
+      size_t bigger;
+      if (! INT_ADD_WRAPV (size, GCALIGNMENT, &bigger))
+	size = bigger;
+    }
+
+  eassert ((intptr_t) p % GCALIGNMENT == 0);
+  return p;
+}
+
 
 /***********************************************************************
 			 Interval Allocation
@@ -3318,22 +3399,13 @@ allocate_buffer (void)
 DEFUN ("make-vector", Fmake_vector, Smake_vector, 2, 2, 0,
        doc: /* Return a newly created vector of length LENGTH, with each element being INIT.
 See also the function `vector'.  */)
-  (register Lisp_Object length, Lisp_Object init)
+  (Lisp_Object length, Lisp_Object init)
 {
-  Lisp_Object vector;
-  register ptrdiff_t sizei;
-  register ptrdiff_t i;
-  register struct Lisp_Vector *p;
-
   CHECK_NATNUM (length);
-
-  p = allocate_vector (XFASTINT (length));
-  sizei = XFASTINT (length);
-  for (i = 0; i < sizei; i++)
+  struct Lisp_Vector *p = allocate_vector (XFASTINT (length));
+  for (ptrdiff_t i = 0; i < XFASTINT (length); i++)
     p->contents[i] = init;
-
-  XSETVECTOR (vector, p);
-  return vector;
+  return make_lisp_ptr (p, Lisp_Vectorlike);
 }
 
 DEFUN ("vector", Fvector, Svector, 0, MANY, 0,
@@ -3342,12 +3414,9 @@ Any number of arguments, even zero arguments, are allowed.
 usage: (vector &rest OBJECTS)  */)
   (ptrdiff_t nargs, Lisp_Object *args)
 {
-  ptrdiff_t i;
-  register Lisp_Object val = make_uninit_vector (nargs);
-  register struct Lisp_Vector *p = XVECTOR (val);
-
-  for (i = 0; i < nargs; i++)
-    p->contents[i] = args[i];
+  Lisp_Object val = make_uninit_vector (nargs);
+  struct Lisp_Vector *p = XVECTOR (val);
+  memcpy (p->contents, args, nargs * sizeof *args);
   return val;
 }
 
@@ -3386,9 +3455,8 @@ stack before executing the byte-code.
 usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS)  */)
   (ptrdiff_t nargs, Lisp_Object *args)
 {
-  ptrdiff_t i;
-  register Lisp_Object val = make_uninit_vector (nargs);
-  register struct Lisp_Vector *p = XVECTOR (val);
+  Lisp_Object val = make_uninit_vector (nargs);
+  struct Lisp_Vector *p = XVECTOR (val);
 
   /* We used to purecopy everything here, if purify-flag was set.  This worked
      OK for Emacs-23, but with Emacs-24's lexical binding code, it can be
@@ -3398,8 +3466,7 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT
      just wasteful and other times plainly wrong (e.g. those free vars may want
      to be setcar'd).  */
 
-  for (i = 0; i < nargs; i++)
-    p->contents[i] = args[i];
+  memcpy (p->contents, args, nargs * sizeof *args);
   make_byte_code (p);
   XSETCOMPILED (val, p);
   return val;
@@ -3657,7 +3724,6 @@ make_save_ptr_int (void *a, ptrdiff_t b)
   return val;
 }
 
-#if ! (defined USE_X_TOOLKIT || defined USE_GTK)
 Lisp_Object
 make_save_ptr_ptr (void *a, void *b)
 {
@@ -3668,7 +3734,6 @@ make_save_ptr_ptr (void *a, void *b)
   p->data[1].pointer = b;
   return val;
 }
-#endif
 
 Lisp_Object
 make_save_funcptr_ptr_obj (void (*a) (void), void *b, Lisp_Object c)
@@ -5360,7 +5425,7 @@ purecopy (Lisp_Object obj)
     }
   else
     {
-      Lisp_Object fmt = build_pure_c_string ("Don't know how to purify: %S");
+      AUTO_STRING (fmt, "Don't know how to purify: %S");
       Fsignal (Qerror, list1 (CALLN (Fformat, fmt, obj)));
     }
 
@@ -5591,7 +5656,7 @@ garbage_collect_1 (void *end)
     return Qnil;
 
   /* Record this function, so it appears on the profiler's backtraces.  */
-  record_in_backtrace (Qautomatic_gc, 0, 0);
+  record_in_backtrace (QAutomatic_GC, 0, 0);
 
   check_cons_list ();
 
@@ -7321,7 +7386,7 @@ do hash-consing of the objects allocated to pure space.  */);
   DEFSYM (Qstring_bytes, "string-bytes");
   DEFSYM (Qvector_slots, "vector-slots");
   DEFSYM (Qheap, "heap");
-  DEFSYM (Qautomatic_gc, "Automatic GC");
+  DEFSYM (QAutomatic_GC, "Automatic GC");
 
   DEFSYM (Qgc_cons_threshold, "gc-cons-threshold");
   DEFSYM (Qchar_table_extra_slots, "char-table-extra-slots");