From 44ce2cb89856709fa4581ed4e3b8091b2d2c351c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= <nicolasbertolo@gmail.com>
Date: Fri, 8 May 2020 14:30:14 -0300
Subject: [PATCH 4/9] Handle LISP_WORDS_ARE_POINTERS and
 CHECK_LISP_OBJECT_TYPE.

* src/comp.c: Introduce the Lisp_X, Lisp_Word, and Lisp_Word_tag
types. These types are used instead of long or long long. Use
emacs_int_type and emacs_uint_types where appropriate.
(emit_coerce): Add special logic that handles the case when
Lisp_Object is a struct. This is necessary for handling the
--enable-check-lisp-object-type configure option.

* src/lisp.h: Since libgccjit does not support opaque unions, change
Lisp_X to be struct. This is done to ensure that the same types are
used in the same binary. It is probably unnecessary since only a
pointer to it is used.
---
 src/comp.c | 328 ++++++++++++++++++++++++++++++++++++-----------------
 src/lisp.h |   5 +-
 2 files changed, 228 insertions(+), 105 deletions(-)

diff --git a/src/comp.c b/src/comp.c
index 0d46628e6a..0d5880ad3c 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -116,6 +116,16 @@ #define F_RELOC_MAX_SIZE 1500
   gcc_jit_type *char_ptr_type;
   gcc_jit_type *ptrdiff_type;
   gcc_jit_type *uintptr_type;
+#if LISP_WORDS_ARE_POINTERS
+  gcc_jit_struct *lisp_X_s;
+  gcc_jit_type *lisp_X;
+#endif
+  gcc_jit_type *lisp_word_type;
+  gcc_jit_type *lisp_word_tag_type;
+#ifdef LISP_OBJECT_IS_STRUCT
+  gcc_jit_field *lisp_obj_i;
+  gcc_jit_struct *lisp_obj_s;
+#endif
   gcc_jit_type *lisp_obj_type;
   gcc_jit_type *lisp_obj_ptr_type;
   /* struct Lisp_Cons */
@@ -158,7 +168,8 @@ #define F_RELOC_MAX_SIZE 1500
   gcc_jit_field *cast_union_as_c_p;
   gcc_jit_field *cast_union_as_v_p;
   gcc_jit_field *cast_union_as_lisp_cons_ptr;
-  gcc_jit_field *cast_union_as_lisp_obj;
+  gcc_jit_field *cast_union_as_lisp_word;
+  gcc_jit_field *cast_union_as_lisp_word_tag;
   gcc_jit_field *cast_union_as_lisp_obj_ptr;
   gcc_jit_function *func; /* Current function being compiled.  */
   bool func_has_non_local; /* From comp-func has-non-local slot.  */
@@ -347,8 +358,10 @@ type_to_cast_field (gcc_jit_type *type)
     field = comp.cast_union_as_c_p;
   else if (type == comp.lisp_cons_ptr_type)
     field = comp.cast_union_as_lisp_cons_ptr;
-  else if (type == comp.lisp_obj_type)
-    field = comp.cast_union_as_lisp_obj;
+  else if (type == comp.lisp_word_type)
+    field = comp.cast_union_as_lisp_word;
+  else if (type == comp.lisp_word_tag_type)
+    field = comp.cast_union_as_lisp_word_tag;
   else if (type == comp.lisp_obj_ptr_type)
     field = comp.cast_union_as_lisp_obj_ptr;
   else
@@ -627,6 +640,31 @@ emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj)
   if (new_type == old_type)
     return obj;
 
+#ifdef LISP_OBJECT_IS_STRUCT
+  if (old_type == comp.lisp_obj_type)
+    {
+      gcc_jit_rvalue *lwordobj =
+        gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_i);
+      return emit_coerce (new_type, lwordobj);
+    }
+
+  if (new_type == comp.lisp_obj_type)
+    {
+      gcc_jit_rvalue *lwordobj =
+        emit_coerce (comp.lisp_word_type, obj);
+
+      gcc_jit_lvalue *tmp_s
+        = gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type,
+                                      format_string ("lisp_obj_%td", i++));
+
+      gcc_jit_block_add_assignment (comp.block, NULL,
+                                    gcc_jit_lvalue_access_field (tmp_s, NULL,
+                                                                 comp.lisp_obj_i),
+                                    lwordobj);
+      return gcc_jit_lvalue_as_rvalue (tmp_s);
+    }
+#endif
+
   gcc_jit_field *orig_field =
     type_to_cast_field (old_type);
   gcc_jit_field *dest_field = type_to_cast_field (new_type);
