From: Andrea Corallo Date: Tue, 23 Feb 2021 13:35:11 +0000 (+0100) Subject: Do not emit assumptions referencing clobbered mvars (bug#46670) X-Git-Tag: emacs-28.0.90~2727^2~128 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=bddd7a2d1376d8ee7a318fc837aaaa98b9d9ce49;p=emacs.git 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. --- diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index b6451d591c5..f18f8e37727 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 694d9d426d5..5bae743d153 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 f7b5a6bbb4c..fa84ffbc0bf 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 () + "" + (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. ;;