From: Paul Eggert <eggert@cs.ucla.edu>
Date: Sun, 6 Dec 2015 17:09:07 +0000 (-0800)
Subject: Improve module interface when WIDE_EMACS_INT
X-Git-Tag: emacs-25.0.90~525
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=302bbe00b31852942827dab42154f33411b99171;p=emacs.git

Improve module interface when WIDE_EMACS_INT

* src/emacs-module.c (plain_values): New constant.
(module_nil): Now a constant.
(Finternal_module_call, value_to_lisp_bits, lisp_to_value_bits)
(syms_of_module): Use if, not #ifdef, so that both sides are
checked at compile-time, and so that GCC doesn’t complain
about an unused var in the typical case.  Also, depend on
plain_values, not on WIDE_EMACS_INT; the code shouldn’t assume
that WIDE_EMACS_INT implies !USE_LSB_TAG.
(value_to_lisp_bits, lisp_to_value_bits): New functions.
Sign-extend integers rather than zero-extending them, as small
negative integers are more likely.
(value_to_lisp, lisp_to_value): Rewrite in terms of the new *_bits
functions.
(HAVE_STRUCT_ATTRIBUTE_ALIGNED): Define to 0 if not already defined.
(mark_modules): Remove.  All uses removed.
(lisp_to_value): Don’t assume Fcons returns a pointer aligned
to GCALIGNMENT.
(syms_of_module): Check that module_nil converts to Qnil.
* src/lisp.h (lisp_h_XSYMBOL, XSYMBOL): Use signed conversion, since
we prefer signed to unsigned when either will do.
(TAG_PTR): Sign-extend pointers when USE_LSB_TAG, as this is
a bit better for emacs-module.c.
---

diff --git a/src/alloc.c b/src/alloc.c
index e83b3836aa4..ea44c51d162 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -5567,10 +5567,6 @@ garbage_collect_1 (void *end)
   mark_fringe_data ();
 #endif
 
-#ifdef HAVE_MODULES
-  mark_modules ();
-#endif
-
   /* Everything is now marked, except for the data in font caches,
      undo lists, and finalizers.  The first two are compacted by
      removing an items which aren't reachable otherwise.  */
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 22fee7e4860..9967fc49afe 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -56,6 +56,18 @@ static pthread_t main_thread;
 static DWORD main_thread;
 #endif
 
+/* True if Lisp_Object and emacs_value have the same representation.
+   This is typically true unless WIDE_EMACS_INT.  In practice, having
+   the same sizes and alignments and maximums should be a good enough
+   proxy for equality of representation.  */
+enum
+  {
+    plain_values
+      = (sizeof (Lisp_Object) == sizeof (emacs_value)
+	 && alignof (Lisp_Object) == alignof (emacs_value)
+	 && INTPTR_MAX == EMACS_INT_MAX)
+  };
+
 
 /* Private runtime and environment members.  */
 
@@ -103,8 +115,11 @@ static void module_reset_handlerlist (const int *);
 static void module_wrong_type (emacs_env *, Lisp_Object, Lisp_Object);
 
 /* We used to return NULL when emacs_value was a different type from
-   Lisp_Object, but nowadays we just use Qnil instead.  */
-static emacs_value module_nil;
+   Lisp_Object, but nowadays we just use Qnil instead.  Although they
+   happen to be the same thing in the current implementation, module
+   code should not assume this.  */
+verify (NIL_IS_ZERO);
+static emacs_value const module_nil = 0;
 
 /* Convenience macros for non-local exit handling.  */
 
@@ -559,7 +574,7 @@ module_get_user_ptr (emacs_env *env, emacs_value uptr)
 static void
 module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr)
 {
-  // FIXME: This function should return bool because it can fail.
+  /* FIXME: This function should return bool because it can fail.  */
   MODULE_FUNCTION_BEGIN ();
   check_main_thread ();
   if (module_non_local_exit_check (env) != emacs_funcall_exit_return)
@@ -587,7 +602,7 @@ static void
 module_set_user_finalizer (emacs_env *env, emacs_value uptr,
 			   emacs_finalizer_function fin)
 {
-  // FIXME: This function should return bool because it can fail.
+  /* FIXME: This function should return bool because it can fail.  */
   MODULE_FUNCTION_BEGIN ();
   Lisp_Object lisp = value_to_lisp (uptr);
   if (! USER_PTRP (lisp))
@@ -598,7 +613,7 @@ module_set_user_finalizer (emacs_env *env, emacs_value uptr,
 static void
 module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val)
 {
-  // FIXME: This function should return bool because it can fail.
+  /* FIXME: This function should return bool because it can fail.  */
   MODULE_FUNCTION_BEGIN ();
   Lisp_Object lvec = value_to_lisp (vec);
   if (! VECTORP (lvec))
@@ -641,7 +656,7 @@ module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i)
 static ptrdiff_t
 module_vec_size (emacs_env *env, emacs_value vec)
 {
-  // FIXME: Return a sentinel value (e.g., -1) on error.
+  /* FIXME: Return a sentinel value (e.g., -1) on error.  */
   MODULE_FUNCTION_BEGIN (0);
   Lisp_Object lvec = value_to_lisp (vec);
   if (! VECTORP (lvec))
@@ -729,19 +744,18 @@ usage: (module-call ENVOBJ &rest ARGLIST)   */)
   initialize_environment (&pub, &priv);
 
   USE_SAFE_ALLOCA;
-#ifdef WIDE_EMACS_INT
-  emacs_value *args = SAFE_ALLOCA (len * sizeof *args);
-
-  for (ptrdiff_t i = 0; i < len; i++)
-    args[i] = lisp_to_value (arglist[i + 1]);
-#else
-  /* BEWARE!  Here, we assume that Lisp_Object and
-   * emacs_value have the exact same representation.  */
-  emacs_value *args = (emacs_value*) arglist + 1;
-#endif
+  emacs_value *args;
+  if (plain_values)
+    args = (emacs_value *) arglist + 1;
+  else
+    {
+      args = SAFE_ALLOCA (len * sizeof *args);
+      for (ptrdiff_t i = 0; i < len; i++)
+	args[i] = lisp_to_value (arglist[i + 1]);
+    }
 
   emacs_value ret = envptr->subr (&pub, len, args, envptr->data);
-  SAFE_FREE();
+  SAFE_FREE ();
 
   eassert (&priv == pub.private_members);
 
@@ -838,106 +852,107 @@ module_args_out_of_range (emacs_env *env, Lisp_Object a1, Lisp_Object a2)
 
 /* Value conversion.  */
 
-#ifdef WIDE_EMACS_INT
 /* Unique Lisp_Object used to mark those emacs_values which are really
-   just containers holding a Lisp_Object that's too large for emacs_value.  */
+   just containers holding a Lisp_Object that does not fit as an emacs_value,
+   either because it is an integer out of range, or is not properly aligned.
+   Used only if !plain_values.  */
 static Lisp_Object ltv_mark;
-#endif
 
-/* Convert an `emacs_value' to the corresponding internal object.
-   Never fails.  */
+/* Convert V to the corresponding internal object O, such that
+   V == lisp_to_value_bits (O).  Never fails.  */
 static Lisp_Object
-value_to_lisp (emacs_value v)
+value_to_lisp_bits (emacs_value v)
 {
-#ifdef WIDE_EMACS_INT
-  uintptr_t tmp = (uintptr_t)v;
-  unsigned tag = tmp & ((1 << GCTYPEBITS) - 1);
-  Lisp_Object o;
+  intptr_t i = (intptr_t) v;
+  if (plain_values || USE_LSB_TAG)
+    return XIL (i);
+
+  /* With wide EMACS_INT and when tag bits are the most significant,
+     reassembling integers differs from reassembling pointers in two
+     ways.  First, save and restore the least-significant bits of the
+     integer, not the most-significant bits.  Second, sign-extend the
+     integer when restoring, but zero-extend pointers because that
+     makes TAG_PTR faster.  */
+
+  EMACS_UINT tag = i & (GCALIGNMENT - 1);
+  EMACS_UINT untagged = i - tag;
   switch (tag)
     {
     case_Lisp_Int:
-      o = make_lisp_ptr ((void *)((tmp - tag) >> GCTYPEBITS), tag); break;
-    default:
-      o = make_lisp_ptr ((void *)(tmp - tag), tag);
+      {
+	bool negative = tag & 1;
+	EMACS_UINT sign_extension
+	  = negative ? VALMASK & ~(INTPTR_MAX >> INTTYPEBITS): 0;
+	uintptr_t u = i;
+	intptr_t all_but_sign = u >> GCTYPEBITS;
+	untagged = sign_extension + all_but_sign;
+	break;
+      }
     }
-  /* eassert (lisp_to_value (o) == v); */
-  if (CONSP (o) && EQ (XCDR (o), ltv_mark))
-    return XCAR (o);
-  else
-    return o;
-#else
-  Lisp_Object o = XIL ((EMACS_INT) v);
-  /* Check the assumption made elsewhere that Lisp_Object and emacs_value
-     share the same underlying bit representation.  */
-  eassert (EQ (o, *(Lisp_Object*)&v));
-  /* eassert (lisp_to_value (o) == v); */
+
+  return XIL ((tag << VALBITS) + untagged);
+}
+
+/* If V was computed from lisp_to_value (O), then return O.
+   Never fails.  */
+static Lisp_Object
+value_to_lisp (emacs_value v)
+{
+  Lisp_Object o = value_to_lisp_bits (v);
+  if (! plain_values && CONSP (o) && EQ (XCDR (o), ltv_mark))
+    o = XCAR (o);
   return o;
-#endif
 }
 
-/* Convert an internal object to an `emacs_value'.  Allocate storage
-   from the environment; return NULL if allocation fails.  */
+/* Attempt to convert O to an emacs_value.  Do not do any checking or
+   or allocate any storage; the caller should prevent or detect
+   any resulting bitpattern that is not a valid emacs_value.  */
 static emacs_value
-lisp_to_value (Lisp_Object o)
+lisp_to_value_bits (Lisp_Object o)
 {
-#ifdef WIDE_EMACS_INT
-  /* We need to compress the EMACS_INT into the space of a pointer.
-     For most objects, this is just a question of shuffling the tags around.
-     But in some cases (e.g. large integers) this can't be done, so we
-     should allocate a special object to hold the extra data.  */
-  Lisp_Object orig = o;
-  int tag = XTYPE (o);
-  switch (tag)
-    {
-    case_Lisp_Int:
-      {
-        EMACS_UINT ui = (EMACS_UINT) XINT (o);
-        if (ui <= (SIZE_MAX >> GCTYPEBITS))
-          {
-            uintptr_t uv = (uintptr_t) ui;
-            emacs_value v = (emacs_value) ((uv << GCTYPEBITS) | tag);
-            eassert (EQ (value_to_lisp (v), o));
-            return v;
-          }
-        else
-          {
-            o = Fcons (o, ltv_mark);
-            tag = Lisp_Cons;
-          }
-      } /* FALLTHROUGH */
-    default:
-      {
-        void *ptr = XUNTAG (o, tag);
-        if (((uintptr_t)ptr) & ((1 << GCTYPEBITS) - 1))
-          { /* Pointer is not properly aligned!  */
-            eassert (!CONSP (o)); /* Cons cells have to always be aligned!  */
-            o = Fcons (o, ltv_mark);
-            ptr = XUNTAG (o, tag);
-          }
-        emacs_value v = (emacs_value) (((uintptr_t) ptr) | tag);
-        eassert (EQ (value_to_lisp (v), orig));
-        return v;
-      }
-    }
-#else
-  emacs_value v = (emacs_value) XLI (o);
+  EMACS_UINT u = XLI (o);
 
-  /* Check the assumption made elsewhere that Lisp_Object and emacs_value
-     share the same underlying bit representation.  */
-  eassert (v == *(emacs_value*)&o);
-  eassert (EQ (value_to_lisp (v), o));
-  return v;
-#endif
+  /* Compress U into the space of a pointer, possibly losing information.  */
+  uintptr_t p = (plain_values || USE_LSB_TAG
+		 ? u
+		 : (INTEGERP (o) ? u << VALBITS : u & VALMASK) + XTYPE (o));
+  return (emacs_value) p;
 }
 
-
-/* Memory management.  */
+#ifndef HAVE_STRUCT_ATTRIBUTE_ALIGNED
+enum { HAVE_STRUCT_ATTRIBUTE_ALIGNED = 0 };
+#endif
 
-/* Mark all objects allocated from local environments so that they
-   don't get garbage-collected.  */
-void
-mark_modules (void)
+/* Convert O to an emacs_value.  Allocate storage if needed; this can
+   signal if memory is exhausted.  */
+static emacs_value
+lisp_to_value (Lisp_Object o)
 {
+  emacs_value v = lisp_to_value_bits (o);
+
+  if (! EQ (o, value_to_lisp_bits (v)))
+    {
+      /* Package the uncompressible object pointer inside a pair
+	 that is compressible.  */
+      Lisp_Object pair = Fcons (o, ltv_mark);
+
+      if (! HAVE_STRUCT_ATTRIBUTE_ALIGNED)
+	{
+	  /* Keep calling Fcons until it returns a compressible pair.
+	     This shouldn't take long.  */
+	  while ((intptr_t) XCONS (pair) & (GCALIGNMENT - 1))
+	    pair = Fcons (o, pair);
+
+	  /* Plant the mark.  The garbage collector will eventually
+	     reclaim any just-allocated uncompressible pairs.  */
+	  XSETCDR (pair, ltv_mark);
+	}
+
+      v = (emacs_value) ((intptr_t) XCONS (pair) + Lisp_Cons);
+    }
+
+  eassert (EQ (o, value_to_lisp (v)));
+  return v;
 }
 
 
@@ -1048,10 +1063,9 @@ module_format_fun_env (const struct module_fun_env *env)
 void
 syms_of_module (void)
 {
-  module_nil = lisp_to_value (Qnil);
-#ifdef WIDE_EMACS_INT
-  ltv_mark = Fcons (Qnil, Qnil);
-#endif
+  if (!plain_values)
+    ltv_mark = Fcons (Qnil, Qnil);
+  eassert (NILP (value_to_lisp (module_nil)));
 
   DEFSYM (Qmodule_refs_hash, "module-refs-hash");
   DEFVAR_LISP ("module-refs-hash", Vmodule_refs_hash,
diff --git a/src/lisp.h b/src/lisp.h
index 4bf7f38af80..8428b6a95d7 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -357,7 +357,7 @@ error !;
 # define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS)
 # define lisp_h_XSYMBOL(a) \
     (eassert (SYMBOLP (a)), \
-     (struct Lisp_Symbol *) ((uintptr_t) XLI (a) - Lisp_Symbol \
+     (struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \
 			     + (char *) lispsym))
 # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK))
 # define lisp_h_XUNTAG(a, type) ((void *) (intptr_t) (XLI (a) - (type)))
@@ -713,9 +713,15 @@ struct Lisp_Symbol
 #define DEFUN_ARGS_8	(Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
 			 Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
 
-/* Yield an integer that contains TAG along with PTR.  */
+/* Yield a signed integer that contains TAG along with PTR.
+
+   Sign-extend pointers when USE_LSB_TAG (this simplifies emacs-module.c),
+   and zero-extend otherwise (that’s a bit faster here).
+   Sign extension matters only when EMACS_INT is wider than a pointer.  */
 #define TAG_PTR(tag, ptr) \
-  ((USE_LSB_TAG ? (tag) : (EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr))
+  (USE_LSB_TAG \
+   ? (intptr_t) (ptr) + (tag) \
+   : (EMACS_INT) (((EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr)))
 
 /* Yield an integer that contains a symbol tag along with OFFSET.
    OFFSET should be the offset in bytes from 'lispsym' to the symbol.  */
@@ -934,7 +940,8 @@ INLINE struct Lisp_Symbol *
 XSYMBOL (Lisp_Object a)
 {
   eassert (SYMBOLP (a));
-  uintptr_t i = (uintptr_t) XUNTAG (a, Lisp_Symbol);
+  intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol);
+  eassert (0 <= i);
   void *p = (char *) lispsym + i;
   return p;
 }
@@ -3919,7 +3926,6 @@ extern Lisp_Object make_user_ptr (void (*finalizer) (void*), void *p);
 
 /* Defined in emacs-module.c.  */
 extern void module_init (void);
-extern void mark_modules (void);
 extern void syms_of_module (void);
 #endif