0.8.0.41: "Hunting on worms, part II"

        Insertion of type check on a function result continuation
        prevents tail call optimisation, so:
        * pathwise eliminate unnecessary type checks;
        * disable unsafe CAST insertion on function results.

        Now Paul Dietz' test suite finishes with "83 out of 12565
        total tests failed".

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index d331db6..3edc03b 100644 (file)
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -704,11 +704,11 @@
 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
 ;;; false). If there was a problem, we return NIL.
 (defun assert-definition-type
-       (functional type &key (really-assert t)
-                  ((:lossage-fun *lossage-fun*)
-                   #'compiler-style-warn)
-                  unwinnage-fun
-                  (where "previous declaration"))
+    (functional type &key (really-assert t)
+     ((:lossage-fun *lossage-fun*)
+      #'compiler-style-warn)
+     unwinnage-fun
+     (where "previous declaration"))
   (declare (type functional functional)
           (type function *lossage-fun*)
           (string where))
@@ -728,34 +728,36 @@
             (dtype (when return
                       (continuation-derived-type (return-result return)))))
        (cond
-        ((and dtype (not (values-types-equal-or-intersect dtype
-                                                          type-returns)))
-         (note-lossage
-          "The result type from ~A:~%  ~S~@
+          ((and dtype (not (values-types-equal-or-intersect dtype
+                                                            type-returns)))
+           (note-lossage
+            "The result type from ~A:~%  ~S~@
           conflicts with the definition's result type:~%  ~S"
-          where (type-specifier type-returns) (type-specifier dtype))
-         nil)
-        (*lossage-detected* nil)
-        ((not really-assert) t)
-        (t
-         (assert-continuation-type (return-result return) type-returns
-                                    (lexenv-policy (functional-lexenv functional)))
-         (loop for var in vars and type in types do
-           (cond ((basic-var-sets var)
-                  (when (and unwinnage-fun
-                             (not (csubtypep (leaf-type var) type)))
-                    (funcall unwinnage-fun
-                             "Assignment to argument: ~S~%  ~
+            where (type-specifier type-returns) (type-specifier dtype))
+           nil)
+          (*lossage-detected* nil)
+          ((not really-assert) t)
+          (t
+           (let ((policy (lexenv-policy (functional-lexenv functional))))
+             (when (policy policy (> type-check 0))
+               (assert-continuation-type (return-result return) type-returns
+                                         policy)))
+           (loop for var in vars and type in types do
+                (cond ((basic-var-sets var)
+                       (when (and unwinnage-fun
+                                  (not (csubtypep (leaf-type var) type)))
+                         (funcall unwinnage-fun
+                                  "Assignment to argument: ~S~%  ~
                               prevents use of assertion from function ~
                               type ~A:~%  ~S~%"
-                             (leaf-debug-name var)
-                             where
-                             (type-specifier type))))
-                 (t
-                  (setf (leaf-type var) type)
-                  (dolist (ref (leaf-refs var))
-                    (derive-node-type ref (make-single-value-type type))))))
-         t))))))
+                                  (leaf-debug-name var)
+                                  where
+                                  (type-specifier type))))
+                      (t
+                       (setf (leaf-type var) type)
+                       (dolist (ref (leaf-refs var))
+                         (derive-node-type ref (make-single-value-type type))))))
+           t))))))
 
 (defun assert-global-function-definition-type (name fun)
   (declare (type functional fun))

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index f65cc3a..3f83536 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1734,6 +1734,8 @@
   (declare (type cast cast))
   (let* ((value (cast-value cast))
          (value-type (continuation-derived-type value))
+         (cont (node-cont cast))
+         (dest (continuation-dest cont))
          (atype (cast-asserted-type cast))
          (int (values-type-intersection value-type atype)))
     (derive-node-type cast int)
@@ -1763,24 +1765,40 @@
     (when (eq (node-derived-type cast) *empty-type*)
       (maybe-terminate-block cast nil))
 
-    (flet ((delete-cast ()
-             (let ((cont (node-cont cast)))
-               (delete-filter cast cont value)
-               (reoptimize-continuation cont)
-               (when (continuation-single-value-p cont)
-                 (note-single-valuified-continuation cont))
-               (when (not (continuation-dest cont))
-                 (reoptimize-continuation-uses cont)))))
-      (cond
-        ((and (not do-not-optimize)
-              (values-subtypep value-type
-                               (cast-asserted-type cast)))
-         (delete-cast)
-         (return-from ir1-optimize-cast t))
-        ((and (cast-%type-check cast)
-              (values-subtypep value-type
-                               (cast-type-to-check cast)))
-         (setf (cast-%type-check cast) nil)))))
+    (when (and (not do-not-optimize)
+               (values-subtypep value-type
+                                (cast-asserted-type cast)))
+      (delete-filter cast cont value)
+      (reoptimize-continuation cont)
+      (when (continuation-single-value-p cont)
+        (note-single-valuified-continuation cont))
+      (when (not dest)
+        (reoptimize-continuation-uses cont))
+      (return-from ir1-optimize-cast t))
+
+    (when (and (not do-not-optimize)
+               (not (continuation-use value))
+               dest)
+      (collect ((merges))
+        (do-uses (use value)
+          (when (and (values-subtypep (node-derived-type use) atype)
+                     (immediately-used-p value use))
+            (ensure-block-start cont)
+            (delete-continuation-use use)
+            (add-continuation-use use cont)
+            (unlink-blocks (node-block use) (node-block cast))
+            (link-blocks (node-block use) (continuation-block cont))
+            (when (and (return-p dest)
+                       (basic-combination-p use)
+                       (eq (basic-combination-kind use) :local))
+              (merges use))))
+        (dolist (use (merges))
+          (merge-tail-sets use))))
+
+    (when (and (cast-%type-check cast)
+               (values-subtypep value-type
+                                (cast-type-to-check cast)))
+      (setf (cast-%type-check cast) nil)))
 
   (unless do-not-optimize
     (setf (node-reoptimize cast) nil)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 0970acf..60f15c1 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.40"
+"0.8.0.41"