inline setcdr support

diff --git a/src/comp.c b/src/comp.c
index 538169c0b2a5fb4bff1a8b9b4c5ff9e68c089ca1..f31be0426f18be2f5416b4e43e9ed4196691dce1 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -254,6 +254,7 @@ typedef struct {
   gcc_jit_function *car;
   gcc_jit_function *cdr;
   gcc_jit_function *setcar;
+  gcc_jit_function *setcdr;
   gcc_jit_function *check_type;
   gcc_jit_function *check_impure;
   basic_block_t *block; /* Current basic block  */
@@ -918,6 +919,31 @@ emit_XCDR (gcc_jit_rvalue *c)
       comp.lisp_cons_u_s_u_cdr);
 }
 
+static gcc_jit_lvalue *
+emit_lval_XCDR (gcc_jit_rvalue *c)
+{
+  emit_comment ("lval_XCDR");
+
+  /* XCONS (c)->u.s.u.cdr */
+  return
+    gcc_jit_lvalue_access_field (
+      /* XCONS (c)->u.s.u */
+      gcc_jit_lvalue_access_field (
+       /* XCONS (c)->u.s */
+       gcc_jit_lvalue_access_field (
+         /* XCONS (c)->u */
+         gcc_jit_rvalue_dereference_field (
+           emit_XCONS (c),
+           NULL,
+           comp.lisp_cons_u),
+         NULL,
+         comp.lisp_cons_u_s),
+       NULL,
+       comp.lisp_cons_u_s_u),
+      NULL,
+      comp.lisp_cons_u_s_u_cdr);
+}
+
 static void
 emit_CHECK_CONS (gcc_jit_rvalue *x)
 {
@@ -946,6 +972,14 @@ emit_car_addr (gcc_jit_rvalue *c)
   return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL);
 }
 
+static gcc_jit_rvalue *
+emit_cdr_addr (gcc_jit_rvalue *c)
+{
+  emit_comment ("cdr_addr");
+
+  return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL);
+}
+
 static void
 emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
 {
@@ -960,6 +994,20 @@ emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
     n);
 }
 
+static void
+emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
+{
+  emit_comment ("XSETCDR");
+
+  gcc_jit_block_add_assignment(
+    comp.block->gcc_bb,
+    NULL,
+    gcc_jit_rvalue_dereference (
+      emit_cdr_addr (c),
+      NULL),
+    n);
+}
+
 static gcc_jit_rvalue *
 emit_PURE_P (gcc_jit_rvalue *ptr)
 {
@@ -1471,62 +1519,73 @@ define_CAR_CDR (void)
 }
 
 static void
-define_setcar (void)
+define_setcar_setcdr (void)
 {
   USE_SAFE_ALLOCA;
 
-  gcc_jit_param *cell =
-    gcc_jit_context_new_param (comp.ctxt,
-                              NULL,
-                              comp.lisp_obj_type,
-                              "cell");
-  gcc_jit_param *new_car =
-    gcc_jit_context_new_param (comp.ctxt,
-                              NULL,
-                              comp.lisp_obj_type,
-                              "new_car");
-
-  gcc_jit_param *param[] = { cell, new_car };
-  comp.setcar =
-    gcc_jit_context_new_function (comp.ctxt, NULL,
-                                 GCC_JIT_FUNCTION_ALWAYS_INLINE,
-                                 comp.lisp_obj_type,
-                                 "setcar",
-                                 2,
-                                 param,
-                                 0);
+  char const *f_name[] = {"setcar", "setcdr"};
+  char const *par_name[] = {"new_car", "new_cdr"};
 
-  DECL_AND_SAFE_ALLOCA_BLOCK (init_block, comp.setcar);
-  comp.block = init_block;
-  comp.func = comp.setcar;
+  for (int i = 0; i < 2; i++)
+    {
+      gcc_jit_param *cell =
+       gcc_jit_context_new_param (comp.ctxt,
+                                  NULL,
+                                  comp.lisp_obj_type,
+                                  "cell");
+      gcc_jit_param *new_el =
+       gcc_jit_context_new_param (comp.ctxt,
+                                  NULL,
+                                  comp.lisp_obj_type,
+                                  par_name[i]);
+
+      gcc_jit_param *param[] = { cell, new_el };
+
+      gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr;
+      *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL,
+                                            GCC_JIT_FUNCTION_ALWAYS_INLINE,
+                                            comp.lisp_obj_type,
+                                            f_name[i],
+                                            2,
+                                            param,
+                                            0);
+      DECL_AND_SAFE_ALLOCA_BLOCK (init_block, *f_ref);
+      comp.func = *f_ref;
+      comp.block = init_block;
 
-  /* CHECK_CONS (cell); */
-  emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell));
+      /* CHECK_CONS (cell); */
+      emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell));
 