@@ -664,14 +702,8 @@ emit_binary_op (enum gcc_jit_binary_op op,
 /* Should come with libgccjit.  */
 
 static gcc_jit_rvalue *
-emit_rvalue_from_long_long (long long n)
+emit_rvalue_from_long_long (gcc_jit_type *type, long long n)
 {
-#ifndef WIDE_EMACS_INT
-  xsignal1 (Qnative_ice,
-	    build_string ("emit_rvalue_from_long_long called in non wide int"
-			  " configuration"));
-#endif
-
   emit_comment (format_string ("emit long long: %lld", n));
 
   gcc_jit_rvalue *high =
@@ -697,7 +729,7 @@ emit_rvalue_from_long_long (long long n)
 		      32));
 
   return
-    emit_coerce (comp.long_long_type,
+    emit_coerce (type,
       emit_binary_op (
 	GCC_JIT_BINARY_OP_BITWISE_OR,
 	comp.unsigned_long_long_type,
@@ -712,29 +744,135 @@ emit_rvalue_from_long_long (long long n)
 }
 
 static gcc_jit_rvalue *
-emit_most_positive_fixnum (void)
+emit_rvalue_from_unsigned_long_long (gcc_jit_type *type, unsigned long long n)
+{
+  emit_comment (format_string ("emit unsigned long long: %llu", n));
+
+  gcc_jit_rvalue *high =
+    gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+					  comp.unsigned_long_long_type,
+					  n >> 32);
+  gcc_jit_rvalue *low =
+    emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
+		    comp.unsigned_long_long_type,
+		    emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
+				    comp.unsigned_long_long_type,
+				    gcc_jit_context_new_rvalue_from_long (
+				      comp.ctxt,
+				      comp.unsigned_long_long_type,
+				      n),
+				    gcc_jit_context_new_rvalue_from_int (
+				      comp.ctxt,
+				      comp.unsigned_long_long_type,
+				      32)),
+		    gcc_jit_context_new_rvalue_from_int (
+		      comp.ctxt,
+		      comp.unsigned_long_long_type,
+		      32));
+
+  return emit_coerce (
+           type,
+           emit_binary_op (
+             GCC_JIT_BINARY_OP_BITWISE_OR,
+             comp.unsigned_long_long_type,
+             emit_binary_op (
+               GCC_JIT_BINARY_OP_LSHIFT,
+               comp.unsigned_long_long_type,
+               high,
+               gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+                                                    comp.unsigned_long_long_type,
+                                                    32)),
+             low));
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_emacs_uint (EMACS_UINT val)
+{
+  if (val != (long) val)
+    {
+      return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+                                                   comp.emacs_uint_type,
+                                                   val);
+    }
+  else
+    {
+      return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val);
+    }
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_emacs_int (EMACS_INT val)
+{
+  if (val != (long) val)
+    {
+      return emit_rvalue_from_long_long (comp.emacs_int_type, val);
+    }
+  else
+    {
+      return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+                                                   comp.emacs_int_type, val);
+    }
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val)
 {
-#if EMACS_INT_MAX > LONG_MAX
-  return emit_rvalue_from_long_long (MOST_POSITIVE_FIXNUM);
+  if (val != (long) val)
+    {
+      return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val);
+    }
+  else
+    {
+      return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+                                                   comp.lisp_word_tag_type,
+                                                   val);
+    }
+}
+
+static gcc_jit_rvalue *
+emit_rvalue_from_lisp_word (Lisp_Word val)
+{
+#if LISP_WORDS_ARE_POINTERS
+  return gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
+                                              comp.lisp_word_type,
+                                              val);
 #else
-  return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
-					       comp.emacs_int_type,
-					       MOST_POSITIVE_FIXNUM);
+  if (val != (long) val)
+    {
+      return emit_rvalue_from_unsigned_long_long (comp.lisp_word_type, val);
+    }
+  else
+    {
+      return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
+                                                   comp.lisp_word_type,
+                                                   val);
+    }
 #endif
 }
 
 static gcc_jit_rvalue *
-emit_most_negative_fixnum (void)
+emit_rvalue_from_lisp_obj (Lisp_Object obj)
 {
-#if EMACS_INT_MAX > LONG_MAX
-  return emit_rvalue_from_long_long (MOST_NEGATIVE_FIXNUM);
+#ifdef LISP_OBJECT_IS_STRUCT
+  return emit_coerce(comp.lisp_obj_type,
+                     emit_rvalue_from_lisp_word (obj.i));
 #else
-  return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
-					       comp.emacs_int_type,
-					       MOST_NEGATIVE_FIXNUM);
+  return emit_rvalue_from_lisp_word (obj);
 #endif
 }
 
+static gcc_jit_rvalue *
+emit_most_positive_fixnum (void)
+{
+  return emit_rvalue_from_emacs_int(MOST_POSITIVE_FIXNUM);
+}
+
+static gcc_jit_rvalue *
+emit_most_negative_fixnum (void)
+{
+  return emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM);
+}
+
 /*
    Emit the equivalent of:
    (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i)
@@ -769,7 +907,7 @@ emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type,
 emit_XLI (gcc_jit_rvalue *obj)
 {
   emit_comment ("XLI");
-  return obj;
+  return emit_coerce (comp.emacs_int_type, obj);
 }
 
 static gcc_jit_lvalue *
@@ -779,54 +917,40 @@ emit_lval_XLI (gcc_jit_lvalue *obj)
   return obj;
 }
 
-/*
+
 static gcc_jit_rvalue *
 emit_XLP (gcc_jit_rvalue *obj)
 {
   emit_comment ("XLP");
 
-  return gcc_jit_rvalue_access_field (obj,
-				      NULL,
-				      comp.lisp_obj_as_ptr);
+  return emit_coerce(comp.void_ptr_type, obj);
 }
 
-static gcc_jit_lvalue *
-emit_lval_XLP (gcc_jit_lvalue *obj)
-{
-  emit_comment ("lval_XLP");
+/* TODO */
+/* static gcc_jit_lvalue * */
+/* emit_lval_XLP (gcc_jit_lvalue *obj) */
+/* { */
+/*   emit_comment ("lval_XLP"); */
+
+/*   return gcc_jit_lvalue_access_field (obj, */
+/* 				      NULL, */
+/* 				      comp.lisp_obj_as_ptr); */
+/* } */
 
-  return gcc_jit_lvalue_access_field (obj,
-				      NULL,
-				      comp.lisp_obj_as_ptr);
-} */
 static gcc_jit_rvalue *
-emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag)
+emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag)
 {
   /* #define XUNTAG(a, type, ctype) ((ctype *)
      ((char *) XLP (a) - LISP_WORD_TAG (type))) */
   emit_comment ("XUNTAG");
 
-#ifndef WIDE_EMACS_INT
   return emit_coerce (
 	   gcc_jit_type_get_pointer (type),
 	   emit_binary_op (
 	     GCC_JIT_BINARY_OP_MINUS,
-	     comp.emacs_int_type,
-	     emit_XLI (a),
-	     gcc_jit_context_new_rvalue_from_int (
-	       comp.ctxt,
-	       comp.emacs_int_type,
-	       lisp_word_tag)));
-#else
-  return emit_coerce (
-	   gcc_jit_type_get_pointer (type),
-	   emit_binary_op (
-	     GCC_JIT_BINARY_OP_MINUS,
-	     comp.unsigned_long_long_type,
-	     /* FIXME Should be XLP.  */
-	     emit_XLI (a),
-	     emit_rvalue_from_long_long (lisp_word_tag)));
-#endif
+	     comp.uintptr_type,
+	     emit_XLP (a),
+	     emit_rvalue_from_lisp_word_tag(lisp_word_tag)));
 }
 
 static gcc_jit_rvalue *
