More robust erroneous local call detection

 * When possible, convert known bad calls into calls to error-signaling
   stubs.

 * Fixes lp#504121 (and likely other occurrences of
   "failed AVER (ZEROP (HASH-TABLE-COUNT ...))."

diff --git a/NEWS b/NEWS
index 688915f..0cb943e 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -39,6 +39,8 @@ changes relative to sbcl-1.1.7:
     caller on x86 and x86-64. (lp#800343)
   * bug fix: Compile-time type errors should never result in COMPILE-FILE
     failure. (lp#943953)
+  * bug fix: Known bad local calls do not cause strange failures when
+    emitting or dumping code. (lp#504121)
   * optimization: faster ISQRT on fixnums and small bignums
   * optimization: faster and smaller INTEGER-LENGTH on fixnums on x86-64.
   * optimization: On x86-64, the number of multi-byte NOP instructions used

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 97372d3..9b63361 100644 (file)
--- 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))))))
 \f
 ;;;; &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))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index f50322e..d1c8656 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4411,3 +4411,51 @@
           do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type
                                           (compile nil function))))
                             result-type)))))
+
+(with-test (:name :bug-504121)
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g)
+                       (funcall p1 g))))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-missing))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &optional x)
+                       (funcall p1 g))))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-superfluous))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &optional x)
+                       (funcall p1 g))
+                     #\1 2 3))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-odd))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &key x)
+                       (funcall p1 g))
+                     #\1 :x))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-unknown))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &key x)
+                       (funcall p1 g))
+                     #\1 :y 2))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))