master: (- a (- a b)) => b
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 6d159d1fd9a634c6516f3fa0aa7447b5990ef03b (commit)
from 2e8fa20cbdd1fae3258185ae96227533530d5468 (commit)
- Log -----------------------------------------------------------------
commit 6d159d1fd9a634c6516f3fa0aa7447b5990ef03b
Author: Stas Boukarev <[email protected]>
Date: Thu Aug 20 14:57:46 2026 +0300
(- a (- a b)) => b
And friends.
---
src/compiler/ir1util.lisp | 50 +++++++++++++++++++++++++-------
src/compiler/srctran.lisp | 57 ++++++++++++++++++++++++++++++++++++
tests/arith-2.pure.lisp | 74 +++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 171 insertions(+), 10 deletions(-)
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index dad020266..a20d0238d 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -528,12 +528,34 @@
(if (typep x '(cons (eql :or)))
(cdr x)
(list x)))
+ (collect-spec-vars (spec)
+ (let (vars)
+ (labels ((add (s)
+ (when (and s
+ (symbolp s)
+ (not (keywordp s))
+ (not (eq s '*))
+ (not (eq s '&rest)))
+ (pushnew s vars)))
+ (walk (s)
+ (cond ((typep s '(cons (eql :type)))
+ (let ((var (third s)))
+ (add var)))
+ ((typep s '(cons (eql :constant)))
+ (add (second s)))
+ ((typep s '(cons (member :or :commutative)))
+ (mapc #'walk (cdr s)))
+ ((consp s)
+ (mapc #'walk (cdr s)))
+ (t
+ (add s)))))
+ (walk spec)
+ (nreverse vars))))
(equal-spec (a b)
(cond ((eq a b))
((symbolp a)
(and (symbolp b)
- (not (eq a '*))
- (not (eq b '*))))
+ (eq a b)))
((typep a '(cons (member :type :constant)))
(equal a b))
((and (consp a)
@@ -572,8 +594,8 @@
(declare (ignorable ,@vars))
(when ,(car vars)
,(expand lvars specs
- (let ((old-bound-vars bound-vars))
- (lambda ()
+ (lambda ()
+ (let ((old-bound-vars bound-vars))
(cond (commutative
(assert (= (length vars) 2))
`(or (let (rotated)
@@ -643,12 +665,20 @@
(destructuring-bind (&key node lvar) (if (listp lvar)
lvar
(list :lvar lvar))
- (if node
- `(multiple-value-bind (name combination args) (combination/cast-name-args ,node)
- (declare (ignorable name combination))
- ,@(expand-node nil nil spec (lambda () `(progn ,@body))
- :match-name nil))
- (expand (list lvar) (list spec) (lambda () `(progn ,@body))))))))
+ (let* ((pattern-vars (collect-spec-vars spec))
+ (body-fun (gensym "MATCH-BODY"))
+ (leaf-caller (lambda () `(,body-fun name combination args ,@pattern-vars rotated)))
+ (match-form (if node
+ `(multiple-value-bind (name combination args) (combination/cast-name-args ,node)
+ (declare (ignorable name combination))
+ ,@(expand-node nil nil spec leaf-caller :match-name nil))
+ (expand (list lvar) (list spec) leaf-caller))))
+ `(flet ((,body-fun (name combination args ,@pattern-vars &optional rotated)
+ (declare (ignorable name combination args ,@pattern-vars rotated))
+ ,@body))
+ (let (name combination args rotated)
+ (declare (ignorable name combination args rotated))
+ ,match-form)))))))
(defun erase-node-type (node type &optional nth-value erase-calls)
(setf (node-derived-type node)
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 6a1ac495c..427566ffd 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -6292,6 +6292,63 @@
(t
(give-up-ir1-transform))))))
+(deftransform - ((x y) (rational rational) * :node node)
+ (or (combination-match (:node node) (- a (- a b))
+ (extract-lvar-n b 1 node)
+ 'y)
+ (combination-match (:node node) (- (+ a b) a)
+ (extract-lvar-n b 1 node)
+ 'x)
+ (combination-match (:node node) (- (- a b) a)
+ (extract-lvar-n b 1 node)
+ '(%negate x))
+ (combination-match (:node node) (- a (+ a b))
+ (extract-lvar-n b 1 node)
+ '(%negate y))
+ (combination-match (:node node) (- (+ a b) (+ a c))
+ (extract-lvar-n b 1 node)
+ (extract-lvar-n c 1 node)
+ '(- x y))
+ (combination-match (:node node) (- (- a b) (- a c))
+ (extract-lvar-n b 1 node)
+ (extract-lvar-n c 1 node)
+ '(- y x))
+ (combination-match (:node node) (- (- b a) (- c a))
+ (extract-lvar-n b 1 node)
+ (extract-lvar-n c 1 node)
+ '(- x y))
+ (combination-match (:node node) (- (+ a b) (- a c))
+ (extract-lvar-n b 1 node)
+ (extract-lvar-n c 1 node)
+ '(+ x y))
+ (combination-match (:node node) (- (- a b) (+ a c))
+ (extract-lvar-n b 1 node)
+ (extract-lvar-n c 1 node)
+ '(- (+ x y)))
+ (combination-match (:node node) (- (%negate a) (- b a))
+ (extract-lvar-n b 1 node)
+ ;; TODO: use negate-lvar
+ '(%negate y))
+ (give-up-ir1-transform)))
+
+(deftransform + ((x y) (rational rational) * :node node)
+ (or (combination-match (:node node) (+ a (- b a))
+ (extract-lvar-n b 1 node)
+ (if rotated
+ 'x
+ 'y))
+ (combination-match (:node node) (+ (- b a) (- a c))
+ (extract-lvar-n b 1 node)
+ (extract-lvar-n c 1 node)
+ (if rotated
+ '(- y x)
+ '(- x y)))
+ (combination-match (:node node) (+ (+ a b) (- c a))
+ (extract-lvar-n b 1 node)
+ (extract-lvar-n c 1 node)
+ '(+ x y))
+ (give-up-ir1-transform)))
+
;;; Fold (expt x n) into multiplications for small integral values of
;;; N; convert (expt x 1/2) to sqrt.
(deftransform expt ((x y) (t (constant-arg real)) * :node node)
diff --git a/tests/arith-2.pure.lisp b/tests/arith-2.pure.lisp
index 94763640d..7262af0c2 100644
--- a/tests/arith-2.pure.lisp
+++ b/tests/arith-2.pure.lisp
@@ -2541,3 +2541,77 @@
((signed-byte 16) x))
(ash x (- y)))
((1 -5) 32)))
+
+(with-test (:name :+/-rationals
+ :skipped-on (not :arm64)) ;; FIXME: others translate to generic-+
+ (flet ((test (form &rest names)
+ (let ((calls (ctu:ir1-named-calls form)))
+ (if names
+ (loop for (name count) in names
+ do (assert (= (count name calls) count)))
+ (assert (not calls))))))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (- a (- a b))))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (+ a (- b a))))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (+ (- b a) a)))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (- (+ a b) a)))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (- (+ b a) a)))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (- (- a b) a))
+ '(sb-kernel:%negate 1))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (- a (+ a b)))
+ '(sb-kernel:%negate 1))
+ (test '(lambda (a b c)
+ (declare (rational a b c))
+ (- (+ a b) (+ a c)))
+ '(sb-kernel:two-arg-- 1)
+ '(sb-kernel:two-arg-+ 0))
+ (test '(lambda (a b c)
+ (declare (rational a b c))
+ (- (+ a b) (- a c)))
+ '(sb-kernel:two-arg-- 0)
+ '(sb-kernel:two-arg-+ 1))
+ (test '(lambda (a b c)
+ (declare (rational a b c))
+ (- (- a b) (- a c)))
+ '(sb-kernel:two-arg-- 1)
+ '(sb-kernel:two-arg-+ 0))
+ (test '(lambda (a b c)
+ (declare (rational a b c))
+ (+ (- b a) (- a c)))
+ '(sb-kernel:two-arg-- 1)
+ '(sb-kernel:two-arg-+ 0))
+ (test '(lambda (a b c)
+ (declare (rational a b c))
+ (- (- b a) (- c a)))
+ '(sb-kernel:two-arg-- 1)
+ '(sb-kernel:two-arg-+ 0))
+ (test '(lambda (a b c)
+ (declare (rational a b c))
+ (+ (+ a b) (- c a)))
+ '(sb-kernel:two-arg-- 0)
+ '(sb-kernel:two-arg-+ 1))
+ (test '(lambda (a b c)
+ (declare (rational a b c))
+ (- (- a b) (+ a c)))
+ '(sb-kernel:two-arg-- 0)
+ '(sb-kernel:%negate 1)
+ '(sb-kernel:two-arg-+ 1))
+ (test '(lambda (a b)
+ (declare (rational a b))
+ (- (- a) (- b a)))
+ '(sb-kernel:two-arg-- 0)
+ '(sb-kernel:%negate 1)
+ '(sb-kernel:two-arg-+ 0))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL