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

Transform (< (abs rational) c) before abs is transformed
Some checks are pending
CL-host / ecl (push) Waiting to run
Details
CL-host / clisp (push) Waiting to run
Details
CL-host / ccl (push) Waiting to run
Details
CL-host / cmucl (push) Waiting to run
Details
CL-host / sbcl (push) Waiting to run
Details
CL-host / compare-xc-host-fasls (ccl, false) (push) Blocked by required conditions
Details
CL-host / compare-xc-host-fasls (clisp, false) (push) Blocked by required conditions
Details
CL-host / compare-xc-host-fasls (cmucl, false) (push) Blocked by required conditions
Details
CL-host / compare-xc-host-fasls (self, false) (push) Blocked by required conditions
Details
Linux arm / build (push) Waiting to run
Details
Linux arm64 / build () (push) Waiting to run
Details
Linux qemu / build (ppc64le) (push) Waiting to run
Details
Linux qemu / build (riscv64) (push) Waiting to run
Details
Linux / build (x86, --with-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86, --without-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86, --without-sb-unicode, ) (push) Waiting to run
Details
Linux / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Waiting to run
Details
Linux / build (x86-64, --with-sb-fasteval --without-sb-eval --with-nonstop-foreign-call, fasteval) (push) Waiting to run
Details
Linux / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return, sse4) (push) Waiting to run
Details
Linux / build (x86-64, --with-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86-64, --without-sb-thread, ) (push) Waiting to run
Details
Linux / build (x86-64, --without-sb-unicode, ) (push) Waiting to run
Details
Mac / build (arm64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Mac / build (arm64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Mac / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Mac / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Details
Windows arm64 / build (arm64, clang-aarch64, clangarm64) (push) Waiting to run
Details
Windows / build (x86-64, ucrt-x86_64, ucrt64) (push) Waiting to run
Details

Browse source
This commit is contained in:
Stas Boukarev 2026-09-05 23:31:04 +03:00
parent 783a2ab0e9
commit 790814f16e
2 changed files with 150 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

266
src/compiler/srctran.lisp
View file

@ -7820,129 +7820,142 @@
;;; (< (+/- x cosntant1) constant2) ;;; (< (+/- x cosntant1) constant2)
(make-defs (($fun < > eql)) (make-defs (($fun < > eql))
(deftransform $fun ((x y) (rational (constant-arg rational)) * :important nil) (deftransform $fun ((x y) (rational (constant-arg rational)) * :important nil)
(or (combination-case x (let ((y (lvar-value y)))
((- +) (* constant) (or (combination-case x
(let ((constant (- (lvar-value y) ((- +) (* constant)
(funcall name (lvar-value (second args)))))) (let ((constant (- y
(splice-fun-args x name #'first) (funcall name (lvar-value (second args))))))
`($fun x ,constant))) (splice-fun-args x name #'first)
(- (constant *) `($fun x ,constant)))
(let ((constant (- (lvar-value (first args)) (lvar-value y)))) (- (constant *)
(splice-fun-args x name #'second) (let ((constant (- (lvar-value (first args)) y)))
`($fun ,constant x))) (splice-fun-args x name #'second)
(- (* *) `($fun ,constant x)))
(when (and (zerop (lvar-value y)) (- (* *)
(splice-fun-args x name 2 nil)) (when (and (zerop y)
`(lambda (x y c) (splice-fun-args x name 2 nil))
(declare (ignore c)) `(lambda (x y c)
($fun x y)))) (declare (ignore c))
(%negate (*) ($fun x y))))
(let ((constant (- (lvar-value y)))) (%negate (*)
(splice-fun-args x name #'first) (let ((constant (- y)))
`($fun ,constant x))) (splice-fun-args x name #'first)
(/ (* constant) `($fun ,constant x)))
(let* ((y (lvar-value y)) (/ (* constant)
(b (lvar-value (second args))) (let* ((b (lvar-value (second args)))
(m (* y b))) (m (* y b)))
(when (and (integerp m) (when (and (integerp m)
(not (eql b 0))) (not (eql b 0)))
(aver (splice-fun-args x name #'first nil))
(cond ($when
(member '$fun '(< >))
((minusp b)
`($fun ,m x)))
(t
`($fun x ,m))))))
($when (eq '$fun '<)
(/ (* (type (not (eql 0))))
(when (zerop (lvar-value y))
(destructuring-bind (a b) args
(declare (ignore a))
(cond ((csubtypep (lvar-type b) (specifier-type '(rational 0)))
(aver (splice-fun-args x name #'first nil))
`($fun x 0))
((csubtypep (lvar-type b) (specifier-type '(rational * 0)))
(aver (splice-fun-args x name #'first nil))
`($fun 0 x)))))))
($when (member '$fun '(> <))
(truncate
(* constant)
(let* ((y (lvar-value y))
(b (lvar-value (second args))))
(when (and (integerp y)
(integerp b)
(/= b 0))
(multiple-value-bind (op m)
($if (eq '$fun '>)
(if (>= b 0)
(if (>= y 0)
(values '>= (* b (1+ y)))
(values '> (* b y)))
(if (>= y 0)
(values '<= (* b (1+ y)))
(values '< (* b y))))
(if (> b 0)
(if (<= y 0)
(values '<= (* b (1- y)))
(values '< (* b y)))
(if (<= y 0)
(values '>= (* b (1- y)))
(values '> (* b y)))))
(aver (splice-fun-args x name #'first nil)) (aver (splice-fun-args x name #'first nil))
`(,op x ,m)))))) (cond ($when
((ash *) (* constant) (member '$fun '(< >))
(block nil ((minusp b)
(let* ((constant (lvar-value (second args))) `($fun ,m x)))
(multiplier (if (eq name 'ash) (t
(ash 1 (if (typep constant '(mod 4096)) `($fun x ,m))))))
constant ($when (eq '$fun '<)
(return))) (/ (* (type (not (eql 0))))
constant))) (when (zerop y)
(unless (zerop multiplier) (destructuring-bind (a b) args
(let* ((constant (/ (lvar-value y) multiplier)) (declare (ignore a))
(arg1 'x) (cond ((csubtypep (lvar-type b) (specifier-type '(rational 0)))
(arg2 constant)) (aver (splice-fun-args x name #'first nil))
(when (minusp multiplier) `($fun x 0))
(rotatef arg1 arg2)) ((csubtypep (lvar-type b) (specifier-type '(rational * 0)))
(splice-fun-args x name #'first) (aver (splice-fun-args x name #'first nil))
(cond ((or (integerp constant) `($fun 0 x)))))))
(csubtypep (lvar-type x) (specifier-type 'integer))) ($when (member '$fun '(> <))
`($fun ,arg1 ,arg2)) (truncate
(t (* constant)
;; Do the fixnum case here, (two-arg< fixnum ratio) (let* ((b (lvar-value (second args))))
;; is more expensive than an extra multiplication. (when (and (integerp y)
`(if (fixnump x) (integerp b)
($fun ,arg1 ,arg2) (/= b 0))
($fun ,arg1 ,arg2))))))))) (multiple-value-bind (op m)
;; (< (* x positive/negative) 0) => (< x 0) ($if (eq '$fun '>)
(* (* *) (if (>= b 0)
(when (zerop (lvar-value y)) (if (>= y 0)
(flet ((try (a nth) (values '>= (* b (1+ y)))
(cond ((csubtypep (lvar-type a) (specifier-type '(rational (0)))) (values '> (* b y)))
(aver (splice-fun-args x name nth nil)) (if (>= y 0)
`($fun x 0)) (values '<= (* b (1+ y)))
((csubtypep (lvar-type a) (specifier-type '(rational * (0)))) (values '< (* b y))))
(aver (splice-fun-args x name nth nil)) (if (> b 0)
`($fun 0 x))))) (if (<= y 0)
(destructuring-bind (a b) args (values '<= (* b (1- y)))
(or (try a #'second) (values '< (* b y)))
(try b #'first)))))) (if (<= y 0)
(ash (* (type unsigned-byte)) (values '>= (* b (1- y)))
(when (zerop (lvar-value y)) (values '> (* b y)))))
(aver (splice-fun-args x name #'first nil))
`($fun x 0)))
;; Some operations preserve the sign bit
($when (eq '$fun '<)
(ash (* *)
;; Shifting anywhere doesn't change the sign bit
(when (zerop (lvar-value y))
(aver (splice-fun-args x name #'first nil))
`($fun x 0)))
(floor (* (type (rational (0))))
(when (zerop (lvar-value y))
(aver (splice-fun-args x name #'first nil)) (aver (splice-fun-args x name #'first nil))
`($fun x 0))))) `(,op x ,m))))))
(give-up-ir1-transform)))) ((ash *) (* constant)
(block nil
(let* ((constant (lvar-value (second args)))
(multiplier (if (eq name 'ash)
(ash 1 (if (typep constant '(mod 4096))
constant
(return)))
constant)))
(unless (zerop multiplier)
(let* ((constant (/ y multiplier))
(arg1 'x)
(arg2 constant))
(when (minusp multiplier)
(rotatef arg1 arg2))
(splice-fun-args x name #'first)
(cond ((or (integerp constant)
(csubtypep (lvar-type x) (specifier-type 'integer)))
`($fun ,arg1 ,arg2))
(t
;; Do the fixnum case here, (two-arg< fixnum ratio)
;; is more expensive than an extra multiplication.
`(if (fixnump x)
($fun ,arg1 ,arg2)
($fun ,arg1 ,arg2)))))))))
;; (< (* x positive/negative) 0) => (< x 0)
(* (* *)
(when (zerop y)
(flet ((try (a nth)
(cond ((csubtypep (lvar-type a) (specifier-type '(rational (0))))
(aver (splice-fun-args x name nth nil))
`($fun x 0))
((csubtypep (lvar-type a) (specifier-type '(rational * (0))))
(aver (splice-fun-args x name nth nil))
`($fun 0 x)))))
(destructuring-bind (a b) args
(or (try a #'second)
(try b #'first))))))
(ash (* (type unsigned-byte))
(when (zerop y)
(aver (splice-fun-args x name #'first nil))
`($fun x 0)))
;; Some operations preserve the sign bit
($when (eq '$fun '<)
(ash (* *)
;; Shifting anywhere doesn't change the sign bit
(when (zerop y)
(aver (splice-fun-args x name #'first nil))
`($fun x 0)))
(floor (* (type (rational (0))))
(when (zerop y)
(aver (splice-fun-args x name #'first nil))
`($fun x 0))))
($when (eq '$fun '>)
(abs *
(splice-fun-args x name 1)
`(if (> x ,y)
t
(< x ,(- y)))))
($when (eq '$fun '<)
(abs *
(splice-fun-args x name 1)
(if (and (= y 1)
(lvar-subtypep x integer))
`(= x 0)
`(if (< x ,y)
(> x ,(- y)))))))
(give-up-ir1-transform)))))
(make-defs (($fun = eq eql)) (make-defs (($fun = eq eql))
(deftransform $fun ((x y) (real (constant-arg real)) * :node node :important nil) (deftransform $fun ((x y) (real (constant-arg real)) * :node node :important nil)
@ -7955,10 +7968,9 @@
(splice-fun-args x name 1) (splice-fun-args x name 1)
nil) nil)
((and (/= y 0) ((and (/= y 0)
(not (or (csubtypep (lvar-type (first args)) (specifier-type 'single-float)) (not (float-lvar-p (first args))))
(csubtypep (lvar-type (first args)) (specifier-type 'double-float)) (unless (lvar-subtypep (first args) rational) ;; undo if there's ever an ABS vop for integers
(word-sized-lvar-p (first args))))) (delay-ir1-transform node :ir1-phases))
(delay-ir1-transform node :ir1-phases)
(splice-fun-args x name 1) (splice-fun-args x name 1)
`(if ($fun x ,y) `(if ($fun x ,y)
t t
@ -7981,6 +7993,10 @@
(defun word-sized-lvar-p (lvar) (defun word-sized-lvar-p (lvar)
(word-sized-type-p (lvar-type lvar))) (word-sized-type-p (lvar-type lvar)))
(defun float-lvar-p (lvar)
(or (csubtypep (lvar-type lvar) (specifier-type 'single-float))
(csubtypep (lvar-type lvar) (specifier-type 'double-float))))
(defun single-value-result-type (node &optional asserted) (defun single-value-result-type (node &optional asserted)
(single-value-type (if asserted (single-value-type (if asserted
(node-asserted-type node) (node-asserted-type node)

9
xperfecthash63.lisp-expr
View file

@ -1953,5 +1953,14 @@
(#(67AF46F4 8216D041 E111A059 EE1EF1D5) (#(67AF46F4 8216D041 E111A059 EE1EF1D5)
"(SB-ASSEM:.ALIGN SB-ASSEM:.BYTE SB-ASSEM:.SKIP SB-ASSEM:.LISPWORDS)" "(SB-ASSEM:.ALIGN SB-ASSEM:.BYTE SB-ASSEM:.SKIP SB-ASSEM:.LISPWORDS)"
"((& (>> val 12) 3))") "((& (>> val 12) 3))")
(#(63C481C2 6A3E03D5 73D42188 937BB764 A4528420 D0F360C2 D1F36255 D5F368A1 D7F36BC7)
"(ABS FLOOR * ASH TRUNCATE / %NEGATE + -)"
"((let ((tab #a((8) (unsigned-byte 8) 0 0 4 0 12 2 0 6)))
(let ((b (& val #x7)))
(let ((a (>> val 29)))
(^ a (aref tab b))))))")
(#(6A3E03D5 73D42188 937BB764 A4528420 D0F360C2 D1F36255 D5F368A1 D7F36BC7)
"(ABS * ASH TRUNCATE / %NEGATE + -)"
"((& (- val (>> val 28)) 7))")
) )
;; EOF ;; EOF