-  /* CHECK_IMPURE (cell, XCONS (cell)); */
-  gcc_jit_rvalue *args[] =
-    { gcc_jit_param_as_rvalue (cell),
-      emit_XCONS (gcc_jit_param_as_rvalue (cell)) };
+      /* CHECK_IMPURE (cell, XCONS (cell)); */
+      gcc_jit_rvalue *args[] =
+       { gcc_jit_param_as_rvalue (cell),
+         emit_XCONS (gcc_jit_param_as_rvalue (cell)) };
 
-  gcc_jit_block_add_eval (
-    init_block->gcc_bb,
-    NULL,
-    gcc_jit_context_new_call (comp.ctxt,
+      gcc_jit_block_add_eval (
+                             init_block->gcc_bb,
                              NULL,
-                             comp.check_impure,
-                             2,
-                             args));
-
-  /* XSETCAR (cell, newcar); */
-  emit_XSETCAR (gcc_jit_param_as_rvalue (cell),
-               gcc_jit_param_as_rvalue (new_car));
+                             gcc_jit_context_new_call (comp.ctxt,
+                                                       NULL,
+                                                       comp.check_impure,
+                                                       2,
+                                                       args));
+
+      /* XSETCDR (cell, newel); */
+      if (!i)
+       emit_XSETCAR (gcc_jit_param_as_rvalue (cell),
+                     gcc_jit_param_as_rvalue (new_el));
+      else
+       emit_XSETCDR (gcc_jit_param_as_rvalue (cell),
+                     gcc_jit_param_as_rvalue (new_el));
 
-  /* return newcar; */
-  gcc_jit_block_end_with_return (init_block->gcc_bb,
-                                NULL,
-                                gcc_jit_param_as_rvalue (new_car));
+      /* return newel; */
+      gcc_jit_block_end_with_return (init_block->gcc_bb,
+                                    NULL,
+                                    gcc_jit_param_as_rvalue (new_el));
+    }
   SAFE_FREE ();
 }
+
 /* Declare a substitute for PSEUDOVECTORP as always inlined function.  */
 
 static void
@@ -1942,7 +2001,7 @@ init_comp (int opt_level)
   define_CHECK_TYPE ();
   define_CHECK_IMPURE ();
   define_bool_to_lisp_obj ();
-  define_setcar();
+  define_setcar_setcdr();
 }
 
 static void
@@ -2885,7 +2944,14 @@ compile_f (const char *f_name, ptrdiff_t bytestr_length,
          PUSH_RVAL (res);
          break;
 
-       CASE_CALL_N (setcdr, 2);
+       case Bsetcdr:
+         POP2;
+         res = gcc_jit_context_new_call (comp.ctxt,
+                                         NULL,
+                                         comp.setcdr,
+                                         2, args);
+         PUSH_RVAL (res);
+         break;
 
        CASE (Bcar_safe);
          EMIT_CALL_N ("CAR_SAFE", 1);

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 47c61c82bdddb25bd970d34edc806287f06f73b6..d2b8f56d36ff81ae506ace0a8a01e3739d2107ad 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -289,6 +289,11 @@
                      err
                      (comp-tests-setcar-f 3 10)
                    (error err))
+                 '(wrong-type-argument consp 3)))
+  (should (equal (condition-case
+                     err
+                     (comp-tests-setcdr-f 3 10)
+                   (error err))
                  '(wrong-type-argument consp 3))))
 
 (defun comp-bubble-sort ()