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

Inline (the fixnum (* x y))

Browse source
This commit is contained in:
Stas Boukarev 2025-09-04 02:34:01 +03:00
parent 0e7d8d574d
commit ec111830aa
3 changed files with 35 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
src/compiler/srctran.lisp
View file

@ -3922,7 +3922,7 @@
(multiple-value-bind (cast) (cast-or-check-bound-type node (specifier-type 'fixnum))
(when cast
(cond ((csubtypep (lvar-type x) (specifier-type 'integer))
(delay-ir1-transform node :constraint)
(delay-ir1-transform node :ir1-phases)
(if (and
(not (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0))))
(or (not (types-equal-or-intersect (lvar-type x) (specifier-type '(eql #.(- most-negative-fixnum)))))
@ -3943,6 +3943,35 @@
(deftransform * ((y x) (fixnum t) * :node node :priority :last)
(unknown-*-transform x y node))
(deftransform * ((x y) (t t) * :node node :priority :last)
(or (unless (or (csubtypep (lvar-type x) (specifier-type 'word))
(csubtypep (lvar-type x) (specifier-type 'sb-vm:signed-word))
(csubtypep (lvar-type x) (specifier-type '(or complex float)))
(csubtypep (lvar-type y) (specifier-type 'word))
(csubtypep (lvar-type y) (specifier-type 'sb-vm:signed-word))
(csubtypep (lvar-type y) (specifier-type '(or complex float))))
(block nil
(multiple-value-bind (cast) (cast-or-check-bound-type node (specifier-type 'fixnum))
(when cast
(cond ((and (csubtypep (lvar-type x) (specifier-type '(and integer (not (member 0 -1)))))
(csubtypep (lvar-type y) (specifier-type '(and integer (not (member 0 -1))))))
(delay-ir1-transform node :constraint)
`(* (the fixnum x) (the fixnum y)))
((and (csubtypep (lvar-type x) (specifier-type 'integer))
(csubtypep (lvar-type y) (specifier-type 'integer)))
(delay-ir1-transform node :constraint)
`(* (the sb-vm:signed-word x) (the sb-vm:signed-word y)))
(t
(delay-ir1-transform node :ir1-phases)
(delete-lvar-cast-if (specifier-type 'number) y)
(delete-lvar-cast-if (specifier-type 'number) x)
`(if (and (typep x 'fixnum)
(typep y 'fixnum))
(* (truly-the fixnum x)
(truly-the fixnum y))
(two-arg-* x y))))))))
(give-up-ir1-transform)))
(defun overflow-transform-1 (name x node)
(unless (node-lvar node)
(give-up-ir1-transform))

5
tests/arith-2.pure.lisp
View file

@ -862,4 +862,7 @@
(the fixnum (* y x))))))
(assert (equal (ctu:ir1-named-calls `(lambda (x)
(the fixnum (* x 2))))
'(sb-kernel:*-by-fixnum-to-fixnum))))
'(sb-kernel:*-by-fixnum-to-fixnum)))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (integer x y))
(the fixnum (* x y)))))))

2
tests/arith-combinations.pure.lisp
View file

@ -69,7 +69,7 @@
(error "~a => ~a /= ~a" (list* lambda args) c result)
(let ((x (type-error-datum c))
(type (type-error-expected-type c)))
(cond
(cond
((not (or (equal type result-type)
(and (eq op '*)
;; Some transforms are not too careful about their errors