common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Add transforms for (= (logcount word-sized) 1)

Browse source
This commit is contained in:
Stas Boukarev 2026-09-05 18:37:25 +03:00
parent f8160932da
commit 120d5eab81
2 changed files with 96 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
src/compiler/ir1util.lisp
View file

@ -624,7 +624,7 @@
(if lvars
(let ((lvar (car lvars))
(spec (car specs)))
(flet ((match-var (name &optional allow-empty constant)
(flet ((match-var (name &optional allow-empty constant constant-type)
(cond ((or (eq name '*)
(and allow-empty
(not name)))
@ -638,17 +638,21 @@
body)))
(t
(push name bound-vars)
`(let ((,name ,(if constant
`(lvar-value ,lvar)
lvar)))
,(expand (cdr lvars) (cdr specs)
body))))))
(let ((expanded (expand (cdr lvars) (cdr specs)
body)))
`(let ((,name ,(if constant
`(lvar-value ,lvar)
lvar)))
,(if constant-type
`(when (typep ,name ',constant-type)
,expanded)
expanded)))))))
(cond ((typep spec '(cons (eql :type)))
`(when (csubtypep (lvar-type ,lvar) (specifier-type ',(second spec)))
,(match-var (third spec) t)))
((typep spec '(cons (eql :constant)))
`(when (constant-lvar-p ,lvar)
,(match-var (second spec) t t)))
,(match-var (second spec) t t (third spec))))
((symbolp spec)
(match-var spec))
((atom spec)
@ -4325,3 +4329,11 @@ is :ANY, the function name is not checked."
(setf (lambda-var-sets var)
(delq1 set (lambda-var-sets var)))
(delete-filter set (node-lvar set) (set-value set))))
(defun transform-to-identity (nth-arg node n-args)
(let ((vars (make-gensym-list n-args)))
(transform-call node
`(lambda ,vars
(declare (ignorable ,@vars))
,(nth nth-arg vars))
'transform--to-identity)))

79
src/compiler/srctran.lisp
View file

@ -3264,6 +3264,82 @@
(when (< hi -1)
(specifier-type '(integer 1)))))))))
(deftransform logcount ((x) (integer) * :node node :important nil)
(or (unless (word-sized-lvar-p x)
(let ((dest (node-dest node)))
;; (= (logcount signed) 0) => (or (eq x 0) (eq x -1))
(combination-case (nil :node dest)
(eq (* 0)
(unless (word-sized-lvar-p x)
(delay-ir1-transform node :ir1-phases)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
'(or (eq x 0) (eq x -1)))))))
(give-up-ir1-transform)))
(deftransform logcount ((x) (unsigned-byte) * :node node :important nil)
(or (let ((dest (node-dest node)))
(combination-case (nil :node dest)
;; (= (logcount unsigned) 0) => (= x 0)
(eq (* 0)
(erase-node-type node (lvar-derived-type x))
'x)))
(give-up-ir1-transform)))
(deftransform logcount ((x) (signed-word) * :node node :important nil)
(delay-ir1-transform node :ir1-phases)
(or (let ((dest (node-dest node)))
(combination-case (nil :node dest)
(eq (* 0)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
`(< (logand most-positive-word (1+ x)) 2))
(eq (* 1)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
(if (lvar-intersectp x (integer -1 0))
`(let* ((x (logxor x (ash x ,(- 1 sb-vm:n-word-bits))))
(1-x (1- x)))
(> (logxor x 1-x) 1-x))
`(let ((x (logxor x (ash x ,(- 1 sb-vm:n-word-bits)))))
(not (logtest x (1- x))))))
(< (* 2)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
`(let ((x (logxor x (ash x ,(- 1 sb-vm:n-word-bits)))))
(not (logtest x (1- x)))))
(> (* 1)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
`(let ((x (logxor x (ash x ,(- 1 sb-vm:n-word-bits)))))
(logtest x (1- x))))))
(give-up-ir1-transform)))
(deftransform logcount ((x) (word) * :node node :important nil)
(delay-ir1-transform node :ir1-phases)
(or (let ((dest (node-dest node)))
(combination-case (nil :node dest)
;; (= (logcount unsigned) 0) => (= x 0)
(eq (* 0)
(erase-node-type node (lvar-derived-type x))
'x)
(eq (* 1)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
(if (lvar-intersectp x (eql 0))
`(let ((1-x (logand most-positive-word (1- x))))
(> (logxor x 1-x) 1-x))
`(not (logtest x (1- x)))))
(< (* 2)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
`(not (logtest x (1- x))))
(> (* 1)
(erase-node-type node (values-specifier-type '(values boolean &optional)))
(transform-to-identity 0 dest 2)
`(logtest x (1- x)))))
(give-up-ir1-transform)))
(defoptimizer (isqrt derive-type) ((x))
(one-arg-derive-type
x
@ -5058,8 +5134,7 @@
(let ((rem (and (mv-bind-unused-p result 0)
(mv-bind-dest result 1 t))))
(or
(when (and rem
(combination-matches 'eq '(* 0) rem))
(when (combination-matches 'eq '(* 0) rem)
(cond ((oddp y)
(let* ((max-x most-positive-word)
(inv (mulinv abs-y max-x))