X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=18d051b0086056deaa550c1da7b68010301c4c7d;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=f370eb35a1201ca02bb727953c29e340f618c312;hpb=70ea2f8c140246a8b5f7cb126198ff068630258f;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index f370eb3..18d051b 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)) @@ -186,14 +227,14 @@ (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 (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)) @@ -281,7 +322,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))) @@ -337,7 +378,7 @@ (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))) @@ -345,15 +386,21 @@ (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 - (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))) + (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)) @@ -468,26 +515,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 +536,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 +550,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 +579,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) @@ -600,8 +633,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)) @@ -632,7 +664,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 +673,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))) @@ -860,7 +892,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 @@ -959,7 +992,11 @@ next-block))) (move-return-stuff fun call next-block) (merge-lets fun call) - (setf (node-tail-p call) nil))) + (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)