feature/native-comp 42970cc 2/5: Add new cond-rw pass to have forward propagation track cond branches

[Andrea Corallo]

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

    Add new cond-rw pass to have forward propagation track cond branches
    
    Add a new pass to rewrite conditional branches.  This is introducing
    and placing a new LIMPLE operator 'assume' in use by fwprop to
    propagate conditional branch test informations on target basic blocks.
    
        * lisp/emacs-lisp/comp.el (comp-passes): Add `comp-cond-rw'.
        (comp-limple-assignments): Add `assume' operator.
        (comp-emit-assume, comp-cond-rw-target-slot, comp-cond-rw-func)
        (comp-cond-rw): Add new functions.
        (comp-fwprop-insn): Update to pattern match `assume' insns.
        * src/comp.c (emit_limple_insn): Add for `assume'.
        (syms_of_comp): Define 'Qassume' symbol.
---
 lisp/emacs-lisp/comp.el | 83 ++++++++++++++++++++++++++++++++++++++++++++++++-
 src/comp.c              |  5 +--
 2 files changed, 85 insertions(+), 3 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 15b8b3a..9b26f6c 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -171,6 +171,7 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'.  
See `comp-ctxt'.")
                         comp-fwprop
                         comp-call-optim
                         comp-ipa-pure
+                        comp-cond-rw
                         comp-fwprop
                         comp-dead-code
                         comp-tco
@@ -216,7 +217,8 @@ Useful to hook into pass checkers.")
                              set-rest-args-to-local)
   "Limple set operators.")
 
-(defconst comp-limple-assignments `(fetch-handler
+(defconst comp-limple-assignments `(assume
+                                    fetch-handler
                                     ,@comp-limple-sets)
   "Limple operators that clobbers the first m-var argument.")
 
@@ -1677,6 +1679,73 @@ into the C code forwarding the compilation unit."
     (comp-add-func-to-ctxt (comp-limplify-top-level t))))
 
 
+;;; conditional branches rewrite pass specific code.
+
+(defun comp-emit-assume (target-slot rhs bb-name kind)
+  "Emit an assume of kind KIND for TARGET-SLOT being RHS.
+The assume is emitted at the beginning of the block named
+BB-NAME."
+  (push `(assume ,(make-comp-mvar :slot target-slot) ,rhs ,kind)
+       (comp-block-insns (gethash bb-name (comp-func-blocks comp-func))))
+  (setf (comp-func-ssa-status comp-func) 'dirty))
+
+(defun comp-cond-rw-target-slot (slot-num exit-insn bb)
+  "Search for the last assignment of SLOT-NUM in BB.
+Keep on searching till EXIT-INSN is encountered.
+Return the corresponding rhs slot number."
+  (cl-flet ((targetp (x)
+              ;; Ret t if x is an mvar and target the correct slot number.
+              (and (comp-mvar-p x)
+                   (eql slot-num (comp-mvar-slot x)))))
+    (cl-loop
+     with res = nil
+     for insn in (comp-block-insns bb)
+     when (eq insn exit-insn)
+     do (cl-return (and (comp-mvar-p res) (comp-mvar-slot res)))
+     do (pcase insn
+          (`(,(pred comp-assign-op-p) ,(pred targetp) ,rhs)
+           (setf res rhs)))
+     finally (cl-assert nil))))
+
+(defun comp-cond-rw-func ()
+  "`comp-cond-rw' worker function for each selected function."
+  (cl-loop
+   for b being each hash-value of (comp-func-blocks comp-func)
+   do (cl-loop
+       named in-the-basic-block
+       for insns-seq on (comp-block-insns b)
+       do (pcase insns-seq
+            (`((set ,(and (pred comp-mvar-p) cond)
+                    (,(pred comp-call-op-p)
+                     ,(and (or 'eq 'eql '= 'equal) test-fn) ,op1 ,op2))
+              (comment ,_comment-str)
+              (cond-jump ,cond ,(pred comp-mvar-p) ,bb-1 ,_bb-2))
+             (when-let ((target-slot1 (comp-cond-rw-target-slot
+                                      (comp-mvar-slot op1) (car insns-seq) b)))
+              (comp-emit-assume target-slot1 op2 bb-1 test-fn))
+             (when-let ((target-slot2 (comp-cond-rw-target-slot
+                                      (comp-mvar-slot op2) (car insns-seq) b)))
+              (comp-emit-assume target-slot2 op1 bb-1 test-fn))
+            (cl-return-from in-the-basic-block))))))
+
+(defun comp-cond-rw (_)
+  "Rewrite conditional branches adding appropriate 'assume' insns.
+This is introducing and placing 'assume' insns in use by fwprop
+to propagate conditional branch test informations on target basic
+blocks."
+  (maphash (lambda (_ f)
+             (when (and (>= (comp-func-speed f) 1)
+                        ;; No point to run this on dynamic scope as
+                        ;; this pass is effecive only on local
+                        ;; variables.
+                       (comp-func-l-p f)
+                        (not (comp-func-has-non-local f)))
+               (let ((comp-func f))
+                 (comp-cond-rw-func)
+                 (comp-log-func comp-func 3))))
+           (comp-ctxt-funcs-h comp-ctxt)))
+
+
 ;;; pure-func pass specific code.
 
 ;; Simple IPA pass to infer function purity of functions not
@@ -2158,6 +2227,18 @@ Forward propagate immediate involed in assignments."
           (comp-function-call-maybe-remove insn f args)))
        (_
         (comp-mvar-propagate lval rval))))
+    (`(assume ,lval ,rval ,kind)
+     (pcase kind
+       ('eq
+        (comp-mvar-propagate lval rval))
+       ((or 'eql 'equal)
+        (if (memq (comp-mvar-type rval) '(symbol fixnum))
+            (comp-mvar-propagate lval rval)
+          (setf (comp-mvar-type lval) (comp-mvar-type rval))))
+       ('=
+        (if (eq (comp-mvar-type rval) 'fixnum)
+            (comp-mvar-propagate lval rval)
+          (setf (comp-mvar-type lval) 'number)))))
     (`(setimm ,lval ,v)
      (setf (comp-mvar-const-vld lval) t
            (comp-mvar-constant lval) v
diff --git a/src/comp.c b/src/comp.c
index 0c55557..48e4f1c 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -2131,9 +2131,9 @@ emit_limple_insn (Lisp_Object insn)
                               n);
       emit_cond_jump (test, target2, target1);
     }
-  else if (EQ (op, Qphi))
+  else if (EQ (op, Qphi) || EQ (op, Qassume))
     {
-      /* Nothing to do for phis into the backend.  */
+      /* Nothing to do for phis or assumes in the backend.  */
     }
   else if (EQ (op, Qpush_handler))
     {
@@ -5134,6 +5134,7 @@ native compiled one.  */);
   DEFSYM (Qcallref, "callref");
   DEFSYM (Qdirect_call, "direct-call");
   DEFSYM (Qdirect_callref, "direct-callref");
+  DEFSYM (Qassume, "assume");
   DEFSYM (Qsetimm, "setimm");
   DEFSYM (Qreturn, "return");
   DEFSYM (Qcomp_mvar, "comp-mvar");