master: mv-bind-unused-p: skip preceding mv-call arguments

The branch "master" has been updated in SBCL:
       via  77215fb2f3e1765a9c26aee521be38f6e2f2260a (commit)
      from  c5c0dba53554373597e44b6b482f6a2d4195943a (commit)

- Log -----------------------------------------------------------------
commit 77215fb2f3e1765a9c26aee521be38f6e2f2260a
Author: Stas Boukarev <[email protected]>
Date:   Thu Jul 9 19:49:12 2026 +0300

    mv-bind-unused-p: skip preceding mv-call arguments
    
    Fixes lp#2160207
---
 src/compiler/ir1util.lisp  | 37 ++++++++++++++++++++++++++++---------
 tests/compiler-2.pure.lisp | 25 +++++++++++++++++++++++++
 2 files changed, 53 insertions(+), 9 deletions(-)

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index d1803df15..1d161de7f 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -339,6 +339,22 @@
                       do (return (values (lvar-dest lvar) lvar ref))))
               (values dest lvar)))))))
 
+(defun mv-let-arg-vars (arg fun &optional (call (let-combination fun)))
+  (when call
+    (multiple-value-bind (start length)
+        (loop with position = 0
+              for lvar in (basic-combination-args call)
+              for n-values = (nth-value 1 (values-types
+                                           (lvar-derived-type lvar)))
+              when (eq lvar arg)
+              return (values position n-values)
+              do
+              (if (integerp n-values)
+                  (incf position n-values)
+                  (return)))
+      (when start
+        (values (nthcdr start (lambda-vars fun))
+                length)))))
 
 (defun mv-bind-vars (lvar &optional single-use)
   (when (and lvar
@@ -349,7 +365,7 @@
                  (eq (basic-combination-kind dest) :local))
         (let ((fun (combination-lambda dest)))
           (when (functional-kind-eq fun mv-let)
-            (lambda-vars fun)))))))
+            (mv-let-arg-vars lvar fun dest)))))))
 
 (defun mv-bind-dest (lvar nth-value &optional single-use)
   (let ((vars (mv-bind-vars lvar single-use)))
@@ -368,7 +384,7 @@
                  (eq (basic-combination-kind dest) :local))
         (let ((fun (combination-lambda dest)))
           (when (functional-kind-eq fun mv-let)
-            (let ((var (nth nth-value (lambda-vars fun))))
+            (let ((var (nth nth-value (mv-let-arg-vars lvar fun dest))))
               (and var
                    (notany #'node-lvar (leaf-refs var))))))))))
 
@@ -700,12 +716,14 @@
                                              do (derive-node-type ref type :from-scratch t)
                                                 (erase (node-lvar ref) 0)))))
                               (if (functional-kind-eq fun mv-let)
-                                  (if nth-value
-                                      (erase-var (nth nth-value (lambda-vars fun))
-                                                 (values-type-nth nth-value lvar-type))
-                                      (mapc #'erase-var
-                                            (lambda-vars fun)
-                                            (values-type-in lvar-type (length (lambda-vars fun)))))
+                                  (multiple-value-bind (vars length) (mv-let-arg-vars lvar fun dest)
+                                    (if nth-value
+                                        (erase-var (nth nth-value vars)
+                                                   (values-type-nth nth-value lvar-type))
+                                        (loop repeat length
+                                              for var in vars
+                                              for type in (values-type-in lvar-type length)
+                                              do (erase-var var type))))
                                   (erase-var
                                    (nth (position-or-lose lvar
                                                           (basic-combination-args dest))
@@ -3714,7 +3732,8 @@ is :ANY, the function name is not checked."
                                           (when (and (functional-p fun)
                                                      (functional-kind-eq fun mv-let))
                                             (let* ((arg (position leaf/lvar (combination-args dest)))
-                                                   (var (and arg (nth arg (lambda-vars fun)))))
+                                                   (var (and arg
+                                                             (nth arg (mv-let-arg-vars dest-lvar fun mv)))))
                                               (recur var)
                                               t)))))))))
                           (t
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 87a85d31d..1a759d410 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -5121,3 +5121,28 @@
                       (self-call (1- a))))
                :name 'self-call))))
     (assert (not (member 'self-call (ctu:find-named-callees fun))))))
+
+(with-test (:name :mv-bind-unused-p-multiple-args)
+  (checked-compile-and-assert
+      ()
+      `(lambda (x y)
+         (multiple-value-call #'values t -1 (floor x y)))
+    ((5 3) (values t -1 1 2)))
+  (checked-compile-and-assert
+      ()
+      `(lambda (x y)
+         (multiple-value-call (lambda (a b c d)
+                                (values a b c d)) -1 t (floor x y)))
+    ((3 5) (values -1 t 0 3)))
+  (checked-compile-and-assert
+      ()
+      `(lambda (x y)
+         (multiple-value-call (lambda (a b c d)
+                                (declare (ignore a b))
+                                (values c d)) -1 t (floor x y)))
+    ((3 5) (values  0 3)))
+  (assert (equal (ctu:ir1-named-calls `(lambda (x y)
+                                         (multiple-value-call (lambda (a b c d)
+                                                                (declare (ignore d))
+                                                                (values a b c)) -1 t (floor x y))))
+                 '(sb-kernel::floor1))))

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


hooks/post-receive
-- 
SBCL