@@ -853,7 +977,7 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
 }
 
 static gcc_jit_rvalue *
-emit_TAGGEDP (gcc_jit_rvalue *obj, ptrdiff_t tag)
+emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
 {
    /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
 	- (unsigned) (tag)) \
@@ -1054,17 +1178,7 @@ emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n)
 			comp.emacs_int_type,
 			tmp, comp.lisp_int0);
 
-  gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func,
-						    NULL,
-						    comp.lisp_obj_type,
-						    "lisp_obj_fixnum");
-
-  gcc_jit_block_add_assignment (comp.block,
-				NULL,
-				emit_lval_XLI (res),
-				tmp);
-
-  return gcc_jit_lvalue_as_rvalue (res);
+  return emit_coerce (comp.lisp_obj_type, tmp);
 }
 
 static gcc_jit_rvalue *
@@ -1076,10 +1190,8 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n)
     return XIL (n);
   */
 
-  gcc_jit_rvalue *intmask =
-    emit_coerce (comp.emacs_uint_type,
-		 emit_rvalue_from_long_long ((EMACS_INT_MAX
-					      >> (INTTYPEBITS - 1))));
+  gcc_jit_rvalue *intmask = emit_rvalue_from_emacs_uint (INTMASK);
+
   n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND,
 		      comp.emacs_uint_type,
 		      intmask, n);
@@ -1090,12 +1202,10 @@ emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n)
 		    emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
 				    comp.emacs_uint_type,
 				    comp.lisp_int0,
-				    gcc_jit_context_new_rvalue_from_int (
-				      comp.ctxt,
-				      comp.emacs_uint_type,
-				      VALBITS)),
+                                    emit_rvalue_from_emacs_uint(VALBITS)),
 		    n);
-  return emit_XLI (emit_coerce (comp.emacs_int_type, n));
+
+  return emit_coerce (comp.lisp_obj_type, n);
 }
 
 
@@ -1114,17 +1224,10 @@ emit_const_lisp_obj (Lisp_Object obj)
   emit_comment (format_string ("const lisp obj: %s",
 			       SSDATA (Fprin1_to_string (obj, Qnil))));
 
-  if (NIL_IS_ZERO && EQ (obj, Qnil))
+  if (EQ (obj, Qnil))
     {
       gcc_jit_rvalue *n;
-#ifdef WIDE_EMACS_INT
-      eassert (NIL_IS_ZERO);
-      n = emit_rvalue_from_long_long (0);
-#else
-      n = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
-					       comp.void_ptr_type,
-					       NULL);
-#endif
+      n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil);
       return emit_coerce (comp.lisp_obj_type, n);
     }
 
@@ -1345,16 +1448,7 @@ emit_mvar_val (Lisp_Object mvar)
 	  /* We can still emit directly objects that are self-contained in a
 	     word (read fixnums).  */
 	  emit_comment (SSDATA (Fprin1_to_string (constant, Qnil)));
-	  gcc_jit_rvalue *word;
-#ifdef WIDE_EMACS_INT
-	  word = emit_rvalue_from_long_long (constant);
-#else
-	  word =
-	    gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
-						 comp.void_ptr_type,
-						 XLP (constant));
-#endif
-	  return emit_coerce (comp.lisp_obj_type, word);
+          return emit_rvalue_from_lisp_obj(constant);
 	}
       /* Other const objects are fetched from the reloc array.  */
       return emit_const_lisp_obj (constant);
@@ -2518,11 +2612,16 @@ define_cast_union (void)
 			       NULL,
 			       comp.lisp_cons_ptr_type,
 			       "cons_ptr");
-  comp.cast_union_as_lisp_obj =
+  comp.cast_union_as_lisp_word =
     gcc_jit_context_new_field (comp.ctxt,
 			       NULL,
-			       comp.lisp_obj_type,
-			       "lisp_obj");
+			       comp.lisp_word_type,
+			       "lisp_word");
+  comp.cast_union_as_lisp_word_tag =
+    gcc_jit_context_new_field (comp.ctxt,
+                               NULL,
+                               comp.lisp_word_tag_type,
+                               "lisp_word_tag");
   comp.cast_union_as_lisp_obj_ptr =
     gcc_jit_context_new_field (comp.ctxt,
 			       NULL,
@@ -2543,7 +2642,8 @@ define_cast_union (void)
       comp.cast_union_as_c_p,
       comp.cast_union_as_v_p,
       comp.cast_union_as_lisp_cons_ptr,
-      comp.cast_union_as_lisp_obj,
+      comp.cast_union_as_lisp_word,
+      comp.cast_union_as_lisp_word_tag,
       comp.cast_union_as_lisp_obj_ptr };
   comp.cast_union_type =
     gcc_jit_context_new_union_type (comp.ctxt,
@@ -2810,8 +2910,8 @@ define_add1_sub1 (void)
 					  GCC_JIT_COMPARISON_NE,
 					  n_fixnum,
 					  i == 0
-					  ? emit_most_positive_fixnum ()
-					  : emit_most_negative_fixnum ())),
+					  ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM)
+					  : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))),
 	inline_block,
 	fcall_block);
 
@@ -3307,9 +3407,31 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt,
   comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt,
 						       sizeof (EMACS_UINT),
 						       false);
-  /* No XLP is emitted for now so lets define this always as integer
-     disregarding LISP_WORDS_ARE_POINTERS value.  */
-  comp.lisp_obj_type = comp.emacs_int_type;
+#if LISP_WORDS_ARE_POINTERS
+  comp.lisp_X_s = gcc_jit_context_new_opaque_struct (comp.ctxt,
+                                                     NULL,
+                                                     "Lisp_X");
+  comp.lisp_X = gcc_jit_struct_as_type(comp.lisp_X_s);
+  comp.lisp_word_type = gcc_jit_type_get_pointer(comp.lisp_X);
+#else
+  comp.lisp_word_type = comp.emacs_int_type;
+#endif
+  comp.lisp_word_tag_type
+    = gcc_jit_context_get_int_type (comp.ctxt, sizeof (Lisp_Word_tag), false);
+#ifdef LISP_OBJECT_IS_STRUCT
+  comp.lisp_obj_i = gcc_jit_context_new_field (comp.ctxt,
+                                               NULL,
+                                               comp.lisp_word_type,
+                                               "i");
+  comp.lisp_obj_s = gcc_jit_context_new_struct_type (comp.ctxt,
+                                                     NULL,
+                                                     "Lisp_Object",
+                                                     1,
+                                                     &comp.lisp_obj_i);
+  comp.lisp_obj_type = gcc_jit_struct_as_type (comp.lisp_obj_s);
+#else
+  comp.lisp_obj_type = comp.lisp_word_type;
+#endif
   comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type);
   comp.one =
     gcc_jit_context_new_rvalue_from_int (comp.ctxt,
diff --git a/src/lisp.h b/src/lisp.h
index 834b3e586c..e242546d10 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -299,12 +299,12 @@ #define GCALIGNED(type) (alignof (type) % GCALIGNMENT == 0)
 
 /* Lisp_Word is a scalar word suitable for holding a tagged pointer or
    integer.  Usually it is a pointer to a deliberately-incomplete type
-   'union Lisp_X'.  However, it is EMACS_INT when Lisp_Objects and
+   'struct Lisp_X'.  However, it is EMACS_INT when Lisp_Objects and
    pointers differ in width.  */
 
 #define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX)
 #if LISP_WORDS_ARE_POINTERS
-typedef union Lisp_X *Lisp_Word;
+typedef struct Lisp_X *Lisp_Word;
 #else
 typedef EMACS_INT Lisp_Word;
 #endif
@@ -573,6 +573,7 @@ #define ENUM_BF(TYPE) enum TYPE
 
 #ifdef CHECK_LISP_OBJECT_TYPE
 typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object;
+# define LISP_OBJECT_IS_STRUCT
 # define LISP_INITIALLY(w) {w}
 # undef CHECK_LISP_OBJECT_TYPE
 enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
-- 
2.25.1.windows.1

