X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=f8211b797dd77d2cacd3dea719cf08f4bf07e3af;hb=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;hp=8ebe63ad416abddae670ea6e33ca8a0849b28b8c;hpb=bfa4310e41dcd011ca9d139f29be1c5757b41378;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 8ebe63a..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 " - (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)) @@ -337,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 " - (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)) @@ -532,9 +577,9 @@ `(lambda ,vars (declare (ignorable ,@ignores)) (%funcall ,entry ,@args)) - :debug-name (debug-namify "hairy function entry " - (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)))))) @@ -586,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)) @@ -604,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) @@ -621,9 +664,11 @@ (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" @@ -846,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