X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=8ebe63ad416abddae670ea6e33ca8a0849b28b8c;hb=cf4cb9554515c59eddbde38d1cf236339c37f55f;hp=3239cd36f4ec45ebf60204f10e272b9a59a5d046;hpb=140791a0479787eaca83bea2355c15b65259a823;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 3239cd3..8ebe63a 100644 --- 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 @@ -468,26 +468,11 @@ (cond ((= n-call-args nargs) (convert-call ref call fun)) (t - ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the - ;; Compiler" that calling a function with "the wrong number of - ;; arguments" be only a STYLE-ERROR. I think, though, that this - ;; should only apply when the number of arguments is inferred - ;; from a previous definition. If the number of arguments - ;; is DECLAIMed, surely calling with the wrong number is a - ;; real WARNING. As long as SBCL continues to use CMU CL's - ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here, - ;; but as long as we continue to use that policy, that's the - ;; not our biggest problem.:-| When we fix that policy, this - ;; should come back into compliance. (So fix that policy!) - ;; ..but.. - ;; FIXME, continued: Except that section "3.2.2.3 Semantic - ;; Constraints" says that if it's within the same file, it's - ;; wrong. And we're in locall.lisp here, so it's probably - ;; (haven't checked this..) a call to something in the same - ;; file. So maybe it deserves a full warning anyway. - (compiler-warn + (warn + 'local-argument-mismatch + :format-control "function called with ~R argument~:P, but wants exactly ~R" - n-call-args nargs) + :format-arguments (list n-call-args nargs)) (setf (basic-combination-kind call) :error))))) ;;;; &OPTIONAL, &MORE and &KEYWORD calls @@ -504,11 +489,11 @@ (max-args (optional-dispatch-max-args fun)) (call-args (length (combination-args call)))) (cond ((< call-args min-args) - ;; FIXME: See FIXME note at the previous - ;; wrong-number-of-arguments warnings in this file. - (compiler-warn + (warn + 'local-argument-mismatch + :format-control "function called with ~R argument~:P, but wants at least ~R" - call-args min-args) + :format-arguments (list call-args min-args)) (setf (basic-combination-kind call) :error)) ((<= call-args max-args) (convert-call ref call @@ -518,11 +503,12 @@ ((optional-dispatch-more-entry fun) (convert-more-call ref call fun)) (t - ;; FIXME: See FIXME note at the previous - ;; wrong-number-of-arguments warnings in this file. - (compiler-warn + (warn + 'local-argument-mismatch + :format-control "function called with ~R argument~:P, but wants at most ~R" - call-args max-args) + :format-arguments + (list call-args max-args)) (setf (basic-combination-kind call) :error)))) (values)) @@ -546,7 +532,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) @@ -632,7 +618,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) @@ -641,7 +627,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))) @@ -953,11 +939,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) @@ -1032,6 +1024,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) @@ -1071,7 +1064,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 @@ -1082,10 +1076,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))