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)
(make-defs (($fun < > eql))
(deftransform $fun ((x y) (rational (constant-arg rational)) * :important nil)
(or (combination-case x
((- +) (* constant)
(let ((constant (- (lvar-value y)
(funcall name (lvar-value (second args))))))
(splice-fun-args x name #'first)
`($fun x ,constant)))
(- (constant *)
(let ((constant (- (lvar-value (first args)) (lvar-value y))))
(splice-fun-args x name #'second)
`($fun ,constant x)))
(- (* *)
(when (and (zerop (lvar-value y))
(splice-fun-args x name 2 nil))
`(lambda (x y c)
(declare (ignore c))
($fun x y))))
(%negate (*)
(let ((constant (- (lvar-value y))))
(splice-fun-args x name #'first)
`($fun ,constant x)))
(/ (* constant)
(let* ((y (lvar-value y))
(b (lvar-value (second args)))
(m (* y b)))
(when (and (integerp m)
(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)))))
(let ((y (lvar-value y)))
(or (combination-case x
((- +) (* constant)
(let ((constant (- y
(funcall name (lvar-value (second args))))))
(splice-fun-args x name #'first)
`($fun x ,constant)))
(- (constant *)
(let ((constant (- (lvar-value (first args)) y)))
(splice-fun-args x name #'second)
`($fun ,constant x)))
(- (* *)
(when (and (zerop y)
(splice-fun-args x name 2 nil))
`(lambda (x y c)
(declare (ignore c))
($fun x y))))
(%negate (*)
(let ((constant (- y)))
(splice-fun-args x name #'first)
`($fun ,constant x)))
(/ (* constant)
(let* ((b (lvar-value (second args)))
(m (* y b)))
(when (and (integerp m)
(not (eql b 0)))
(aver (splice-fun-args x name #'first nil))
`(,op x ,m))))))
((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 (/ (lvar-value 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 (lvar-value 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 (lvar-value 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))
(cond ($when
(member '$fun '(< >))
((minusp b)
`($fun ,m x)))
(t
`($fun x ,m))))))
($when (eq '$fun '<)
(/ (* (type (not (eql 0))))
(when (zerop 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* ((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))
`($fun x 0)))))
(give-up-ir1-transform))))
`(,op x ,m))))))
((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))
(deftransform $fun ((x y) (real (constant-arg real)) * :node node :important nil)
@ -7955,10 +7968,9 @@
(splice-fun-args x name 1)
nil)
((and (/= y 0)
(not (or (csubtypep (lvar-type (first args)) (specifier-type 'single-float))
(csubtypep (lvar-type (first args)) (specifier-type 'double-float))
(word-sized-lvar-p (first args)))))
(delay-ir1-transform node :ir1-phases)
(not (float-lvar-p (first args))))
(unless (lvar-subtypep (first args) rational) ;; undo if there's ever an ABS vop for integers
(delay-ir1-transform node :ir1-phases))
(splice-fun-args x name 1)
`(if ($fun x ,y)
t
@ -7981,6 +7993,10 @@
(defun word-sized-lvar-p (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)
(single-value-type (if asserted
(node-asserted-type node)

9
xperfecthash63.lisp-expr
View file

@ -1953,5 +1953,14 @@
(#(67AF46F4 8216D041 E111A059 EE1EF1D5)
"(SB-ASSEM:.ALIGN SB-ASSEM:.BYTE SB-ASSEM:.SKIP SB-ASSEM:.LISPWORDS)"
"((& (>> 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