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

Transform (> (truncate rational c1) c2) to (> rational (* c1 c2))

Browse source
This commit is contained in:
Stas Boukarev 2025-12-03 22:39:00 +03:00
parent 51b3d28476
commit 279eeadf62
3 changed files with 33 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.cirrus.yml
View file

@ -2,7 +2,7 @@ freebsd_build_task:
freebsd_instance:
matrix:
image_family: freebsd-14-2
image_family: freebsd-14-3
cpu: 2
memory: 2G

26
src/compiler/srctran.lisp
View file

@ -6443,6 +6443,32 @@
((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))
`(,op x ,m))))))
((ash *) (* constant)
(let* ((constant (lvar-value (second args)))
(multiplier (if (eq name 'ash)

6
xperfecthash63.lisp-expr
View file

@ -1716,5 +1716,11 @@
(#(6A3E03D5 A4528420 D0F360C2 D1F36255 D5F368A1 D7F36BC7)
"(* ASH / %NEGATE + -)"
"((& (^ (>> val 6) (>> val 27)) 7))")
(#(63C481C2 6A3E03D5 73D42188 A4528420 D0F360C2 D1F36255 D5F368A1 D7F36BC7)
"(FLOOR * ASH TRUNCATE / %NEGATE + -)"
"((& (- val (>> val 12)) 7))")
(#(6A3E03D5 73D42188 A4528420 D0F360C2 D1F36255 D5F368A1 D7F36BC7)
"(* ASH TRUNCATE / %NEGATE + -)"
"((& (- (>> val 6) (>> val 25)) 7))")
)
;; EOF