varset support 5 test passing

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 68bc770ff953f0e5aaf57a64b69557c59b223276..05f17e43d64cb890eb16b3abc9fe596519217f56 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -20,6 +20,10 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
 
+;;; Commentary:
+;; This code is an attempt to make a Carrera out of a turbocharged VW Bug.
+;; Or, to put it another way to make the pig fly.
+
 ;;; Code:
 
 (require 'bytecomp)
@@ -260,8 +264,12 @@ VAL is known at compile time."
        (comp-push-call `(call Fsymbol_value ,(make-comp-mvar
                                               :const-vld t
                                               :constant (cadr inst)))))
-      ;; ('byte-varset
-      ;;  (comp-emit-call `(call Fsymbol_value ,(cadr inst))))
+      ('byte-varset
+       (comp-emit-call `(call set_internal
+                              ,(make-comp-mvar
+                                :const-vld t
+                                :constant (cadr inst))
+                              ,(comp-slot))))
       ('byte-constant
        (comp-push-const (cadr inst)))
       ('byte-stack-ref
@@ -280,6 +288,8 @@ VAL is known at compile time."
        (comp-emit-call `(call Fcar_safe ,(comp-slot))))
       ('byte-cdr-safe
        (comp-emit-call `(call Fcdr_safe ,(comp-slot))))
+      ('byte-length
+       (comp-emit-call `(call Flength ,(comp-slot))))
       ('byte-list1
        (comp-limplify-listn 1))
       ('byte-list2

diff --git a/src/comp.c b/src/comp.c
index cbbc5f0378279dca5db3d7f435776d3970f949cb..25598aa20c1f1ed11c10b1f81138eaa0f3ae80ef 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -966,6 +966,58 @@ emit_mvar_val (Lisp_Object mvar)
     return emit_lisp_obj_from_ptr (FUNCALL1 (comp-mvar-constant, mvar));
 }
 
+static gcc_jit_rvalue *
+emit_limple_call (Lisp_Object arg1)
+{
+  char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1)));
+  Lisp_Object call_args = XCDR (XCDR (arg1));
+  int i = 0;
+
+  if (calle[0] == 'F')
+    {
+      /*
+       Ex: (= #s(comp-mvar 6 1 nil nil nil)
+              (call Fcar #s(comp-mvar 4 0 nil nil nil)))
+
+        Ex: (= #s(comp-mvar 5 0 nil nil cons)
+              (call Fcons #s(comp-mvar 3 0 t 1 nil)
+                          #s(comp-mvar 4 nil t nil nil)))
+      */
+
+      ptrdiff_t nargs = list_length (call_args);
+      gcc_jit_rvalue *gcc_args[nargs];
+      FOR_EACH_TAIL (call_args)
+       gcc_args[i++] = emit_mvar_val (XCAR (call_args));
+
+      return emit_call (calle, comp.lisp_obj_type, nargs, gcc_args);
+    }
+  else if (!strcmp (calle, "set_internal"))
+    {
+      /*
+       Ex: (set #s(comp-mvar 8 1 nil nil nil)
+                 (call set_internal
+                       #s(comp-mvar 7 nil t xxx nil)
+                       #s(comp-mvar 6 1 t 3 nil)))
+      */
+      /* TODO: Inline the most common case.  */
+      eassert (list_length (call_args) == 2);
+      gcc_jit_rvalue *gcc_args[4];
+      FOR_EACH_TAIL (call_args)
+       gcc_args[i++] = emit_mvar_val (XCAR (call_args));
+      gcc_args[2] = emit_lisp_obj_from_ptr (Qnil);
+      gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+                                                        comp.int_type,
+                                                        SET_INTERNAL_SET);
+      gcc_jit_block_add_eval (
+       comp.block,
+       NULL,
+       emit_call ("set_internal", comp.void_type , 4, gcc_args));
+
+      return NULL;
+    }
+  error ("LIMPLE inconsiste call");
+}
+
 static void
 emit_limple_inst (Lisp_Object inst)
 {
@@ -1000,23 +1052,7 @@ emit_limple_inst (Lisp_Object inst)
        }
       else if (EQ (FIRST (arg1), Qcall))
        {
-         /*
-           Ex: (= #s(comp-mvar 6 1 nil nil nil)
-                  (call Fcar #s(comp-mvar 4 0 nil nil nil)))
-
-           Ex: (= #s(comp-mvar 5 0 nil nil cons)
-                  (call Fcons #s(comp-mvar 3 0 t 1 nil)
-                        #s(comp-mvar 4 nil t nil nil)))
-         */
-
-         char *calle = (char *) SDATA (SYMBOL_NAME (SECOND (arg1)));
-         Lisp_Object call_args = XCDR (XCDR (arg1));
-         ptrdiff_t nargs = list_length (call_args);
-         gcc_jit_rvalue *gcc_args[nargs];
-         int i = 0;
-         FOR_EACH_TAIL (call_args)
-           gcc_args[i++] = emit_mvar_val (XCAR (call_args));
-         res = emit_call (calle, comp.lisp_obj_type, nargs, gcc_args);
+         res = emit_limple_call (arg1);
        }
       else if (EQ (FIRST (arg1), Qcallref))
        {
@@ -1038,10 +1074,11 @@ emit_limple_inst (Lisp_Object inst)
        {
          error ("LIMPLE inconsistent arg1 for op =");
        }
-      gcc_jit_block_add_assignment (comp.block,
-                                   NULL,
-                                   comp.frame[slot_n],
-                                   res);
+      if (res)
+       gcc_jit_block_add_assignment (comp.block,
+                                     NULL,
+                                     comp.frame[slot_n],
+                                     res);
     }
   else if (EQ (op, Qsetpar))
     {

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 0aea66f974b2a2799e941b9f17ae1bb8b8d1563c..64edddf4c0422ff6ba9d45f9fe9912bd28142460 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -95,23 +95,23 @@
   (should (= (comp-tests-cons-car-f) 1))
   (should (= (comp-tests-cons-cdr-f 3) 3)))
 
-;; (ert-deftest  comp-tests-varset ()
-;;   "Testing varset."
-;;   (defun comp-tests-varset-f ()
-;;       (setq comp-tests-var1 55))
-;;   (native-compile #'comp-tests-varset-f)
+(ert-deftest comp-tests-varset ()
+  "Testing varset."
+  (defun comp-tests-varset-f ()
+      (setq comp-tests-var1 55))
+  (native-compile #'comp-tests-varset-f)
 
-;;   (comp-tests-varset-f)
+  (comp-tests-varset-f)
 
-;;   (should (= comp-tests-var1 55)))
+  (should (= comp-tests-var1 55)))
 
-;; (ert-deftest  comp-tests-length ()
-;;   "Testing length."
-;;   (defun comp-tests-length-f ()
-;;       (length '(1 2 3)))
-;;   (native-compile #'comp-tests-length-f)
+(ert-deftest comp-tests-length ()
+  "Testing length."
+  (defun comp-tests-length-f ()
+      (length '(1 2 3)))
+  (native-compile #'comp-tests-length-f)
 
-;;   (should (= (comp-tests-length-f) 3)))
+  (should (= (comp-tests-length-f) 3)))
 
 ;; (ert-deftest  comp-tests-aref-aset ()
 ;;   "Testing aref and aset."