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

Fix ldb transforms

Browse source 
erase-node-type has to be called with value-types.

Reported by Eric Marsden.
This commit is contained in:
Stas Boukarev 2026-08-17 18:23:13 +03:00
parent 0a1f43ff5d
commit 06151ad1c1
2 changed files with 16 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
src/compiler/ir1util.lisp
View file

@ -652,17 +652,20 @@
(defun erase-node-type (node type &optional nth-value erase-calls)
(setf (node-derived-type node)
(if (eq type t)
(let ((derived (node-derived-type node)))
(make-values-type
(loop for i from 0
for r in (values-type-required derived)
collect (if (= i nth-value)
*universal-type*
r))
(values-type-optional derived)
(values-type-rest derived)))
type))
(cond ((eq type t)
(let ((derived (node-derived-type node)))
(make-values-type
(loop for i from 0
for r in (values-type-required derived)
collect (if (= i nth-value)
*universal-type*
r))
(values-type-optional derived)
(values-type-rest derived))))
(t
(aver (or (eq type *wild-type*)
(values-type-p type)))
type)))
(erase-lvar-type (node-lvar node) nth-value erase-calls))
;;; The uses need to have the correct type before calling this.

4
src/compiler/srctran.lisp
View file

@ -3621,7 +3621,7 @@
(cond ((and (<= mask most-positive-word)
(or (combination-matches '= '(* 0) (node-dest node))
(combination-matches '> '(* 0) (node-dest node))))
(erase-node-type node (specifier-type 'word))
(erase-node-type node (values-specifier-type '(values word &optional)))
`(logand integer ,mask))
(t
(give-up-ir1-transform)))))
@ -3630,7 +3630,7 @@
(deftransform %mask-field ((size posn int) * * :node node)
(cond ((or (combination-matches '= '(* 0) (node-dest node))
(combination-matches '> '(* 0) (node-dest node)))
(erase-node-type node (specifier-type 'unsigned-byte))
(erase-node-type node (values-specifier-type '(values unsigned-byte &optional)))
`(%ldb size posn int))
(t
(give-up-ir1-transform))))