feature/native-comp 67c443a 4/8: Introduce 'unreachable' LIMPLE operator

[Andrea Corallo]

branch: feature/native-comp
commit 67c443adc1ef8a03d27c6172247e792421bb0e13
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>

    Introduce 'unreachable' LIMPLE operator
    
    Introduce 'unreachable' as LIMPLE operater so we can handle correctly
    in the CFG functions throwing values or signaling errors.
    
        * src/comp.c (retrive_block): Better error diagnostic.
        (emit_limple_insn): Add `unreachable'.
        (compile_function): Fix block iteration.
        (syms_of_comp): Define 'Qunreachable'.
        * lisp/emacs-lisp/comp.el (comp-block): New variable.
        (comp-block-lap): Add `non-ret-insn' slot.
        (comp-branch-op-p): New predicate.
        (comp-limple-lock-keywords): Color `unreachable' as red.
        (comp-compute-edges): Add `unreachable'.
        (comp-fwprop-call): Store non returning function call.
        (comp-fwprop*): Update.
        (comp-clean-orphan-blocks, comp-rewrite-non-locals): New functions.
        (comp-fwprop): Call `comp-rewrite-non-locals'.
        * test/src/comp-tests.el (comp-tests-type-spec-tests): Add two
        tests.
        * test/src/comp-test-funcs.el (comp-test-non-local-1)
        (comp-test-non-local-2, comp-test-non-local-3)
        (comp-test-non-local-4): New functions.
---
 lisp/emacs-lisp/comp.el     | 82 ++++++++++++++++++++++++++++++++++++------
 src/comp.c                  | 47 ++++++++++++++----------
 test/src/comp-test-funcs.el | 16 +++++++++
 test/src/comp-tests.el      | 88 +++++++++++++++++++++++++++------------------
 4 files changed, 171 insertions(+), 62 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index a6704e8..3ef9a6b 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -537,6 +537,9 @@ Useful to hook into pass checkers.")
 (defvar comp-func nil
   "Bound to the current function by most passes.")
 
+(defvar comp-block nil
+  "Bound to the current basic block by some pass.")
+
 (define-error 'native-compiler-error-dyn-func
   "can't native compile a non-lexically-scoped function"
   'native-compiler-error)
@@ -637,13 +640,17 @@ Is in use to help the SSA rename pass."))
                               (:include comp-block)
                               (:constructor make--comp-block-lap
                                             (addr sp name))) ; Positional
-  "A basic block created from lap."
+  "A basic block created from lap (real code)."
   ;; These two slots are used during limplification.
   (sp nil :type number
       :documentation "When non-nil indicates the sp value while entering
 into it.")
   (addr nil :type number
-        :documentation "Start block LAP address."))
+        :documentation "Start block LAP address.")
+  (non-ret-insn nil :type list
+                :documentation "Non returning basic blocks.
+`comp-fwprop' may identify and store here basic blocks performing
+non local exits."))
 
 (cl-defstruct (comp-latch (:copier nil)
                           (:include comp-block))
@@ -843,6 +850,10 @@ To be used by all entry points."
   "Call predicate for OP."
   (when (memq op comp-limple-calls) t))
 
+(defun comp-branch-op-p (op)
+  "Branch predicate for OP."
+  (when (memq op comp-limple-branches) t))
+
 (defsubst comp-limple-insn-call-p (insn)
   "Limple INSN call predicate."
   (comp-call-op-p (car-safe insn)))
@@ -894,7 +905,7 @@ Assume allocation class 'd-default as default."
      (1 font-lock-function-name-face))
     (,(rx bol "(" (group-n 1 "phi"))
      (1 font-lock-variable-name-face))
