X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=f8211b797dd77d2cacd3dea719cf08f4bf07e3af;hb=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;hp=bf6507b29d60c3f3806fc739bf00ea127b4fe6e5;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index bf6507b..f8211b7 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -43,6 +43,46 @@ (setf (car args) nil))) (values)) +(defun recognize-dynamic-extent-lvars (call fun) + (declare (type combination call) (type clambda fun)) + (loop for arg in (basic-combination-args call) + and var in (lambda-vars fun) + when (and arg + (lambda-var-dynamic-extent var) + (not (lvar-dynamic-extent arg))) + collect arg into dx-lvars + and do (let ((use (lvar-uses arg))) + ;; Stack analysis wants DX value generators to end + ;; their blocks. Uses of mupltiple used LVARs already + ;; end their blocks, so we just need to process + ;; used-once LVARs. + (when (node-p use) + (node-ends-block use))) + finally (when dx-lvars + (binding* ((before-ctran (node-prev call)) + (nil (ensure-block-start before-ctran)) + (block (ctran-block before-ctran)) + (new-call-ctran (make-ctran :kind :inside-block + :next call + :block block)) + (entry (with-ir1-environment-from-node call + (make-entry :prev before-ctran + :next new-call-ctran))) + (cleanup (make-cleanup :kind :dynamic-extent + :mess-up entry + :info dx-lvars))) + (setf (node-prev call) new-call-ctran) + (setf (ctran-next before-ctran) entry) + (setf (ctran-use new-call-ctran) entry) + (setf (entry-cleanup entry) cleanup) + (setf (node-lexenv call) + (make-lexenv :default (node-lexenv call) + :cleanup cleanup)) + (push entry (lambda-entries (node-home-lambda entry))) + (dolist (lvar dx-lvars) + (setf (lvar-dynamic-extent lvar) cleanup))))) + (values)) + ;;; This function handles merging the tail sets if CALL is potentially ;;; tail-recursive, and is a call to a function with a different ;;; TAIL-SET than CALL's FUN. This must be called whenever we alter @@ -92,6 +132,7 @@ (when arg (flush-lvar-externally-checkable-type arg)))) (pushnew fun (lambda-calls-or-closes (node-home-lambda call))) + (recognize-dynamic-extent-lvars call fun) (merge-tail-sets call fun) (change-ref-leaf ref fun) (values)) @@ -185,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 ~A" - (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)) @@ -234,22 +274,21 @@ ;;; do LET conversion here. (defun locall-analyze-fun-1 (fun) (declare (type functional fun)) - (let ((refs (leaf-refs fun)) - (first-time t)) + (let ((refs (leaf-refs fun))) (dolist (ref refs) (let* ((lvar (node-lvar ref)) (dest (when lvar (lvar-dest lvar)))) - (cond ((and (basic-combination-p dest) - (eq (basic-combination-fun dest) lvar) - (eq (lvar-uses lvar) ref)) + (unless (node-to-be-deleted-p ref) + (cond ((and (basic-combination-p dest) + (eq (basic-combination-fun dest) lvar) + (eq (lvar-uses lvar) ref)) - (convert-call-if-possible ref dest) + (convert-call-if-possible ref dest) - (unless (eq (basic-combination-kind dest) :local) - (reference-entry-point ref))) - (t - (reference-entry-point ref)))) - (setq first-time nil))) + (unless (eq (basic-combination-kind dest) :local) + (reference-entry-point ref))) + (t + (reference-entry-point ref))))))) (values)) @@ -282,7 +321,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))) @@ -338,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 ~A" - (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)) @@ -393,8 +437,7 @@ (original-fun (ref-leaf ref))) (aver (functional-p original-fun)) (unless (or (member (basic-combination-kind call) '(:local :error)) - (block-delete-p block) - (eq (functional-kind (block-home-lambda block)) :deleted) + (node-to-be-deleted-p call) (member (functional-kind original-fun) '(:toplevel-xep :deleted)) (not (or (eq (component-kind component) :initial) @@ -440,22 +483,23 @@ (defun convert-mv-call (ref call fun) (declare (type ref ref) (type mv-combination call) (type functional fun)) (when (and (looks-like-an-mv-bind fun) - (not (functional-entry-fun fun)) (singleton-p (leaf-refs fun)) (singleton-p (basic-combination-args call))) (let* ((*current-component* (node-component ref)) (ep (optional-dispatch-entry-point-fun fun (optional-dispatch-max-args fun)))) - (aver (= (optional-dispatch-min-args fun) 0)) - (setf (basic-combination-kind call) :local) - (pushnew ep (lambda-calls-or-closes (node-home-lambda call))) - (merge-tail-sets call ep) - (change-ref-leaf ref ep) + (when (null (leaf-refs ep)) + (aver (= (optional-dispatch-min-args fun) 0)) + (aver (not (functional-entry-fun fun))) + (setf (basic-combination-kind call) :local) + (pushnew ep (lambda-calls-or-closes (node-home-lambda call))) + (merge-tail-sets call ep) + (change-ref-leaf ref ep) - (assert-lvar-type - (first (basic-combination-args call)) - (make-short-values-type (mapcar #'leaf-type (lambda-vars ep))) - (lexenv-policy (node-lexenv call))))) + (assert-lvar-type + (first (basic-combination-args call)) + (make-short-values-type (mapcar #'leaf-type (lambda-vars ep))) + (lexenv-policy (node-lexenv call)))))) (values)) ;;; Attempt to convert a call to a lambda. If the number of args is @@ -469,26 +513,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 @@ -505,11 +534,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 @@ -519,11 +548,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)) @@ -547,9 +577,9 @@ `(lambda ,vars (declare (ignorable ,@ignores)) (%funcall ,entry ,@args)) - :debug-name (debug-namify "hairy function entry ~S" - (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)))))) @@ -601,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)) @@ -619,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) @@ -633,16 +661,18 @@ (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) - (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" - loser) + (car loser)) (setf (basic-combination-kind call) :error) (return-from convert-more-call))) @@ -861,7 +891,8 @@ ;; FIXME: Replace the call with unsafe CAST. -- APD, 2003-01-26 (do-uses (use result) (derive-node-type use call-type))) - (substitute-lvar-uses lvar result))) + (substitute-lvar-uses lvar result + (and lvar (eq (lvar-uses lvar) call))))) (values)) ;;; We are converting FUN to be a LET when the call is in a non-tail @@ -948,18 +979,23 @@ (values)) ;;; Actually do LET conversion. We call subfunctions to do most of the -;;; work. We change the CALL's CONT to be the continuation heading the -;;; BIND block, and also do REOPTIMIZE-LVAR on the args and -;;; CONT so that LET-specific IR1 optimizations get a chance. We blow -;;; away any entry for the function in *FREE-FUNS* so that nobody -;;; will create new references to it. +;;; work. We do REOPTIMIZE-LVAR on the args and CALL's lvar so that +;;; LET-specific IR1 optimizations get a chance. We blow away any +;;; entry for the function in *FREE-FUNS* so that nobody will create +;;; 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) @@ -1033,7 +1069,8 @@ (when (and (basic-combination-p dest) (eq (basic-combination-fun dest) ref-lvar) (eq (basic-combination-kind dest) :local) - (not (block-delete-p (node-block dest))) + (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) @@ -1073,7 +1110,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 @@ -1084,10 +1122,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)) @@ -1122,7 +1160,7 @@ (let ((outside-non-tail-call nil) (outside-call nil)) (when (and (dolist (ref (leaf-refs clambda) t) - (let ((dest (lvar-dest (node-lvar ref)))) + (let ((dest (node-dest ref))) (when (or (not dest) (block-delete-p (node-block dest))) (return nil))