add limple switch support

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 69f43822948ce07a29628dfa0ef23f93bbc85bc0..4841753172f735aeb1ab5f8adb711b0ae003090f 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -355,11 +355,11 @@ If DST-N is specified use it otherwise assume it to be the current slot."
           (comp-block-sp (gethash block-name blocks)))
     (setf (comp-limplify-block-name comp-pass) block-name)))
 
-(defun comp-emit-cond-jump (target-offset lap-label negated)
-  "Emit a conditional jump to LAP-LABEL.
+(defun comp-emit-cond-jump (a b target-offset lap-label negated)
+  "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ.
 TARGET-OFFSET is the positive offset on the SP when branching to the target
 block.
-If NEGATED non nil negate the test condition."
+If NEGATED non nil negate the tested condition."
   (let ((blocks (comp-func-blocks comp-func))
         (bb (comp-new-block-sym))) ;; Fall through block
     (puthash bb
@@ -367,8 +367,8 @@ If NEGATED non nil negate the test condition."
             blocks)
     (let ((target (comp-lap-to-limple-bb lap-label)))
       (comp-emit (if negated
-                    (list 'cond-jump (comp-slot-next) target bb)
-                  (list 'cond-jump (comp-slot-next) bb target)))
+                    (list 'cond-jump a b target bb)
+                  (list 'cond-jump a b bb target)))
       (puthash target
               (make-comp-block :sp (+ target-offset (comp-sp)))
               blocks)
@@ -423,6 +423,14 @@ If NEGATED non nil negate the test condition."
            (comp-mark-block-closed)
            (comp-emit-block guarded-bb))))
 
+(defun comp-emit-switch (var m-hash)
+  "Emit a limple for a lap jump table given VAR and M-HASH."
+  (cl-assert (comp-mvar-const-vld m-hash))
+  (cl-loop for test being each hash-keys of (comp-mvar-constant m-hash)
+           using (hash-value target-label)
+           for m-test = (make-comp-mvar :constant test)
+           do (comp-emit-cond-jump var m-test 0 target-label nil)))
+
 (defmacro comp-op-case (&rest cases)
   "Expand CASES into the corresponding pcase.
 This is responsible for generating the proper stack adjustment when known and
@@ -583,13 +591,17 @@ the annotation emission."
       (byte-goto
        (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn))))
       (byte-goto-if-nil
-       (comp-emit-cond-jump 0 (cl-third insn) nil))
+       (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0
+                            (cl-third insn) nil))
       (byte-goto-if-not-nil
-       (comp-emit-cond-jump 0 (cl-third insn) t))
+       (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0
+                            (cl-third insn) t))
       (byte-goto-if-nil-else-pop
-       (comp-emit-cond-jump 1 (cl-third insn) nil))
+       (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1
+                            (cl-third insn) nil))
       (byte-goto-if-not-nil-else-pop
-       (comp-emit-cond-jump 1 (cl-third insn) t))
+       (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1
+                            (cl-third insn) t))
       (byte-return
        (comp-emit (list 'return (comp-slot-next)))
        (comp-mark-block-closed))
@@ -642,7 +654,8 @@ the annotation emission."
       (byte-stack-set2)
       (byte-discardN
        (comp-stack-adjust (- arg)))
-      (byte-switch)
+      (byte-switch
+       (comp-emit-switch (comp-slot-next) (comp-slot-n (+ 2 (comp-sp)))))
       (byte-constant
        (comp-emit-set-const arg))
       (byte-discardN-preserve-tos

diff --git a/src/comp.c b/src/comp.c
index 6436a5db7128b6bd5591fb25f290f7f806011db6..e4483ea4206b1d6a44143d21c7f3b3e555ea9041 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -1128,11 +1128,12 @@ emit_limple_insn (Lisp_Object insn)
   else if (EQ (op, Qcond_jump))
     {
       /* Conditional branch.  */
-      gcc_jit_rvalue *test = emit_mvar_val (arg0);
-      gcc_jit_block *target1 = retrive_block (SECOND (args));
-      gcc_jit_block *target2 = retrive_block (THIRD (args));
+      gcc_jit_rvalue *a = emit_mvar_val (arg0);
+      gcc_jit_rvalue *b =  emit_mvar_val (SECOND (args));
+      gcc_jit_block *target1 = retrive_block (THIRD (args));
+      gcc_jit_block *target2 = retrive_block (FORTH (args));
 
-      emit_cond_jump (emit_NILP (test), target2, target1);
+      emit_cond_jump (emit_EQ (a, b), target2, target1);
     }
   else if (EQ (op, Qpush_handler))
     {

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index ed3a9b2f9d0177aed18fbaa0c6325c6def054f1f..58846ed50d05d9a813f2a19d5fb44029a79da76c 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -200,18 +200,19 @@
 
   (should (= (comp-tests-ffuncall-lambda-f 1) 2)))
 
-;; (ert-deftest  comp-tests-jump-table ()
-;;   "Testing jump tables"
-;;   (defun comp-tests-jump-table-1-f (x)
-;;     (pcase x
-;;       ('x 'a)
-;;       ('y 'b)
-;;       (_ 'c)))
-
-
-;;   (should (eq (comp-tests-jump-table-1-f 'x) 'a))
-;;   (should (eq (comp-tests-jump-table-1-f 'y) 'b))
-;;   (should (eq (comp-tests-jump-table-1-f 'xxx) 'c)))
+(ert-deftest  comp-tests-jump-table ()
+  "Testing jump tables"
+  (defun comp-tests-jump-table-1-f (x)
+    (pcase x
+      ('x 'a)
+      ('y 'b)
+      (_ 'c)))
+
+  (native-compile #'comp-tests-jump-table-1-f)
+
+  (should (eq (comp-tests-jump-table-1-f 'x) 'a))
+  (should (eq (comp-tests-jump-table-1-f 'y) 'b))
+  (should (eq (comp-tests-jump-table-1-f 'xxx) 'c)))
 
 (ert-deftest  comp-tests-conditionals ()
   "Testing conditionals."