-    (,(rx bol "(" (group-n 1 "return"))
+    (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
      (1 font-lock-warning-face))
     (,(rx (group-n 1 (or "entry"
                          (seq (or "entry_" "entry_fallback_" "bb_")
@@ -2581,6 +2592,7 @@ blocks."
                  (make-comp-edge :src bb :dst (gethash third blocks))
                  (make-comp-edge :src bb :dst (gethash forth blocks)))
                 (return)
+                (unreachable)
                 (otherwise
                  (signal 'native-ice
                          (list "block does not end with a branch"
@@ -2936,6 +2948,9 @@ Fold the call in case."
             args (cdr args)))
     (when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
       (let ((cstr (comp-cstr-f-ret cstr-f)))
+        (when (comp-cstr-empty-p cstr)
+          ;; Store it to be rewrittein as non local exit.
+          (setf (comp-block-lap-non-ret-insn comp-block) insn))
         (setf (comp-mvar-range lval) (comp-cstr-range cstr)
               (comp-mvar-valset lval) (comp-cstr-valset cstr)
               (comp-mvar-typeset lval) (comp-cstr-typeset cstr)
@@ -2997,15 +3012,61 @@ Fold the call in case."
 Return t if something was changed."
   (cl-loop with modified = nil
            for b being each hash-value of (comp-func-blocks comp-func)
-           do (cl-loop for insn in (comp-block-insns b)
-                       for orig-insn = (unless modified
-                                         ;; Save consing after 1th change.
-                                         (comp-copy-insn insn))
-                       do (comp-fwprop-insn insn)
-                       when (and (null modified) (not (equal insn orig-insn)))
-                         do (setf modified t))
+           do (cl-loop
+               with comp-block = b
+               for insn in (comp-block-insns b)
+               for orig-insn = (unless modified
+                                 ;; Save consing after 1th change.
+                                 (comp-copy-insn insn))
+               do (comp-fwprop-insn insn)
+               when (and (null modified) (not (equal insn orig-insn)))
+                 do (setf modified t))
            finally return modified))
 
+(defun comp-clean-orphan-blocks (block)
+  "Iterativelly remove all non reachable blocks orphaned by BLOCK."
+  (while
+   (cl-loop
+    with repeat = nil
+    with blocks = (comp-func-blocks comp-func)
+    for bb being each hash-value of blocks
+    when (and (not (eq (comp-block-name bb) 'entry))
+              (cl-notany (lambda (ed)
+                           (and (gethash (comp-block-name (comp-edge-src ed))
+                                         blocks)
+                                (not (eq (comp-edge-src ed) block))))
+                         (comp-block-in-edges bb)))
+    do
+    (comp-log (format "Removing block: %s" (comp-block-name bb)) 1)
+    (remhash (comp-block-name bb) blocks)
+    (setf repeat t)
+    finally return repeat)))
+
+(defun comp-rewrite-non-locals ()
+  "Make explicit in LIMPLE non-local exits if identified."
+  (cl-loop
+   for bb being each hash-value of (comp-func-blocks comp-func)
+   for non-local-insn = (and (comp-block-lap-p bb)
+                             (comp-block-lap-non-ret-insn bb))
+   when non-local-insn
+   do
+   (cl-loop
+    for ed in (comp-block-out-edges bb)
+    for dst-bb = (comp-edge-dst ed)
+    ;; Remove one or more block if necessary.
+    when (length= (comp-block-in-edges dst-bb) 1)
+    do
+    (comp-log (format "Removing block: %s" (comp-block-name dst-bb)) 1)
+    (remhash (comp-block-name dst-bb) (comp-func-blocks comp-func))
+    (comp-clean-orphan-blocks bb))
+   ;; Rework the current block.
+   (let* ((insn-seq (memq non-local-insn (comp-block-insns bb))))
+     (setf (comp-block-lap-non-ret-insn bb) ()
+           (comp-block-out-edges bb) ()
+           ;; Prune unnecessary insns!
+           (cdr insn-seq) '((unreachable))
+           (comp-func-ssa-status comp-func) 'dirty))))
+
 (defun comp-fwprop (_)
   "Forward propagate types and consts within the lattice."
   (comp-ssa)
@@ -3024,6 +3085,7 @@ Return t if something was changed."
                      'comp
                      (format "fwprop pass jammed into %s?" (comp-func-name 
f))))
                   (comp-log (format "Propagation run %d times\n" i) 2))
+                 (comp-rewrite-non-locals)
                  (comp-log-func comp-func 3))))
            (comp-ctxt-funcs-h comp-ctxt)))
 
diff --git a/src/comp.c b/src/comp.c
index 04bf997..da43610 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -753,7 +753,7 @@ retrive_block (Lisp_Object block_name)
   Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil);
 
   if (NILP (value))
-    xsignal1 (Qnative_ice, build_string ("missing basic block"));
+    xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name);
 
   return (gcc_jit_block *) xmint_pointer (value);
 }
@@ -2282,6 +2282,13 @@ emit_limple_insn (Lisp_Object insn)
                                     NULL,
                                     emit_mvar_rval (arg[0]));
     }
+  else if (EQ (op, Qunreachable))
+    {
+      /* Libgccjit has no __builtin_unreachable.  */
+      gcc_jit_block_end_with_return (comp.block,
+                                    NULL,
+                                    emit_lisp_obj_rval (Qnil));
+    }
   else
     {
       xsignal2 (Qnative_ice,
@@ -3910,13 +3917,13 @@ compile_function (Lisp_Object func)
      The "entry" block must be declared as first.  */
   declare_block (Qentry);
   Lisp_Object blocks = CALL1I (comp-func-blocks, func);
-  Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil);
   struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks);
-  for (ptrdiff_t i = 0; i < ht->count; i++)
+  for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
     {
-      Lisp_Object block = HASH_VALUE (ht, i);
-      if (!EQ (block, entry_block))
-       declare_block (HASH_KEY (ht, i));
+      Lisp_Object block_name = HASH_KEY (ht, i);
+      if (!EQ (block_name, Qentry)
+         && !EQ (block_name, Qunbound))
+       declare_block (block_name);
     }
 
   gcc_jit_block_add_assignment (retrive_block (Qentry),
@@ -3925,21 +3932,24 @@ compile_function (Lisp_Object func)
                                gcc_jit_lvalue_as_rvalue (comp.func_relocs));
 
 
-  for (ptrdiff_t i = 0; i < ht->count; i++)
+  for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
     {
       Lisp_Object block_name = HASH_KEY (ht, i);
-      Lisp_Object block = HASH_VALUE (ht, i);
-      Lisp_Object insns = CALL1I (comp-block-insns, block);
-      if (NILP (block) || NILP (insns))
-       xsignal1 (Qnative_ice,
-                 build_string ("basic block is missing or empty"));
-
-      comp.block = retrive_block (block_name);
-      while (CONSP (insns))
+      if (!EQ (block_name, Qunbound))
        {
-         Lisp_Object insn = XCAR (insns);
-         emit_limple_insn (insn);
-         insns = XCDR (insns);
+         Lisp_Object block = HASH_VALUE (ht, i);
+         Lisp_Object insns = CALL1I (comp-block-insns, block);
+         if (NILP (block) || NILP (insns))
+           xsignal1 (Qnative_ice,
+                     build_string ("basic block is missing or empty"));
+
+         comp.block = retrive_block (block_name);
+         while (CONSP (insns))
+           {
+             Lisp_Object insn = XCAR (insns);
+             emit_limple_insn (insn);
+             insns = XCDR (insns);
+           }
        }
     }
   const char *err =  gcc_jit_context_get_first_error (comp.ctxt);
@@ -5098,6 +5108,7 @@ compiled one.  */);
   DEFSYM (Qassume, "assume");
   DEFSYM (Qsetimm, "setimm");
   DEFSYM (Qreturn, "return");
+  DEFSYM (Qunreachable, "unreachable");
   DEFSYM (Qcomp_mvar, "comp-mvar");
   DEFSYM (Qcond_jump, "cond-jump");
   DEFSYM (Qphi, "phi");
diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el
index 49e8076..1c2fb3d 100644
--- a/test/src/comp-test-funcs.el
+++ b/test/src/comp-test-funcs.el
@@ -621,6 +621,22 @@
        (load (if (file-exists-p dest) dest filename)))
       'no-byte-compile)))
 
