From: Paul Khuong Date: Fri, 17 May 2013 20:54:06 +0000 (-0400) Subject: More robust erroneous local call detection X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f980e90c5539626c007de121278e66acdb91d37c;p=sbcl.git 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 --- 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 --- 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)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index f50322e..d1c8656 100644 --- 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)))))