[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp c07c9f6 2/9: Extend cstrs pass to match `when' like
From: |
Andrea Corallo |
Subject: |
feature/native-comp c07c9f6 2/9: Extend cstrs pass to match `when' like code |
Date: |
Thu, 24 Dec 2020 09:49:30 -0500 (EST) |
branch: feature/native-comp
commit c07c9f6bf81d2355672839e7423a9f2a5f00e4fb
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
Extend cstrs pass to match `when' like code
* lisp/emacs-lisp/comp.el (comp-emit-assume): Better parameter names.
(comp-add-cond-cstrs-simple): New function.
(comp-add-cond-cstrs): Rename assume-target -> block-target.
(comp-add-cstrs): Call `comp-add-cond-cstrs-simple'.
* test/src/comp-tests.el (comp-tests-type-spec-tests): Add test.
---
lisp/emacs-lisp/comp.el | 45 +++++++++++++++++++++++++++++++++++----------
test/src/comp-tests.el | 8 +++++++-
2 files changed, 42 insertions(+), 11 deletions(-)
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 599c8c7..eef63b5 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -1881,15 +1881,15 @@ into the C code forwarding the compilation unit."
;; 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.
+(defun comp-emit-assume (lhs rhs bb negated)
+ "Emit an assume for mvar LHS being RHS.
When NEGATED is non-nil the assumption is negated.
The assume is emitted at the beginning of the block BB."
- (let ((target-slot (comp-mvar-slot target))
+ (let ((lhs-slot (comp-mvar-slot lhs))
(tmp-mvar (if negated
(make-comp-mvar :slot (comp-mvar-slot rhs))
rhs)))
- (push `(assume ,(make-comp-mvar :slot target-slot) (and ,target ,tmp-mvar))
+ (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar))
(comp-block-insns bb))
(if negated
(push `(assume ,tmp-mvar (not ,rhs))
@@ -1950,6 +1950,30 @@ TARGET-BB-SYM is the symbol name of the target block."
"_cstrs"))
curr-bb target-bb))))
+(defun comp-add-cond-cstrs-simple ()
+ "`comp-add-cstrs' 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 insn-seq on (comp-block-insns b)
+ do
+ (pcase insn-seq
+ (`((set ,(and (pred comp-mvar-p) tmp-mvar)
+ ,(and (pred comp-mvar-p) obj1))
+ (comment ,_comment-str)
+ (cond-jump ,tmp-mvar ,obj2 . ,blocks))
+ (cl-loop
+ for branch-target-cell on blocks
+ for branch-target = (car branch-target-cell)
+ for block-target = (comp-add-cond-cstrs-target-block b branch-target)
+ for negated in '(nil t)
+ do
+ (setf (car branch-target-cell) (comp-block-name block-target))
+ (comp-emit-assume tmp-mvar obj2 block-target negated)
+ finally (cl-return-from in-the-basic-block)))))))
+
(defun comp-add-cond-cstrs ()
"`comp-add-cstrs' worker function for each selected function."
(cl-loop
@@ -1960,23 +1984,23 @@ TARGET-BB-SYM is the symbol name of the target block."
for insns-seq on (comp-block-insns b)
do
(pcase insns-seq
- (`((set ,(and (pred comp-mvar-p) cond)
+ (`((set ,(and (pred comp-mvar-p) obj1)
(,(pred comp-call-op-p)
,(or 'eq 'eql '= 'equal) ,op1 ,op2))
(comment ,_comment-str)
- (cond-jump ,cond ,(pred comp-mvar-p) . ,blocks))
+ (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks))
(cl-loop
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)
+ for block-target = (comp-add-cond-cstrs-target-block b branch-target)
for negated in '(t nil)
- do (setf (car branch-target-cell) (comp-block-name assume-target))
+ do (setf (car branch-target-cell) (comp-block-name block-target))
when target-mvar1
- do (comp-emit-assume target-mvar1 op2 assume-target negated)
+ do (comp-emit-assume target-mvar1 op2 block-target negated)
when target-mvar2
- do (comp-emit-assume target-mvar2 op1 assume-target negated)
+ do (comp-emit-assume target-mvar2 op1 block-target negated)
finally (cl-return-from in-the-basic-block)))))))
(defun comp-emit-call-cstr (mvar call-cell cstr)
@@ -2048,6 +2072,7 @@ blocks."
(comp-func-l-p f)
(not (comp-func-has-non-local f)))
(let ((comp-func f))
+ (comp-add-cond-cstrs-simple)
(comp-add-cond-cstrs)
(comp-add-call-cstr)
(comp-log-func comp-func 3))))
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index e0d4bf8..039e066 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -935,7 +935,13 @@ Return a list of results."
;; 19
((defun comp-tests-ret-type-spec-f (x y)
(eq x y))
- boolean)))
+ boolean)
+
+ ;; 20
+ ((defun comp-tests-ret-type-spec-f (x)
+ (when x
+ 'foo))
+ (or (member foo) null))))
(defun comp-tests-define-type-spec-test (number x)
`(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()
- feature/native-comp updated (b99a474 -> b4ee13c), Andrea Corallo, 2020/12/24
- feature/native-comp 4deeb2f 1/9: Invert basic block argument order in LIMPLE cond-jump, Andrea Corallo, 2020/12/24
- feature/native-comp c07c9f6 2/9: Extend cstrs pass to match `when' like code,
Andrea Corallo <=
- feature/native-comp 538f598 4/9: Extend cstrs pass to match `unless' like code, Andrea Corallo, 2020/12/24
- feature/native-comp 672988e 5/9: Symplify (not t) => nil and (not nil) => t, Andrea Corallo, 2020/12/24
- feature/native-comp 96d4c70 6/9: * Fix logic for constraining block with multiple predecessors, Andrea Corallo, 2020/12/24
- feature/native-comp 715cac1 3/9: * lisp/emacs-lisp/comp.el (comp-limplify-lap-inst): Opencode byte-not., Andrea Corallo, 2020/12/24
- feature/native-comp 2327a98 8/9: * Constrain only mvars that are actually used, Andrea Corallo, 2020/12/24
- feature/native-comp b4ee13c 9/9: * Memoize `comp-subtype-p', Andrea Corallo, 2020/12/24
- feature/native-comp 2a6c6bf 7/9: * Use `comp-assign-op-p' into dead code elimination pass, Andrea Corallo, 2020/12/24