+(defun comp-test-no-return-1 (x)
+  (while x
+   (error "foo")))
+
+(defun comp-test-no-return-2 (x)
+  (cond
+   ((eql x '2) t)
+   ((error "bar") nil)))
+
+(defun comp-test-no-return-3 ())
+(defun comp-test-no-return-4 (x)
+  (when x
+    (error "foo")
+    (while (comp-test-no-return-3)
+      (comp-test-no-return-3))))
+
 (provide 'comp-test-funcs)
 
 ;;; comp-test-funcs.el ends here
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 4546ecc..9801136 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -949,50 +949,50 @@ Return a list of results."
 
       ;; 22
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (> x 3)
-           x))
+        (when (> x 3)
+          x))
        (or null float (integer 4 *)))
 
       ;; 23
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (>= x 3)
-           x))
+        (when (>= x 3)
+          x))
        (or null float (integer 3 *)))
 
       ;; 24
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (< x 3)
-           x))
+        (when (< x 3)
+          x))
        (or null float (integer * 2)))
 
       ;; 25
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (<= x 3)
-           x))
+        (when (<= x 3)
+          x))
        (or null float (integer * 3)))
 
       ;; 26
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (> 3 x)
-           x))
+        (when (> 3 x)
+          x))
        (or null float (integer * 2)))
 
       ;; 27
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (>= 3 x)
-           x))
+        (when (>= 3 x)
+          x))
        (or null float (integer * 3)))
 
       ;; 28
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (< 3 x)
-           x))
+        (when (< 3 x)
+          x))
        (or null float (integer 4 *)))
 
       ;; 29
       ((defun comp-tests-ret-type-spec-f (x)
-         (when (<= 3 x)
-           x))
+        (when (<= 3 x)
+          x))
        (or null float (integer 3 *)))
 
       ;; 30
@@ -1032,8 +1032,8 @@ Return a list of results."
 
       ;; 35 No float range support.
       ((defun comp-tests-ret-type-spec-f (x)
-              (when (> x 1.0)
-                x))
+        (when (> x 1.0)
+          x))
        (or null marker number))
 
       ;; 36
@@ -1061,17 +1061,17 @@ Return a list of results."
       ;; 39
       ;; SBCL gives: (OR REAL NULL)
       ((defun comp-tests-ret-type-spec-f (x y)
-                   (when (and (<= 1 x 10)
-                              (<= 2 y 3))
-                     (+ x y)))
+        (when (and (<= 1 x 10)
+                   (<= 2 y 3))
+          (+ x y)))
        (or null float (integer 3 13)))
 
       ;; 40
       ;; SBCL: (OR REAL NULL)
       ((defun comp-tests-ret-type-spec-f (x y)
-                   (when (and (<= 1 x 10)
-                              (<= 2 y 3))
-                     (- x y)))
+        (when (and (<= 1 x 10)
+                   (<= 2 y 3))
+          (- x y)))
        (or null float (integer -2 8)))
 
       ;; 41
@@ -1090,23 +1090,23 @@ Return a list of results."
 
       ;; 43
       ((defun comp-tests-ret-type-spec-f (x y)
-                   (when (and (<= x 10)
-                              (<= 2 y))
-                     (- x y)))
+        (when (and (<= x 10)
+                   (<= 2 y))
+          (- x y)))
        (or null float (integer * 8)))
 
       ;; 44
       ((defun comp-tests-ret-type-spec-f (x y)
-          (when (and (<= x 10)
-                     (<= y 3))
-            (- x y)))
+         (when (and (<= x 10)
+                    (<= y 3))
+           (- x y)))
        (or null float integer))
 
       ;; 45
       ((defun comp-tests-ret-type-spec-f (x y)
-          (when (and (<= 2 x)
-                     (<= 3 y))
-            (- x y)))
+         (when (and (<= 2 x)
+                    (<= 3 y))
+           (- x y)))
        (or null float integer))
 
       ;; 46
@@ -1176,7 +1176,27 @@ Return a list of results."
       ((defun comp-tests-ret-type-spec-f (x)
          (unless (integerp x)
            x))
-       (not integer))))
+       (not integer))
+
+      ;; 56
+      ((defun comp-tests-ret-type-spec-f (x)
+         (cl-ecase x
+           (1 (message "one"))
+           (5 (message "five")))
+         x)
+       t
+       ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block
+       ;; boundary if necessary as this should return:
+       ;; (or (integer 1 1) (integer 5 5))
+       )
+
+      ;; 57
+      ((defun comp-tests-ret-type-spec-f (x)
+         (unless (or (eq x 'foo)
+                    (= x 3))
+           (error "Not foo or 3"))
+         x)
+       (or (member foo) (integer 3 3)))))
 
   (defun comp-tests-define-type-spec-test (number x)
     `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()