diff options
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 80 | ||||
| -rw-r--r-- | test/src/comp-tests.el | 4 |
2 files changed, 73 insertions, 11 deletions
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e8db2383c41..6f1ef26ac78 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1868,7 +1868,19 @@ into the C code forwarding the compilation unit." (comp-add-func-to-ctxt (comp-limplify-top-level t)))) -;;; conditional branches rewrite pass specific code. +;;; add-cstrs pass specific code. + +;; This pass is responsible for adding constraints, these are +;; generated from: +;; +;; - Conditional branches: each branch taken or non taken can be used +;; in the CFG to infer infomations on the tested variables. +;; +;; - Function calls: function calls to function assumed to be not +;; redefinable can be used to add constrains on the function +;; arguments. Ex: if we execute successfully (= x y) we know that +;; afterwards both x and y must satisfy the (or number marker) +;; type specifier. (defun comp-emit-assume (target rhs bb negated) "Emit an assume for mvar TARGET being RHS. @@ -1907,10 +1919,10 @@ The assume is emitted at the beginning of the block BB." (cl-return (puthash bb-symbol new-bb (comp-func-blocks comp-func))) finally (cl-assert nil))) -(defun comp-add-cond-cstrs-target-mvar (mvar exit-insn bb) - "Given MVAR search in BB what we'll use as assume target. -Keep on searching till EXIT-INSN is encountered. -Return the corresponding rhs mvar." +;; Cheap substitute to a copy propagation pass... +(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb) + "Given MVAR search in BB the original mvar MVAR got assigned from. +Keep on searching till EXIT-INSN is encountered." (cl-flet ((targetp (x) ;; Ret t if x is an mvar and target the correct slot number. (and (comp-mvar-p x) @@ -1955,10 +1967,8 @@ TARGET-BB-SYM is the symbol name of the target block." (comment ,_comment-str) (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks)) (cl-loop - with target-mvar1 = (comp-add-cond-cstrs-target-mvar op1 (car insns-seq) - b) - with target-mvar2 = (comp-add-cond-cstrs-target-mvar op2 (car insns-seq) - b) + with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b) + with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b) for branch-target-cell on blocks for branch-target = (car branch-target-cell) for assume-target = (comp-add-cond-cstrs-target-block b branch-target) @@ -1970,6 +1980,57 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-assume target-mvar2 op1 assume-target negated) finally (cl-return-from in-the-basic-block))))))) +(defun comp-emit-call-cstr (mvar call-cell cstr) + "Emit a constraint CSTR for MVAR after CALL-CELL." + (let ((next-cell (cdr call-cell)) + (new-cell `((assume ,(make-comp-mvar :slot (comp-mvar-slot mvar)) + (and ,mvar ,cstr))))) + (setf (cdr call-cell) new-cell + (cdr new-cell) next-cell + (comp-func-ssa-status comp-func) 'dirty))) + +(defun comp-lambda-list-gen (lambda-list) + "Return a generator to iterate over LAMBDA-LIST." + (lambda () + (cl-case (car lambda-list) + (&optional + (setf lambda-list (cdr lambda-list)) + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list)))) + (&rest + (cadr lambda-list)) + (t + (prog1 + (car lambda-list) + (setf lambda-list (cdr lambda-list))))))) + +(defun comp-add-call-cstr () + "Add args assumptions for each function of which the type specifier is known." + (cl-loop + for bb being each hash-value of (comp-func-blocks comp-func) + do + (comp-loop-insn-in-block bb + (when-let ((match + (pcase insn + (`(set ,lhs (,(pred comp-call-op-p) ,f . ,args)) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values cstr-f lhs args))) + (`(,(pred comp-call-op-p) ,f . ,args) + (when-let ((cstr-f (gethash f comp-known-func-cstr-h))) + (cl-values cstr-f nil args)))))) + (cl-multiple-value-bind (cstr-f lhs args) match + (cl-loop + for arg in args + for gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f)) + for cstr = (funcall gen) + for target = (comp-cond-cstrs-target-mvar arg insn bb) + when (and target + (or (null lhs) + (not (eql (comp-mvar-slot lhs) + (comp-mvar-slot target))))) + do (comp-emit-call-cstr target insn-cell cstr))))))) + (defun comp-add-cstrs (_) "Rewrite conditional branches adding appropriate 'assume' insns. This is introducing and placing 'assume' insns in use by fwprop @@ -1984,6 +2045,7 @@ blocks." (not (comp-func-has-non-local f))) (let ((comp-func f)) (comp-add-cond-cstrs) + (comp-add-call-cstr) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4ea8dbbadb3..a3e887bde95 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -872,14 +872,14 @@ Return a list of results." (if (= x 3) 'foo x)) - (or (member foo) (integer * 2) (integer 4 *))) + (or (member foo) marker number)) ;; 13 ((defun comp-tests-ret-type-spec-8-4-f (x y) (if (= x y) x 'foo)) - t) + (or (member foo) marker number)) ;; 14 ((defun comp-tests-ret-type-spec-9-1-f (x) |