assignment-convert: Handle tail calls and cleanups better (again).

Instead of trying to compare cleanups modulo harmlessness directly as
in the code disabled in 6cbab77cdb,
check for harmlessness of the cleanup nesting from the call node to
the lambda block directly. This allows us to re-enable the Fluet &
Weeks tests.

We also catch another case of assignment conversion where mutually
tail recursive functions are entered by tail calls from different
functions.

src/compiler/locall.lisp

@@ -1653,40 +1653,39 @@
         (return-ctran nil)
         (return-lvar nil)
         (return-env nil)
-        (return-cleanup nil))
+        (return-cleanup nil)
-    (flet ((return-point-agrees-p (call)
+        (return-harmless nil))
-             (let ((ctran (or (node-next call)
+    (flet ((return-point-agrees-p (call fun)
-                              (block-start (first (block-succ (node-block call))))))
+             (let ((ctran (if (node-tail-p call)
+                              :tail
+                              (or (node-next call)
+                                  (block-start (first (block-succ (node-block call)))))))
                    (lvar (and (valued-node-p call)
                               (node-lvar call)))
                    (env (node-home-lambda call))
-                   (cleanup (node-enclosing-cleanup call)))
+                   (cleanup (node-enclosing-cleanup call))
+                   (harmless (only-harmless-cleanups (node-block call)
+                                                     (lambda-block fun))))
                (aver env)
                (cond ((null return-env)
                       (setq return-ctran ctran
                             return-lvar lvar
                             return-env env
-                            return-cleanup cleanup)
+                            return-cleanup cleanup
+                            return-harmless harmless)
                       t)
                      (t
                       ;; We can only convert multiple outside calls
                       ;; when they are all in the same environment, so
                       ;; we don't muck up tail sets. This is not a
                       ;; conceptual restriction though; it may be
-                      ;; possible to lift this if things are
+                      ;; possible to lift this if things are reworked.
-                      ;; reworked. The cleanup checking here is also
-                      ;; overly conservative. A better approach would
-                      ;; be to check for harmful cleanups with respect
-                      ;; to the messiest common ancestor, though care
-                      ;; would need to be taken with cleanup emission
-                      ;; as merging lambdas will anchor to a specific
-                      ;; predecessor's lexenv/cleanup, not to the
-                      ;; ancestor's.
                       (and (or (eq (node-derived-type call) *empty-type*)
                                (and (eq return-ctran ctran)
                                     (eq return-lvar lvar)))
                            (eq return-env env)
-                           (eq return-cleanup cleanup)))))))
+                           (or (eq return-cleanup cleanup)
+                               (and return-harmless harmless))))))))
       (dolist (fun group)
         (unless (ok-initial-convert-p fun)
           (return-from maybe-convert-group-to-assignment nil))
@@ -1700,7 +1699,7 @@
               (cond ((memq (node-home-lambda ref) group)
                      (unless (node-tail-p call)
                        (return-from maybe-convert-group-to-assignment nil)))
-                    ((return-point-agrees-p call)
+                    ((return-point-agrees-p call fun)
                      (push call outside-calls))
                     (t
                      (return-from maybe-convert-group-to-assignment nil)))))

tests/compiler-ir.pure.lisp

@@ -303,17 +303,36 @@
       (assert (eq (funcall fun -3) 'GOOD))
       (assert assignment))))
 
+;;; Check that we can convert a group of mutually tail recursive
+;;; lambdas entered by tail calls.
+#+sb-devel
+(with-test (:name (:assignment-convert :group-entered-by-tail-calls))
+  (let ((converted '()))
+    (let ((fun (inspect-ir
+                '(lambda (n)
+                  (labels ((my-even? (n)
+                             (if (zerop n) t (my-odd? (1- n))))
+                           (my-odd? (n)
+                             (if (zerop n) nil (my-even? (1- n)))))
+                    (if (plusp n)
+                        (my-even? n)
+                        (my-odd? n))))
+                (lambda (component)
+                  (dolist (lambda (sb-c::component-lambdas component))
+                    (dolist (lambda-let (sb-c::lambda-lets lambda))
+                      (when (sb-c::functional-kind-eq lambda-let sb-c::assignment)
+                        (push lambda-let converted))))))))
+      (assert (eq (funcall fun 4) t))
+      (assert (eq (funcall fun 7) nil))
+      (assert (eq (funcall fun 0) nil))
+      (assert (= (length converted) 2))))) ; MY-EVEN?, MY-ODD?
+
 ;;; The example in 5.1 of Fluet and Weeks "Contification using
 ;;; Dominators", which the A_cont analysis can handle, but A_call
 ;;; cannot. In this case, FM, F, G and H all have the same
 ;;; continuation.
 #+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.1)
+(with-test (:name (:assignment-convert :fluet-weeks-5.1))
-            ;; Unfortunately, this test and the next few almost work
-            ;; but are defeated by the block tags inserted by LABELS
-            ;; since we don't have smart enough cleanup logic in the
-            ;; assignment conversion code.
-            :fails-on :sbcl)
   (let ((converted '()))
     (let ((fun (inspect-ir
                 '(lambda (b x y flag)
@@ -347,8 +366,7 @@
 ;;; A modified version of the above test, but with an outside call for
 ;;; H.
 #+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.1-modified)
+(with-test (:name (:assignment-convert :fluet-weeks-5.1-modified))
-            :fails-on :sbcl)
   (let ((converted '()))
     (let ((fun (inspect-ir
                 '(lambda (b x y flag)
@@ -388,8 +406,7 @@
 ;;; analysis. In this case, F, G1, G2 and H all have the same
 ;;; continuation.
 #+sb-devel
-(with-test (:name (:assignment-convert :fluet-weeks-5.2)
+(with-test (:name (:assignment-convert :fluet-weeks-5.2))
-            :fails-on :sbcl)
   (let ((converted '()))
     (let ((fun (inspect-ir
                 '(lambda (b x y flag)