feature/native-comp bddd7a2 3/4: Do not emit assumptions referencing clobbered mvars (bug#46670)

[Andrea Corallo]

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

    Do not emit assumptions referencing clobbered mvars (bug#46670)
    
        * lisp/emacs-lisp/comp.el (comp-func): Add `vframe-size' slot.
        (comp-new-frame): Add `vsize' parameter.
        (comp-limplify-top-level, comp-limplify-function): Update for new
        `comp-new-frame'.
        (comp-maybe-add-vmvar): New function.
        (comp-add-cond-cstrs): Logic update to emit assumptions not
        referencing clobbered variables.
        (comp-place-phis, comp-ssa, comp-ssa-rename-insn)
        (comp-ssa-rename): Update rename logic to rename also negative
        slots.
        (comp-fwprop-insn): Update to handle `(assume mvar mvar)' form.
        * test/src/comp-tests.el (46670-1): Add testcase.
        * test/src/comp-test-funcs.el (comp-test-46670-1-f)
        (comp-test-46670-2-f): New functions.
---
 lisp/emacs-lisp/comp.el     | 102 ++++++++++++++++++++++++++++----------------
 test/src/comp-test-funcs.el |   7 +++
 test/src/comp-tests.el      |   6 +++
 3 files changed, 78 insertions(+), 37 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index b6451d5..f18f8e3 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -809,6 +809,7 @@ non local exit (ends with an `unreachable' insn)."))
 Once in SSA form this *must* be set to 'dirty' every time the topology of the
 CFG is mutated by a pass.")
   (frame-size nil :type integer)
+  (vframe-size 0 :type integer)
   (blocks (make-hash-table :test #'eq) :type hash-table
           :documentation "Basic block symbol -> basic block.")
   (lap-block (make-hash-table :test #'equal) :type hash-table
@@ -1468,11 +1469,11 @@ STACK-OFF is the index of the first slot frame 
involved."
       (setf (comp-mvar-typeset mvar) (list type)))
     mvar))
 
-(defun comp-new-frame (size &optional ssa)
+(defun comp-new-frame (size vsize &optional ssa)
   "Return a clean frame of meta variables of size SIZE.
 If SSA non-nil populate it of m-var in ssa form."
-  (cl-loop with v = (make-comp-vec)
-           for i below size
+  (cl-loop with v = (make-comp-vec :beg (- vsize) :end size)
+           for i from (- vsize) below size
            for mvar = (if ssa
                           (make-comp-ssa-mvar :slot i)
                         (make-comp-mvar :slot i))
@@ -2116,7 +2117,7 @@ into the C code forwarding the compilation unit."
          (comp-func func)
          (comp-pass (make-comp-limplify
                      :curr-block (make--comp-block-lap -1 0 'top-level)
-                     :frame (comp-new-frame 1))))
+                     :frame (comp-new-frame 1 0))))
     (comp-make-curr-block 'entry (comp-sp))
     (comp-emit-annotation (if for-late-load
                               "Late top level"
@@ -2177,7 +2178,7 @@ into the C code forwarding the compilation unit."
   (let* ((frame-size (comp-func-frame-size func))
          (comp-func func)
          (comp-pass (make-comp-limplify
-                     :frame (comp-new-frame frame-size))))
+                     :frame (comp-new-frame frame-size 0))))
     (comp-fill-label-h)
     ;; Prologue
     (comp-make-curr-block 'entry (comp-sp))
@@ -2322,6 +2323,18 @@ The assume is emitted at the beginning of the block BB."
       (_ (cl-assert nil)))
     (setf (comp-func-ssa-status comp-func) 'dirty)))
 
+(defun comp-maybe-add-vmvar (op cmp-res insns-seq)
+  "If CMP-RES is clobbering OP emit a new constrained MVAR and return it.
+Return OP otherwise."
+  (if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res)))
+           (new-mvar (make-comp-mvar
+                      :slot
+                      (- (cl-incf (comp-func-vframe-size comp-func))))))
+      (progn
+        (push `(assume ,new-mvar ,op) (cdr insns-seq))
+        new-mvar)
+    op))
+
 (defun comp-add-new-block-between (bb-symbol bb-a bb-b)
   "Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B."
   (cl-loop
@@ -2427,6 +2440,7 @@ TARGET-BB-SYM is the symbol name of the target block."
    do
    (cl-loop
     named in-the-basic-block
+    with prev-insns-seq
     for insns-seq on (comp-block-insns b)
     do
     (pcase insns-seq
@@ -2452,10 +2466,14 @@ TARGET-BB-SYM is the symbol name of the target block."
         (let ((block-target (comp-add-cond-cstrs-target-block b 
branch-target)))
           (setf (car branch-target-cell) (comp-block-name block-target))
           (when (comp-mvar-used-p target-mvar1)
-            (comp-emit-assume kind target-mvar1 op2 block-target negated))
+            (comp-emit-assume kind target-mvar1
+                              (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq)
+                              block-target negated))
           (when (comp-mvar-used-p target-mvar2)
             (comp-emit-assume (comp-reverse-cmp-fun kind)
-                              target-mvar2 op1 block-target negated)))
+                              target-mvar2
+                              (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq)
+                              block-target negated)))
         finally (cl-return-from in-the-basic-block)))
       (`((set ,(and (pred comp-mvar-p) cmp-res)
               (,(pred comp-call-op-p)
@@ -2493,7 +2511,8 @@ TARGET-BB-SYM is the symbol name of the target block."
         (let ((block-target (comp-add-cond-cstrs-target-block b 
branch-target)))
           (setf (car branch-target-cell) (comp-block-name block-target))
           (comp-emit-assume 'and target-mvar cstr block-target negated))
-        finally (cl-return-from in-the-basic-block)))))))
+        finally (cl-return-from in-the-basic-block))))
+    (setf prev-insns-seq insns-seq))))
 
 (defsubst comp-insert-insn (insn insn-cell)
   "Insert INSN as second insn of INSN-CELL."
@@ -2816,7 +2835,8 @@ blocks."
                                (eq op 'fetch-handler))
                         return t)))
 
-    (cl-loop for i from 0 below (comp-func-frame-size comp-func) ; FIXME
+    (cl-loop for i from (- (comp-func-vframe-size comp-func))
+                   below (comp-func-frame-size comp-func)
              ;; List of blocks with a definition of mvar i
              for defs-v = (cl-loop with blocks = (comp-func-blocks comp-func)
                                    for b being each hash-value of blocks
@@ -2854,40 +2874,44 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or 
post-order if non-nil."
 
 (cl-defstruct (comp-ssa (:copier nil))
   "Support structure used while SSA renaming."
-  (frame (comp-new-frame (comp-func-frame-size comp-func) t) :type comp-vec
+  (frame (comp-new-frame (comp-func-frame-size comp-func)
+                         (comp-func-vframe-size comp-func) t)
+         :type comp-vec
          :documentation "`comp-vec' of m-vars."))
 
 (defun comp-ssa-rename-insn (insn frame)
-  (dotimes (slot-n (comp-func-frame-size comp-func))
-    (cl-flet ((targetp (x)
-                ;; Ret t if x is an mvar and target the correct slot number.
-                (and (comp-mvar-p x)
-                     (eql slot-n (comp-mvar-slot x))))
-              (new-lvalue ()
-                ;; If is an assignment make a new mvar and put it as l-value.
-                (let ((mvar (make-comp-ssa-mvar :slot slot-n)))
-                  (setf (comp-vec-aref frame slot-n) mvar
-                        (cadr insn) mvar))))
-      (pcase insn
-        (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_)
-         (let ((mvar (comp-vec-aref frame slot-n)))
-           (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn))))
-         (new-lvalue))
-        (`(fetch-handler . ,_)
-         ;; Clobber all no matter what!
-         (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n)))
-        (`(phi ,n)
-         (when (equal n slot-n)
-           (new-lvalue)))
-        (_
-         (let ((mvar (comp-vec-aref frame slot-n)))
-           (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
+  (cl-loop
+   for slot-n from (- (comp-func-vframe-size comp-func))
+              below (comp-func-frame-size comp-func)
+   do
+   (cl-flet ((targetp (x)
+               ;; Ret t if x is an mvar and target the correct slot number.
+               (and (comp-mvar-p x)
+                    (eql slot-n (comp-mvar-slot x))))
+             (new-lvalue ()
+               ;; If is an assignment make a new mvar and put it as l-value.
+               (let ((mvar (make-comp-ssa-mvar :slot slot-n)))
+                 (setf (comp-vec-aref frame slot-n) mvar
+                       (cadr insn) mvar))))
+     (pcase insn
+       (`(,(pred comp-assign-op-p) ,(pred targetp) . ,_)
+        (let ((mvar (comp-vec-aref frame slot-n)))
+          (setf (cddr insn) (cl-nsubst-if mvar #'targetp (cddr insn))))
+        (new-lvalue))
+       (`(fetch-handler . ,_)
+        ;; Clobber all no matter what!
+        (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n)))
+       (`(phi ,n)
+        (when (equal n slot-n)
+          (new-lvalue)))
+       (_
+        (let ((mvar (comp-vec-aref frame slot-n)))
+          (setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
 
 (defun comp-ssa-rename ()
   "Entry point to rename into SSA within the current function."
   (comp-log "Renaming\n" 2)
-  (let ((frame-size (comp-func-frame-size comp-func))
-        (visited (make-hash-table)))
+  (let ((visited (make-hash-table)))
     (cl-labels ((ssa-rename-rec (bb in-frame)
                   (unless (gethash bb visited)
                     (puthash bb t visited)
@@ -2903,7 +2927,9 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or 
post-order if non-nil."
                        do (ssa-rename-rec child (comp-vec-copy in-frame)))))))
 
       (ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func))
-                      (comp-new-frame frame-size t)))))
+                      (comp-new-frame (comp-func-frame-size comp-func)
+                                      (comp-func-vframe-size comp-func)
+                                      t)))))
 
 (defun comp-finalize-phis ()
   "Fixup r-values into phis in all basic blocks."
@@ -3094,6 +3120,8 @@ Fold the call in case."
           (comp-fwprop-call insn lval f args)))
        (_
         (comp-mvar-propagate lval rval))))
+    (`(assume ,lval ,(and (pred comp-mvar-p) rval))
+     (comp-mvar-propagate lval rval))
     (`(assume ,lval (,kind . ,operands))
      (cl-case kind
        (and
diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el
index 694d9d4..5bae743 100644
--- a/test/src/comp-test-funcs.el
+++ b/test/src/comp-test-funcs.el
@@ -478,6 +478,13 @@
              (eq family 'unspecified))
       family)))
 
+(defun comp-test-46670-1-f (x)
+  "foo")
+
+(defun comp-test-46670-2-f (s)
+  (and (equal (comp-test-46670-1-f (length s)) s)
+       s))
+
 
 ;;;;;;;;;;;;;;;;;;;;
 ;; Tromey's tests ;;
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index f7b5a6b..fa84ffb 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -497,6 +497,12 @@ 
https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html.";
   (load (native-compile (concat comp-test-directory "comp-test-45603.el")))
   (should (fboundp #'comp-test-45603--file-local-name)))
 
+(comp-deftest 46670-1 ()
+  "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>"
+  (should (string= (comp-test-46670-2-f "foo") "foo"))
+  (should (equal (subr-type (symbol-function #'comp-test-46670-2-f))
+                 '(function (t) (or null sequence)))))
+
 
 ;;;;;;;;;;;;;;;;;;;;;
 ;; Tromey's tests. ;;