master: Derive the return type of XEPs

The branch "master" has been updated in SBCL:
       via  4de59fbb0311928a2a39ff5e554f5b823ebe1f30 (commit)
      from  187f57e2244946c0953dcd1c99c3a28553c557ec (commit)

- Log -----------------------------------------------------------------
commit 4de59fbb0311928a2a39ff5e554f5b823ebe1f30
Author: Stas Boukarev <[email protected]>
Date:   Wed May 6 04:35:44 2026 +0300

    Derive the return type of XEPs
---
 src/code/type.lisp         | 15 +++++++++++++++
 src/cold/exports.lisp      |  1 +
 src/compiler/ir1opt.lisp   |  8 ++++++--
 tests/compiler-2.pure.lisp |  9 +++++++++
 4 files changed, 31 insertions(+), 2 deletions(-)

diff --git a/src/code/type.lisp b/src/code/type.lisp
index 78f291d34..aa34eb5b0 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -620,6 +620,21 @@
             (new fun-designator-type)
             (new fun-type))))))
 
+(defun fun-type-change-return (type return)
+  (if (fun-type-p type)
+      (make-fun-type
+       :required (fun-type-required type)
+       :optional (fun-type-optional type)
+       :rest (fun-type-rest type)
+       :keyp (fun-type-keyp type)
+       :keywords (fun-type-keywords type)
+       :allowp (fun-type-allowp type)
+       :wild-args (fun-type-wild-args type)
+       :returns return)
+      (make-fun-type
+       :wild-args t
+       :returns return)))
+
 ;; This seems to be used only by cltl2, and within 'cross-type',
 ;; where it is never used, which makes sense, since pretty much we
 ;; never want this object, but instead the classoid FUNCTION
diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp
index 55c93ca5b..fb1213168 100644
--- a/src/cold/exports.lisp
+++ b/src/cold/exports.lisp
@@ -1774,6 +1774,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
            "FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS" "FUN-TYPE-NARGS"
            "FUN-TYPE-OPTIONAL" "FUN-TYPE-P" "FUN-TYPE-REQUIRED"
            "FUN-TYPE-REST" "FUN-TYPE-RETURNS" "FUN-TYPE-WILD-ARGS"
+           "FUN-TYPE-CHANGE-RETURN"
            "GENERALIZED-BOOLEAN"
            "GENERIC-ABSTRACT-TYPE-FUNCTION"
            "GET-CLOSURE-LENGTH" "GET-HEADER-DATA"
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index a0cba11c1..b500dad9f 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -809,8 +809,12 @@
            (unless (type= (res) (tail-set-type tails))
              (setf (tail-set-type tails) (res))
              (dolist (fun (tail-set-funs tails))
-               (dolist (ref (leaf-refs fun))
-                 (reoptimize-lvar (node-lvar ref))))))))))
+               (let* ((entry-type (fun-type-change-return (leaf-type fun) (res)))
+                      (ref-type (make-single-value-type entry-type)))
+                 (setf (leaf-type fun) entry-type)
+                 (dolist (ref (leaf-refs fun))
+                   (setf (node-derived-type ref) ref-type)
+                   (reoptimize-lvar (node-lvar ref)))))))))))
 
 ;;;; IF optimization
 
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index ca3ecaf10..1271399be 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -5143,3 +5143,12 @@
       (declare ((simple-array nil (9)) a))
       (setf (aref a 0) 1)
       a)))
+
+(with-test (:name :xep-type-derivation)
+  (assert-type
+   (lambda (n)
+     (funcall (if n
+                  (lambda (a) (+ a 2))
+                  (lambda (a) (+ a 1)))
+              1))
+   number))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL