X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=f8211b797dd77d2cacd3dea719cf08f4bf07e3af;hb=96a139f451963981fc2419410f468bae1a5d25d2;hp=e5bbc97317b5a812f4dba2c3c186c35056e89071;hpb=e39c00f137e71016e259c667dfe2aa628963b730;p=sbcl.git

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index e5bbc97..f8211b7 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -226,15 +226,14 @@
   (aver (null (functional-entry-fun fun)))
   (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 "
-						(leaf-debug-name fun)))))
+				   :debug-name (debug-name 
+                                                'xep (leaf-debug-name fun)))))
       (setf (functional-kind res) :external
 	    (leaf-ever-used res) t
 	    (functional-entry-fun res) fun
 	    (functional-entry-fun fun) res
-	    (component-reanalyze *current-component*) t
-	    (component-reoptimize *current-component*) t)
+	    (component-reanalyze *current-component*) t)
+      (reoptimize-component *current-component* :maybe)
       (etypecase fun
 	(clambda
 	 (locall-analyze-fun-1 fun))
@@ -378,23 +377,28 @@
 	   (inline-expansion-ok call))
       (let* ((end (component-last-block (node-component call)))
              (pred (block-prev end)))
-        (multiple-value-bind (losing-local-functional converted-lambda)
+        (multiple-value-bind (losing-local-object converted-lambda)
             (catch 'locall-already-let-converted
               (with-ir1-environment-from-node call
                 (let ((*lexenv* (functional-lexenv original-functional)))
                   (values nil
                           (ir1-convert-lambda
                            (functional-inline-expansion original-functional)
-                           :debug-name (debug-namify
-                                        "local inline "
-                                        (leaf-debug-name
-                                         original-functional)))))))
-          (cond (losing-local-functional
-                 (let ((*compiler-error-context* call))
-                   (compiler-notify "couldn't inline expand because expansion ~
-		                   calls this LET-converted local function:~
-		                   ~%  ~S"
-                                    (leaf-debug-name losing-local-functional)))
+                           :debug-name (debug-name 'local-inline 
+                                                   (leaf-debug-name 
+                                                    original-functional)))))))
+          (cond (losing-local-object
+                 (if (functional-p losing-local-object)
+                     (let ((*compiler-error-context* call))
+                       (compiler-notify "couldn't inline expand because expansion ~
+                                         calls this LET-converted local function:~
+                                         ~%  ~S"
+                                        (leaf-debug-name losing-local-object)))
+                     (let ((*compiler-error-context* call))
+                       (compiler-notify "implementation limitation: couldn't inline ~
+                                         expand because expansion refers to ~
+                                         the optimized away object ~S."
+                                        losing-local-object)))
                  (loop for block = (block-next pred) then (block-next block)
                        until (eq block end)
                        do (setf (block-delete-p block) t))
@@ -573,9 +577,9 @@
 	    `(lambda ,vars
 	       (declare (ignorable ,@ignores))
 	       (%funcall ,entry ,@args))
-	    :debug-name (debug-namify "hairy function entry "
-				      (lvar-fun-name
-				       (basic-combination-fun call)))))))
+	    :debug-name (debug-name 'hairy-function-entry 
+                                    (lvar-fun-name
+                                     (basic-combination-fun call)))))))
     (convert-call ref call new-fun)
     (dolist (ref (leaf-refs entry))
       (convert-call-if-possible ref (lvar-dest (node-lvar ref))))))
@@ -627,8 +631,7 @@
       (when (optional-dispatch-keyp fun)
 	(when (oddp (length more))
 	  (compiler-warn "function called with odd number of ~
-  		          arguments in keyword portion")
-
+                          arguments in keyword portion")
 	  (setf (basic-combination-kind call) :error)
 	  (return-from convert-more-call))
 
@@ -645,7 +648,6 @@
 	    (let ((name (lvar-value lvar))
 		  (dummy (first temp))
 		  (val (second temp)))
-              ;; FIXME: check whether KEY was supplied earlier
               (when (and (eq name :allow-other-keys) (not allow-found))
                 (let ((val (second key)))
                   (cond ((constant-lvar-p val)
@@ -662,9 +664,11 @@
                                (setq loser (list name)))))
 		(let ((info (lambda-var-arg-info var)))
 		  (when (eq (arg-info-key info) name)
-		    (ignores dummy)
-		    (supplied (cons var val))
-		    (return)))))))
+		      (ignores dummy)
+		      (if (member var (supplied) :key #'car)
+			  (ignores val)
+			  (supplied (cons var val)))
+		      (return)))))))
 
 	(when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
 	  (compiler-warn "function called with unknown argument keyword ~S"