Commit bddd7a2d authored by Andrea Corallo's avatar Andrea Corallo
Browse files

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.
parent 89e9b051
......@@ -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
......
......@@ -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 ;;
......
......@@ -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. ;;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment