better type propagation for MULTIPLE-VALUE-BIND

  Previously code such as

   (multiple-value-bind (x y) (known-call ...)
      ...)

  could lose the derived type for KNOWN-CALL when it was converted to
  an inline lambda: the derived type correctly ended up associated
  with the final VALUES call in the inlined code, but
  CONVERT-MV-BIND-TO-LET lost that.

  Address this by propagating the derived type of VALUES to the
  VALUES arguments.

  Allows removing the TRULY-THE kludge from the new TRUNCATE
  transform.

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 5c4a4ae..8a4d87e 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1988,6 +1988,15 @@
         (unlink-node call)
         (when vals
           (reoptimize-lvar (first vals)))
+        ;; Propagate derived types from the VALUES call to its args:
+        ;; transforms can leave the VALUES call with a better type
+        ;; than its args have, so make sure not to throw that away.
+        (let ((types (values-type-types (node-derived-type use))))
+          (dolist (val vals)
+            (when types
+              (let ((type (pop types)))
+                (assert-lvar-type val type '((type-check . 0)))))))
+        ;; Propagate declared types of MV-BIND variables.
         (propagate-to-args use fun)
         (reoptimize-call use))
       t)))

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 0426eef..03bb32a 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3357,28 +3357,10 @@
     ;; Division by zero, one or powers of two is handled elsewhere.
     (when (zerop (logand y (1- y)))
       (give-up-ir1-transform))
-    ;; The compiler can't derive the result types to maximal tightness
-    ;; from the transformed expression, so we calculate them here and
-    ;; add the corresponding specifiers explicitly through TRULY-THE.
-    ;; This duplicates parts of the TRUNCATE DERIVE-TYPE optimizer but
-    ;; using that here would be too cumbersome.
-    (let* ((x-type (lvar-type x))
-           (x-low (or (and (numeric-type-p x-type)
-                           (numeric-type-low x-type))
-                      0))
-           (x-high (or (and (numeric-type-p x-type)
-                            (numeric-type-high x-type))
-                       (1- (expt 2 #.sb!vm:n-word-bits))))
-           (quot-low (truncate x-low y))
-           (quot-high (truncate x-high y)))
-      (if (= quot-low quot-high)
-          `(values ,quot-low
-                   (- x ,(* quot-low y)))
-          `(let* ((quot ,(gen-unsigned-div-by-constant-expr y))
-                  (rem (ldb (byte #.sb!vm:n-word-bits 0)
-                            (- x (* quot ,y)))))
-             (values (truly-the (integer ,quot-low ,quot-high) quot)
-                     (truly-the (integer 0 ,(1- y)) rem)))))))
+    `(let* ((quot ,(gen-unsigned-div-by-constant-expr y))
+            (rem (ldb (byte #.sb!vm:n-word-bits 0)
+                      (- x (* quot ,y)))))
+       (values quot rem))))
 \f
 ;;;; arithmetic and logical identity operation elimination
 

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 9c52b0f..2c73809 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -2136,4 +2136,26 @@
     (assert (equal `(function () (values ,ufix &optional))
                    (%simple-fun-type fun)))))
 
+(test-util:with-test (:name :mv-bind-to-let-type-propagation)
+  (let ((f (compile nil `(lambda (x)
+                           (declare (optimize speed)
+                                    (type (integer 20 50) x))
+                           (< (truncate x 10) 1))))
+        (g (compile nil `(lambda (x)
+                           (declare (optimize speed)
+                                    (type (integer 20 50) x))
+                           (< (nth-value 1 (truncate x 10)) 10))))
+        (h (compile nil `(lambda (x)
+                           (declare (optimize speed)
+                                    (type (integer 20 50) x))
+                           (multiple-value-bind (q r)
+                               (truncate x 10)
+                             (declare (ignore r))
+                             (< q 1)))))
+        (type0 '(function ((integer 20 50)) (values null &optional)))
+        (type1 '(function ((integer 20 50)) (values (member t) &optional))))
+    (assert (equal type0 (sb-kernel:%simple-fun-type f)))
+    (assert (equal type1 (sb-kernel:%simple-fun-type g)))
+    (assert (equal type0 (sb-kernel:%simple-fun-type h)))))
+
 ;;; success