Bintegerp support

diff --git a/src/comp.c b/src/comp.c
index 1b1401caff9d032834af3d94dfb14d6241e93d72..f3fd8dc16bbf1a3de2ece32ba5e01ddd57cba99a 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -187,6 +187,7 @@ typedef struct {
   gcc_jit_rvalue *inttypebits;
   gcc_jit_rvalue *lisp_int0;
   gcc_jit_function *pseudovectorp;
+  gcc_jit_function *bool_to_lisp_obj;
   basic_block_t *bblock; /* Current basic block  */
   Lisp_Object func_hash; /* f_name -> gcc_func  */
 } comp_t;
@@ -360,7 +361,7 @@ emit_call (const char *f_name, gcc_jit_type *ret_type, unsigned nargs,
 
 INLINE static void
 emit_cond_jump (gcc_jit_rvalue *test,
-                    gcc_jit_block *then_target, gcc_jit_block *else_target)
+               gcc_jit_block *then_target, gcc_jit_block *else_target)
 {
   gcc_jit_block_end_with_conditional (comp.bblock->gcc_bb,
                                      NULL,
@@ -503,72 +504,6 @@ emit_CONSP (gcc_jit_rvalue *obj)
   return emit_TAGGEDP(obj, Lisp_Cons);
 }
 
-/* Declare a substitute for PSEUDOVECTORP as inline function.  */
-
-static void
-declare_PSEUDOVECTORP (void)
-{
-  gcc_jit_param *param[2] =
-    { gcc_jit_context_new_param (comp.ctxt,
-                                NULL,
-                                comp.lisp_obj_type,
-                                "a"),
-      gcc_jit_context_new_param (comp.ctxt,
-                                NULL,
-                                comp.int_type,
-                                "code") };
-
-  comp.pseudovectorp =
-    gcc_jit_context_new_function (comp.ctxt, NULL,
-                                 GCC_JIT_FUNCTION_ALWAYS_INLINE,
-                                 comp.bool_type,
-                                 "PSEUDOVECTORP",
-                                 2,
-                                 param,
-                                 0);
-
-  gcc_jit_block *initial_block =
-    gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block");
-
-  gcc_jit_block *ret_false_b =
-    gcc_jit_function_new_block (comp.pseudovectorp, "ret_false");
-
-  gcc_jit_block *call_pseudovector_typep_b =
-    gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector");
-
-  /* Set current context as needed */
-  basic_block_t bblock = { .gcc_bb = initial_block,
-                          .terminated = false };
-  comp.bblock = &bblock;
-  comp.func = comp.pseudovectorp;
-
-  emit_cond_jump (
-    emit_cast (comp.bool_type,
-              emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))),
-    call_pseudovector_typep_b,
-    ret_false_b);
-
-  comp.bblock->gcc_bb = ret_false_b;
-  gcc_jit_block_end_with_return (ret_false_b,
-                                NULL,
-                                gcc_jit_context_new_rvalue_from_int(
-                                  comp.ctxt,
-                                  comp.bool_type,
-                                  false));
-
-  gcc_jit_rvalue *args[2] =
-    { gcc_jit_param_as_rvalue (param[0]),
-      gcc_jit_param_as_rvalue (param[1]) };
-  comp.bblock->gcc_bb = call_pseudovector_typep_b;
-  /* FIXME XUNTAG missing here. */
-  gcc_jit_block_end_with_return (call_pseudovector_typep_b,
-                                NULL,
-                                emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG",
-                                           comp.bool_type,
-                                           2,
-                                           args));
-}
-
 static gcc_jit_rvalue *
 emit_BIGNUMP (gcc_jit_rvalue *obj)
 {
@@ -579,10 +514,11 @@ emit_BIGNUMP (gcc_jit_rvalue *obj)
                                         comp.int_type,
                                         PVEC_BIGNUM) };
 
-  return emit_call ("PSEUDOVECTORP",
-                   comp.bool_type,
-                   2,
-                   args);
+  return gcc_jit_context_new_call (comp.ctxt,
+                                  NULL,
+                                  comp.pseudovectorp,
+                                  2,
+                                  args);
 }
 
 static gcc_jit_rvalue *
@@ -651,7 +587,8 @@ emit_INTEGERP (gcc_jit_rvalue *obj)
                                        NULL,
                                        GCC_JIT_BINARY_OP_LOGICAL_OR,
                                        comp.bool_type,
-                                       emit_FIXNUMP (obj),
+                                       emit_cast (comp.bool_type,
+                                                  emit_FIXNUMP (obj)),
                                        emit_BIGNUMP (obj));
 }
 
@@ -687,7 +624,7 @@ emit_make_fixnum (gcc_jit_block *block, gcc_jit_rvalue *obj)
 }
 
 /* Construct fill and return a lisp object form a raw pointer.  */
-
+/* TODO should we pass the bb?  */
 static gcc_jit_rvalue *
 emit_lisp_obj_from_ptr (basic_block_t *bblock, void *p)
 {
@@ -745,16 +682,19 @@ emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args)
 
   for (int i = 0; i < nargs; i++) {
     gcc_jit_rvalue *idx =
-      gcc_jit_context_new_rvalue_from_int (comp.ctxt,
-                                          gcc_jit_context_get_type(comp.ctxt,
-                                                                   GCC_JIT_TYPE_UNSIGNED_INT),
-                                          i);
-    gcc_jit_block_add_assignment (comp.bblock->gcc_bb, NULL,
-                                 gcc_jit_context_new_array_access (comp.ctxt,
-                                                                   NULL,
-                                                                   gcc_jit_lvalue_as_rvalue(p),
-                                                                   idx),
-                                 args[i]);
+      gcc_jit_context_new_rvalue_from_int (
+       comp.ctxt,
+       gcc_jit_context_get_type(comp.ctxt,
+                                GCC_JIT_TYPE_UNSIGNED_INT),
+       i);
+    gcc_jit_block_add_assignment (
+      comp.bblock->gcc_bb,
+      NULL,
+      gcc_jit_context_new_array_access (comp.ctxt,
+                                       NULL,
+                                       gcc_jit_lvalue_as_rvalue(p),
+                                       idx),
+      args[i]);
   }
 
   args[0] = gcc_jit_context_new_rvalue_from_int(comp.ctxt,
@@ -765,6 +705,118 @@ emit_callN (const char *f_name, unsigned nargs, gcc_jit_rvalue **args)
   return emit_call (f_name, comp.lisp_obj_type, 2, args);
 }
 
