0.8.10.36:

[sbcl.git] / src / compiler / locall.lisp

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index a4bf8fa..fa366db 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -186,7 +186,7 @@
   (with-ir1-environment-from-node (lambda-bind (main-entry fun))
     (let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
                                   :debug-name (debug-namify
-                                               "XEP for ~A"
+                                               "XEP for "
                                                (leaf-debug-name fun)))))
       (setf (functional-kind res) :external
            (leaf-ever-used res) t
@@ -281,7 +281,7 @@
        (return))
       (let ((kind (functional-kind functional)))
        (cond ((or (functional-somewhat-letlike-p functional)
-                  (eql kind :deleted))
+                  (memq kind '(:deleted :zombie)))
               (values)) ; nothing to do
              ((and (null (leaf-refs functional)) (eq kind nil)
                    (not (functional-entry-fun functional)))
@@ -345,7 +345,7 @@
                           (ir1-convert-lambda
                            (functional-inline-expansion original-functional)
                            :debug-name (debug-namify
-                                        "local inline ~A"
+                                        "local inline "
                                         (leaf-debug-name
                                          original-functional)))))))
           (cond (losing-local-functional
@@ -438,22 +438,23 @@
 (defun convert-mv-call (ref call fun)
   (declare (type ref ref) (type mv-combination call) (type functional fun))
   (when (and (looks-like-an-mv-bind fun)
-            (not (functional-entry-fun fun))
             (singleton-p (leaf-refs fun))
             (singleton-p (basic-combination-args call)))
     (let* ((*current-component* (node-component ref))
            (ep (optional-dispatch-entry-point-fun
                 fun (optional-dispatch-max-args fun))))
-      (aver (= (optional-dispatch-min-args fun) 0))
-      (setf (basic-combination-kind call) :local)
-      (pushnew ep (lambda-calls-or-closes (node-home-lambda call)))
-      (merge-tail-sets call ep)
-      (change-ref-leaf ref ep)
+      (when (null (leaf-refs ep))
+        (aver (= (optional-dispatch-min-args fun) 0))
+        (aver (not (functional-entry-fun fun)))
+        (setf (basic-combination-kind call) :local)
+        (pushnew ep (lambda-calls-or-closes (node-home-lambda call)))
+        (merge-tail-sets call ep)
+        (change-ref-leaf ref ep)
 
-      (assert-lvar-type
-       (first (basic-combination-args call))
-       (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
-       (lexenv-policy (node-lexenv call)))))
+        (assert-lvar-type
+         (first (basic-combination-args call))
+         (make-short-values-type (mapcar #'leaf-type (lambda-vars ep)))
+         (lexenv-policy (node-lexenv call))))))
   (values))
 
 ;;; Attempt to convert a call to a lambda. If the number of args is
@@ -545,7 +546,7 @@
            `(lambda ,vars
               (declare (ignorable ,@ignores))
               (%funcall ,entry ,@args))
-           :debug-name (debug-namify "hairy function entry ~S"
+           :debug-name (debug-namify "hairy function entry "
                                      (lvar-fun-name
                                       (basic-combination-fun call)))))))
     (convert-call ref call new-fun)
@@ -631,7 +632,7 @@
                           (progn
                             (ignores dummy val)
                              (unless (eq name :allow-other-keys)
-                               (setq loser name))))
+                               (setq loser (list name)))))
                (let ((info (lambda-var-arg-info var)))
                  (when (eq (arg-info-key info) name)
                    (ignores dummy)
@@ -640,7 +641,7 @@
 
        (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
          (compiler-warn "function called with unknown argument keyword ~S"
-                        loser)
+                        (car loser))
          (setf (basic-combination-kind call) :error)
          (return-from convert-more-call)))
 
@@ -952,11 +953,17 @@
 ;;; new references to it.
 (defun let-convert (fun call)
   (declare (type clambda fun) (type basic-combination call))
-  (let ((next-block (if (node-tail-p call)
-                       nil
-                       (insert-let-body fun call))))
+  (let* ((next-block (insert-let-body fun call))
+         (next-block (if (node-tail-p call)
+                         nil
+                         next-block)))
     (move-return-stuff fun call next-block)
-    (merge-lets fun call)))
+    (merge-lets fun call)
+    (setf (node-tail-p call) nil)
+    ;; If CALL has a derive type NIL, it means that "its return" is
+    ;; unreachable, but the next BIND is still reachable; in order to
+    ;; not confuse MAYBE-TERMINATE-BLOCK...
+    (setf (node-derived-type call) *wild-type*)))
 
 ;;; Reoptimize all of CALL's args and its result.
 (defun reoptimize-call (call)
@@ -1031,6 +1038,7 @@
                     (eq (basic-combination-fun dest) ref-lvar)
                     (eq (basic-combination-kind dest) :local)
                      (not (node-to-be-deleted-p dest))
+                     (not (block-delete-p (lambda-block clambda)))
                     (cond ((ok-initial-convert-p clambda) t)
                           (t
                            (reoptimize-lvar ref-lvar)
@@ -1070,7 +1078,8 @@
 ;;; tail-convert. The second is the value of M-C-T-A.
 (defun maybe-convert-tail-local-call (call)
   (declare (type combination call))
-  (let ((return (lvar-dest (node-lvar call))))
+  (let ((return (lvar-dest (node-lvar call)))
+        (fun (combination-lambda call)))
     (aver (return-p return))
     (when (and (not (node-tail-p call)) ; otherwise already converted
                ;; this is a tail call
@@ -1081,10 +1090,10 @@
                ;; non-tail so that we can use known return inside the
                ;; component.
               (not (eq (functional-kind (node-home-lambda call))
-                       :external)))
+                       :external))
+               (not (block-delete-p (lambda-block fun))))
       (node-ends-block call)
-      (let ((block (node-block call))
-           (fun (combination-lambda call)))
+      (let ((block (node-block call)))
        (setf (node-tail-p call) t)
        (unlink-blocks block (first (block-succ block)))
        (link-blocks block (lambda-block fun))