feature/native-comp cf105f6 1/2: * Fix bug#41112

[Andrea Corallo]

branch: feature/native-comp
commit cf105f604413d270c956adf375217960e3945e2a
Author: Andrea Corallo <address@hidden>
Commit: Andrea Corallo <address@hidden>

    * Fix bug#41112
    
        * lisp/emacs-lisp/comp.el (comp-jump-table-optimizable): New
        function.
        (comp-emit-switch): Make use of 'comp-jump-table-optimizable'.
---
 lisp/emacs-lisp/comp.el | 72 ++++++++++++++++++++++++++++---------------------
 1 file changed, 42 insertions(+), 30 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 60b41f9..6164103 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -850,44 +850,56 @@ Return value is the fall through block name."
                 (`(TAG ,label . ,_)
                  (puthash label addr (comp-limplify-label-to-addr 
comp-pass))))))
 
+(defun comp-jump-table-optimizable (jmp-table)
+  "Return t if JMP-TABLE can be optimized out."
+  (cl-loop
+   with labels = (cl-loop for target-label being each hash-value of jmp-table
+                          collect target-label)
+   with x = (car labels)
+   for l in (cdr-safe labels)
+   unless (= l x)
+     return nil
+   finally return t))
+
 (defun comp-emit-switch (var last-insn)
   "Emit a limple for a lap jump table given VAR and LAST-INSN."
   ;; FIXME this not efficient for big jump tables. We should have a second
   ;; strategy for this case.
   (pcase last-insn
     (`(setimm ,_ ,jmp-table)
-     (cl-loop
-      for test being each hash-keys of jmp-table
-      using (hash-value target-label)
-      with len = (hash-table-count jmp-table)
-      with test-func = (hash-table-test jmp-table)
-      for n from 1
-      for last = (= n len)
-      for m-test = (make-comp-mvar :constant test)
-      for target-name = (comp-block-name (comp-bb-maybe-add 
(comp-label-to-addr target-label)
-                                                            (comp-sp)))
-      for ff-bb = (if last
-                      (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
-                                         (comp-sp))
-                    (make--comp-block nil
-                                      (comp-sp)
-                                      (comp-new-block-sym)))
-      for ff-bb-name = (comp-block-name ff-bb)
-      if (eq test-func 'eq)
-        do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name))
-      else
+     (unless (comp-jump-table-optimizable jmp-table)
+       (cl-loop
+        for test being each hash-keys of jmp-table
+        using (hash-value target-label)
+        with len = (hash-table-count jmp-table)
+        with test-func = (hash-table-test jmp-table)
+        for n from 1
+        for last = (= n len)
+        for m-test = (make-comp-mvar :constant test)
+        for target-name = (comp-block-name (comp-bb-maybe-add 
(comp-label-to-addr target-label)
+                                                              (comp-sp)))
+        for ff-bb = (if last
+                        (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+                                           (comp-sp))
+                      (make--comp-block nil
+                                        (comp-sp)
+                                        (comp-new-block-sym)))
+        for ff-bb-name = (comp-block-name ff-bb)
+        if (eq test-func 'eq)
+          do (comp-emit (list 'cond-jump var m-test ff-bb-name target-name))
+        else
         ;; Store the result of the comparison into the scratch slot before
         ;; emitting the conditional jump.
-        do (comp-emit (list 'set (make-comp-mvar :slot 'scratch)
-                            (comp-call test-func var m-test)))
-           (comp-emit (list 'cond-jump
-                            (make-comp-mvar :slot 'scratch)
-                            (make-comp-mvar :constant nil)
-                            target-name ff-bb-name))
-      do (unless last
-           ;; All fall through are artificially created here except the last 
one.
-           (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
-           (setf (comp-limplify-curr-block comp-pass) ff-bb))))
+          do (comp-emit (list 'set (make-comp-mvar :slot 'scratch)
+                              (comp-call test-func var m-test)))
+             (comp-emit (list 'cond-jump
+                              (make-comp-mvar :slot 'scratch)
+                              (make-comp-mvar :constant nil)
+                              target-name ff-bb-name))
+        unless last
+        ;; All fall through are artificially created here except the last one.
+          do (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
+             (setf (comp-limplify-curr-block comp-pass) ff-bb))))
     (_ (signal 'native-ice
                "missing previous setimm while creating a switch"))))