+/* Declare a substitute for PSEUDOVECTORP as inline function.  */
+
+static void
+declare_PSEUDOVECTORP (void)
+{
+  gcc_jit_param *param[2] =
+    { gcc_jit_context_new_param (comp.ctxt,
+                                NULL,
+                                comp.lisp_obj_type,
+                                "a"),
+      gcc_jit_context_new_param (comp.ctxt,
+                                NULL,
+                                comp.int_type,
+                                "code") };
+
+  comp.pseudovectorp =
+    gcc_jit_context_new_function (comp.ctxt, NULL,
+                                 GCC_JIT_FUNCTION_ALWAYS_INLINE,
+                                 comp.bool_type,
+                                 "PSEUDOVECTORP",
+                                 2,
+                                 param,
+                                 0);
+
+  gcc_jit_block *initial_block =
+    gcc_jit_function_new_block (comp.pseudovectorp, "PSEUDOVECTORP_initial_block");
+
+  gcc_jit_block *ret_false_b =
+    gcc_jit_function_new_block (comp.pseudovectorp, "ret_false");
+
+  gcc_jit_block *call_pseudovector_typep_b =
+    gcc_jit_function_new_block (comp.pseudovectorp, "call_pseudovector");
+
+  /* Set current context as needed */
+  basic_block_t bblock = { .gcc_bb = initial_block,
+                          .terminated = false };
+  comp.bblock = &bblock;
+  comp.func = comp.pseudovectorp;
+
+  emit_cond_jump (
+    emit_cast (comp.bool_type,
+              emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0]))),
+    call_pseudovector_typep_b,
+    ret_false_b);
+
+  comp.bblock->gcc_bb = ret_false_b;
+  gcc_jit_block_end_with_return (ret_false_b,
+                                NULL,
+                                gcc_jit_context_new_rvalue_from_int(
+                                  comp.ctxt,
+                                  comp.bool_type,
+                                  false));
+
+  gcc_jit_rvalue *args[2] =
+    { gcc_jit_param_as_rvalue (param[0]),
+      gcc_jit_param_as_rvalue (param[1]) };
+  comp.bblock->gcc_bb = call_pseudovector_typep_b;
+  /* FIXME XUNTAG missing here. */
+  gcc_jit_block_end_with_return (call_pseudovector_typep_b,
+                                NULL,
+                                emit_call ("helper_PSEUDOVECTOR_TYPEP_XUNTAG",
+                                           comp.bool_type,
+                                           2,
+                                           args));
+}
+
+/* Declare a function to convert boolean into t or nil */
+
+static void
+declare_bool_to_lisp_obj (void)
+{
+  /* x ? Qt : Qnil */
+  gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt,
+                                                   NULL,
+                                                   comp.bool_type,
+                                                   "x");
+  comp.bool_to_lisp_obj =
+    gcc_jit_context_new_function (comp.ctxt, NULL,
+                                 GCC_JIT_FUNCTION_ALWAYS_INLINE,
+                                 comp.lisp_obj_type,
+                                 "bool_to_lisp_obj",
+                                 1,
+                                 &param,
+                                 0);
+  gcc_jit_block *initial_block =
+    gcc_jit_function_new_block (comp.bool_to_lisp_obj,
+                               "bool_to_lisp_obj_initial_block");
+  gcc_jit_block *ret_t_block =
+    gcc_jit_function_new_block (comp.bool_to_lisp_obj,
+                               "ret_t");
+  gcc_jit_block *ret_nil_block =
+    gcc_jit_function_new_block (comp.bool_to_lisp_obj,
+                               "ret_nil");
+  /* Set current context as needed */
+  basic_block_t bblock = { .gcc_bb = initial_block,
+                          .terminated = false };
+  comp.bblock = &bblock;
+  comp.func = comp.bool_to_lisp_obj;
+
+  emit_cond_jump (gcc_jit_param_as_rvalue (param),
+                 ret_t_block,
+                 ret_nil_block);
+  bblock.gcc_bb = ret_t_block;
+  gcc_jit_block_end_with_return (ret_t_block,
+                                NULL,
+                                emit_lisp_obj_from_ptr (&bblock, Qt));
+  bblock.gcc_bb = ret_nil_block;
+  gcc_jit_block_end_with_return (ret_nil_block,
+                                NULL,
+                                emit_lisp_obj_from_ptr (&bblock, Qnil));
+}
+
 static int
 ucmp(const void *a, const void *b)
 {
@@ -1026,6 +1078,7 @@ init_comp (int opt_level)
   comp.func_hash = CALLN (Fmake_hash_table, QCtest, Qequal, QCweakness, Qt);
 
   declare_PSEUDOVECTORP ();
+  declare_bool_to_lisp_obj ();
 }
 
 static void
@@ -1814,7 +1867,13 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length,
          break;
 
        case Bintegerp:
-         error ("Bintegerp not supported");
+         POP1;
+         res = emit_INTEGERP(args[0]);
+         res = gcc_jit_context_new_call (comp.ctxt,
+                                         NULL,
+                                         comp.bool_to_lisp_obj,
+                                         1, &res);
+         PUSH_RVAL (res);
          break;
 
        case BRgoto:

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 63dfafafb04d34c77bb8eda8e85166c6af060fab..d7e6954455bd74590ce83267a2e2dfa673c37d61 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -278,9 +278,26 @@
     ;; Bconsp
     (consp x))
 
+  ;; (byte-compile #'comp-tests-consp-f)
+  ;; (native-compile #'comp-tests-consp-f)
+
   (should (eq (comp-tests-consp-f '(1)) t))
   (should (eq (comp-tests-consp-f 1) nil)))
 
+(ert-deftest comp-tests-num-inline ()
+  "Test some inlined number functions."
+  (defun comp-tests-integerp-f (x)
+    ;; Bintegerp
+    (integerp x))
+
+  (byte-compile #'comp-tests-integerp-f)
+  (native-compile #'comp-tests-integerp-f)
+
+  (should (eq (comp-tests-integerp-f 1) t))
+  (should (eq (comp-tests-integerp-f '(1)) nil))
+  (should (eq (comp-tests-integerp-f 3.5) nil))
+  (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)))
+
 (ert-deftest comp-tests-gc ()
   "Try to do some longer computation to let the gc kick in."
   (dotimes (_ 100000)