X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=9b6336118dd43240f194c4148b04db476fe6dac2;hb=243d0f6f598c3a47adcc06923066263ee3051003;hp=4e18af7caf0b5e02a1904c33ec332fd3921c6d80;hpb=f7a78dd3554bd977b006e5da349a11d4e8463bb5;p=sbcl.git

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 4e18af7..9b63361 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -490,6 +490,24 @@
          (lexenv-policy (node-lexenv call))))))
   (values))
 
+;;; Convenience function to mark local calls as known bad.
+(defun transform-call-with-ir1-environment (node lambda default-name)
+  (aver (combination-p node))
+  (with-ir1-environment-from-node node
+    (transform-call node lambda
+                    (or (combination-fun-source-name node nil)
+                        default-name))))
+
+(defun warn-invalid-local-call (node count &rest warn-arguments)
+  (aver (combination-p node))
+  (aver (typep count 'unsigned-byte))
+  (apply 'warn warn-arguments)
+  (transform-call-with-ir1-environment node
+                                       `(lambda (&rest args)
+                                          (declare (ignore args))
+                                          (%arg-count-error ,count))
+                                       '%arg-count-error))
+
 ;;; Attempt to convert a call to a lambda. If the number of args is
 ;;; wrong, we give a warning and mark the call as :ERROR to remove it
 ;;; from future consideration. If the argcount is O.K. then we just
@@ -501,12 +519,11 @@
     (cond ((= n-call-args nargs)
            (convert-call ref call fun))
           (t
-           (warn
+           (warn-invalid-local-call call n-call-args
             'local-argument-mismatch
             :format-control
             "function called with ~R argument~:P, but wants exactly ~R"
-            :format-arguments (list n-call-args nargs))
-           (setf (basic-combination-kind call) :error)))))
+            :format-arguments (list n-call-args nargs))))))
 
 ;;;; &OPTIONAL, &MORE and &KEYWORD calls
 
@@ -522,12 +539,11 @@
         (max-args (optional-dispatch-max-args fun))
         (call-args (length (combination-args call))))
     (cond ((< call-args min-args)
-           (warn
+           (warn-invalid-local-call call call-args
             'local-argument-mismatch
             :format-control
             "function called with ~R argument~:P, but wants at least ~R"
-            :format-arguments (list call-args min-args))
-           (setf (basic-combination-kind call) :error))
+            :format-arguments (list call-args min-args)))
           ((<= call-args max-args)
            (convert-call ref call
                          (let ((*current-component* (node-component ref)))
@@ -536,13 +552,12 @@
           ((optional-dispatch-more-entry fun)
            (convert-more-call ref call fun))
           (t
-           (warn
+           (warn-invalid-local-call call call-args
             'local-argument-mismatch
             :format-control
             "function called with ~R argument~:P, but wants at most ~R"
             :format-arguments
-            (list call-args max-args))
-           (setf (basic-combination-kind call) :error))))
+            (list call-args max-args)))))
   (values))
 
 ;;; This function is used to convert a call to an entry point when
@@ -622,7 +637,12 @@
         (when (oddp (length more))
           (compiler-warn "function called with odd number of ~
                           arguments in keyword portion")
-          (setf (basic-combination-kind call) :error)
+          (transform-call-with-ir1-environment
+           call
+           `(lambda (&rest args)
+              (declare (ignore args))
+              (%odd-key-args-error))
+           '%odd-key-args-error)
           (return-from convert-more-call))
 
         (do ((key more (cddr key))
@@ -663,7 +683,12 @@
         (when (and loser (not (optional-dispatch-allowp fun)) (not allowp))
           (compiler-warn "function called with unknown argument keyword ~S"
                          (car loser))
-          (setf (basic-combination-kind call) :error)
+          (transform-call-with-ir1-environment
+           call
+           `(lambda (&rest args)
+              (declare (ignore args))
+              (%unknown-key-arg-error ',(car loser)))
+           '%unknown-key-arg-error)
           (return-from convert-more-call)))
 
       (collect ((call-args))
@@ -681,7 +706,7 @@
                    (call-args `(list ,@more-temps))
                    ;; &REST arguments may be accompanied by extra
                    ;; context and count arguments. We know this by
-                   ;; the ARG-INFO-DEFAULT. Supply NIL and 0 or
+                   ;; the ARG-INFO-DEFAULT. Supply 0 and 0 or
                    ;; don't convert at all depending.
                    (let ((more (arg-info-default info)))
                      (when more
@@ -692,7 +717,7 @@
                              ;; We've already converted to use the more context
                              ;; instead of the rest list.
                              (return-from convert-more-call))))
-                       (call-args nil)
+                       (call-args 0)
                        (call-args 0)
                        (setf (arg-info-default info) t)))
                    (return))
@@ -712,7 +737,8 @@
         (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
                                  (append temps more-temps)
                                  (ignores) (call-args)
-                                 more-temps))))
+                                 (when (optional-rest-p fun)
+                                   more-temps)))))
 
   (values))
 
@@ -1028,7 +1054,13 @@
   ;; with anonymous things, and suppressing inlining
   ;; for such things can easily give Python acute indigestion, so
   ;; we don't.)
-  (when (leaf-has-source-name-p clambda)
+  ;;
+  ;; A functional that is already inline-expanded in this componsne definitely
+  ;; deserves let-conversion -- and in case of main entry points for inline
+  ;; expanded optional dispatch, the main-etry isn't explicitly marked :INLINE
+  ;; even if the function really is.
+  (when (and (leaf-has-source-name-p clambda)
+             (not (functional-inline-expanded clambda)))
     ;; ANSI requires that explicit NOTINLINE be respected.
     (or (eq (lambda-inlinep clambda) :notinline)
         ;; If (= LET-CONVERSION 0) we can guess that inlining