X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=4f59a8784fcd74f4bc9fb9239d5d409d861c4c34;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=d796d01276a43ba194b2905987847f241638258b;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index d796d01..4f59a87 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -40,7 +40,8 @@ (let ((arg (car args)) (var (car vars))) (cond ((leaf-refs var) - (assert-continuation-type arg (leaf-type var))) + (assert-continuation-type arg (leaf-type var) + (lexenv-policy (node-lexenv call)))) (t (flush-dest arg) (setf (car args) nil))))) @@ -133,10 +134,12 @@ (temps (make-gensym-list (length (lambda-vars fun))))) `(lambda (,n-supplied ,@temps) (declare (type index ,n-supplied)) - ,(if (policy *lexenv* (zerop safety)) + ,(if (policy *lexenv* (zerop verify-arg-count)) `(declare (ignore ,n-supplied)) `(%verify-arg-count ,n-supplied ,nargs)) - (%funcall ,fun ,@temps)))) + (locally + (declare (optimize (merge-tail-calls 3))) + (%funcall ,fun ,@temps))))) (optional-dispatch (let* ((min (optional-dispatch-min-args fun)) (max (optional-dispatch-max-args fun)) @@ -162,7 +165,9 @@ (n-count (gensym))) `(multiple-value-bind (,n-context ,n-count) (%more-arg-context ,n-supplied ,max) - (%funcall ,more ,@temps ,n-context ,n-count)))))) + (locally + (declare (optimize (merge-tail-calls 3))) + (%funcall ,more ,@temps ,n-context ,n-count))))))) (t (%arg-count-error ,n-supplied))))))))) @@ -409,7 +414,7 @@ (values)) ;;; Attempt to convert a multiple-value call. The only interesting -;;; case is a call to a function that Looks-Like-An-MV-Bind, has +;;; case is a call to a function that LOOKS-LIKE-AN-MV-BIND, has ;;; exactly one reference and no XEP, and is called with one values ;;; continuation. ;;; @@ -438,7 +443,8 @@ (assert-continuation-type (first (basic-combination-args call)) (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep)) - :rest *universal-type*)))) + :rest *universal-type*) + (lexenv-policy (node-lexenv call))))) (values)) ;;; Attempt to convert a call to a lambda. If the number of args is @@ -527,8 +533,8 @@ (with-ir1-environment-from-node call (ir1-convert-lambda `(lambda ,vars - (declare (ignorable . ,ignores)) - (%funcall ,entry . ,args)) + (declare (ignorable ,@ignores)) + (%funcall ,entry ,@args)) :debug-name (debug-namify "hairy function entry ~S" (continuation-fun-name (basic-combination-fun call))))))) @@ -560,6 +566,8 @@ (flame (policy call (or (> speed inhibit-warnings) (> space inhibit-warnings)))) (loser nil) + (allowp nil) + (allow-found nil) (temps (make-gensym-list max)) (more-temps (make-gensym-list (length more)))) (collect ((ignores) @@ -599,17 +607,28 @@ (let ((name (continuation-value cont)) (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-continuation-p val) + (setq allow-found t + allowp (continuation-value val))) + (t (when flame + (compiler-note "non-constant :ALLOW-OTHER-KEYS value")) + (setf (basic-combination-kind call) :error) + (return-from convert-more-call))))) (dolist (var (key-vars) (progn (ignores dummy val) - (setq loser name))) + (unless (eq name :allow-other-keys) + (setq loser name)))) (let ((info (lambda-var-arg-info var))) (when (eq (arg-info-key info) name) (ignores dummy) (supplied (cons var val)) (return))))))) - (when (and loser (not (optional-dispatch-allowp fun))) + (when (and loser (not (optional-dispatch-allowp fun)) (not allowp)) (compiler-warn "function called with unknown argument keyword ~S" loser) (setf (basic-combination-kind call) :error) @@ -618,7 +637,7 @@ (collect ((call-args)) (do ((var arglist (cdr var)) (temp temps (cdr temp))) - (()) + ((null var)) (let ((info (lambda-var-arg-info (car var)))) (if info (ecase (arg-info-kind info) @@ -748,10 +767,10 @@ ;; information. (setf (tail-set-info (lambda-tail-set clambda)) nil)) -;;; Handle the environment semantics of LET conversion. We add CLAMBDA -;;; and its LETs to LETs for the CALL's home function. We merge the -;;; calls for CLAMBDA with the calls for the home function, removing -;;; CLAMBDA in the process. We also merge the ENTRIES. +;;; Handle the PHYSENV semantics of LET conversion. We add CLAMBDA and +;;; its LETs to LETs for the CALL's home function. We merge the calls +;;; for CLAMBDA with the calls for the home function, removing CLAMBDA +;;; in the process. We also merge the ENTRIES. ;;; ;;; We also unlink the function head from the component head and set ;;; COMPONENT-REANALYZE to true to indicate that the DFO should be @@ -770,18 +789,20 @@ (depart-from-tail-set clambda) (let* ((home (node-home-lambda call)) - (home-env (lambda-physenv home))) + (home-physenv (lambda-physenv home))) + + (aver (not (eq home clambda))) ;; CLAMBDA belongs to HOME now. (push clambda (lambda-lets home)) (setf (lambda-home clambda) home) - (setf (lambda-physenv clambda) home-env) + (setf (lambda-physenv clambda) home-physenv) ;; All of CLAMBDA's LETs belong to HOME now. (let ((lets (lambda-lets clambda))) (dolist (let lets) - (setf (lambda-home let) home) - (setf (lambda-physenv let) home-env)) + (setf (lambda-home let) home) + (setf (lambda-physenv let) home-physenv)) (setf (lambda-lets home) (nconc lets (lambda-lets home)))) ;; CLAMBDA no longer has an independent existence as an entity ;; which has LETs. @@ -790,17 +811,17 @@ ;; HOME no longer calls CLAMBDA, and owns all of CLAMBDA's old ;; DFO dependencies. (setf (lambda-calls-or-closes home) - (delete clambda - (nunion (lambda-calls-or-closes clambda) - (lambda-calls-or-closes home)))) + (delete clambda + (nunion (lambda-calls-or-closes clambda) + (lambda-calls-or-closes home)))) ;; CLAMBDA no longer has an independent existence as an entity ;; which calls things or has DFO dependencies. (setf (lambda-calls-or-closes clambda) nil) ;; All of CLAMBDA's ENTRIES belong to HOME now. (setf (lambda-entries home) - (nconc (lambda-entries clambda) - (lambda-entries home))) + (nconc (lambda-entries clambda) + (lambda-entries home))) ;; CLAMBDA no longer has an independent existence as an entity ;; with ENTRIES. (setf (lambda-entries clambda) nil)) @@ -834,7 +855,10 @@ (cont (node-cont call)) (call-type (node-derived-type call))) (when (eq (continuation-use cont) call) - (assert-continuation-type cont (continuation-asserted-type result))) + (set-continuation-type-assertion + cont + (continuation-asserted-type result) + (continuation-type-to-check result))) (unless (eq call-type *wild-type*) (do-uses (use result) (derive-node-type use call-type))) @@ -920,12 +944,21 @@ (cond ((not return)) ((or next-block call-return) (unless (block-delete-p (node-block return)) + (when (and (node-tail-p call) + call-return + (not (eq (node-cont call) + (return-result call-return)))) + ;; We do not care to give a meaningful continuation to + ;; a tail combination, but here we need it. + (delete-continuation-use call) + (add-continuation-use call (return-result call-return))) (move-return-uses fun call (or next-block (node-block call-return))))) (t (aver (node-tail-p call)) (setf (lambda-return call-fun) return) - (setf (return-lambda return) call-fun)))) + (setf (return-lambda return) call-fun) + (setf (lambda-return fun) nil)))) (move-let-call-cont fun) (values)) @@ -952,58 +985,84 @@ (reoptimize-continuation (node-cont call)) (values)) +;;; Are there any declarations in force to say CLAMBDA shouldn't be +;;; LET converted? +(defun declarations-suppress-let-conversion-p (clambda) + ;; From the user's point of view, LET-converting something that + ;; has a name is inlining it. (The user can't see what we're doing + ;; with anonymous things, and suppressing inlining + ;; for such things can easily give Python acute indigestion, so + ;; we don't.) + (when (leaf-has-source-name-p clambda) + ;; ANSI requires that explicit NOTINLINE be respected. + (or (eq (lambda-inlinep clambda) :notinline) + ;; If (= LET-CONVERTION 0) we can guess that inlining + ;; generally won't be appreciated, but if the user + ;; specifically requests inlining, that takes precedence over + ;; our general guess. + (and (policy clambda (= let-convertion 0)) + (not (eq (lambda-inlinep clambda) :inline)))))) + ;;; We also don't convert calls to named functions which appear in the ;;; initial component, delaying this until optimization. This ;;; minimizes the likelihood that we will LET-convert a function which ;;; may have references added due to later local inline expansion. (defun ok-initial-convert-p (fun) (not (and (leaf-has-source-name-p fun) - (eq (component-kind (lambda-component fun)) - :initial)))) + (or (declarations-suppress-let-conversion-p fun) + (eq (component-kind (lambda-component fun)) + :initial))))) ;;; This function is called when there is some reason to believe that ;;; CLAMBDA might be converted into a LET. This is done after local -;;; call analysis, and also when a reference is deleted. We only -;;; convert to a let when the function is a normal local function, has -;;; no XEP, and is referenced in exactly one local call. Conversion is -;;; also inhibited if the only reference is in a block about to be -;;; deleted. We return true if we converted. -;;; -;;; These rules may seem unnecessarily restrictive, since there are -;;; some cases where we could do the return with a jump that don't -;;; satisfy these requirements. The reason for doing things this way -;;; is that it makes the concept of a LET much more useful at the -;;; level of IR1 semantics. The :ASSIGNMENT function kind provides -;;; another way to optimize calls to single-return/multiple call -;;; functions. -;;; -;;; We don't attempt to convert calls to functions that have an XEP, -;;; since we might be embarrassed later when we want to convert a -;;; newly discovered local call. Also, see OK-INITIAL-CONVERT-P. +;;; call analysis, and also when a reference is deleted. We return +;;; true if we converted. (defun maybe-let-convert (clambda) (declare (type clambda clambda)) - (let ((refs (leaf-refs clambda))) - (when (and refs - (null (rest refs)) - (member (functional-kind clambda) '(nil :assignment)) - (not (functional-entry-fun clambda))) - (let* ((ref-cont (node-cont (first refs))) - (dest (continuation-dest ref-cont))) - (when (and dest - (basic-combination-p dest) - (eq (basic-combination-fun dest) ref-cont) - (eq (basic-combination-kind dest) :local) - (not (block-delete-p (node-block dest))) - (cond ((ok-initial-convert-p clambda) t) - (t - (reoptimize-continuation ref-cont) - nil))) - (unless (eq (functional-kind clambda) :assignment) - (let-convert clambda dest)) - (reoptimize-call dest) - (setf (functional-kind clambda) - (if (mv-combination-p dest) :mv-let :let)))) - t))) + (unless (declarations-suppress-let-conversion-p clambda) + ;; We only convert to a LET when the function is a normal local + ;; function, has no XEP, and is referenced in exactly one local + ;; call. Conversion is also inhibited if the only reference is in + ;; a block about to be deleted. + ;; + ;; These rules limiting LET conversion may seem unnecessarily + ;; restrictive, since there are some cases where we could do the + ;; return with a jump that don't satisfy these requirements. The + ;; reason for doing things this way is that it makes the concept + ;; of a LET much more useful at the level of IR1 semantics. The + ;; :ASSIGNMENT function kind provides another way to optimize + ;; calls to single-return/multiple call functions. + ;; + ;; We don't attempt to convert calls to functions that have an + ;; XEP, since we might be embarrassed later when we want to + ;; convert a newly discovered local call. Also, see + ;; OK-INITIAL-CONVERT-P. + (let ((refs (leaf-refs clambda))) + (when (and refs + (null (rest refs)) + (member (functional-kind clambda) '(nil :assignment)) + (not (functional-entry-fun clambda))) + (let* ((ref (first refs)) + (ref-cont (node-cont ref)) + (dest (continuation-dest ref-cont))) + (when (and dest + (basic-combination-p dest) + (eq (basic-combination-fun dest) ref-cont) + (eq (basic-combination-kind dest) :local) + (not (block-delete-p (node-block dest))) + (cond ((ok-initial-convert-p clambda) t) + (t + (reoptimize-continuation ref-cont) + nil))) + (when (eq clambda (node-home-lambda dest)) + (delete-lambda clambda) + (return-from maybe-let-convert nil)) + (unless (eq (functional-kind clambda) :assignment) + (let-convert clambda dest)) + (reoptimize-call dest) + (setf (functional-kind clambda) + (if (mv-combination-p dest) :mv-let :let)))) + t)))) ;;;; tail local calls and assignments @@ -1078,8 +1137,8 @@ (declare (type clambda clambda)) (when (and (not (functional-kind clambda)) (not (functional-entry-fun clambda))) - (let ((non-tail nil) - (call-fun nil)) + (let ((outside-non-tail-call nil) + (outside-call nil)) (when (and (dolist (ref (leaf-refs clambda) t) (let ((dest (continuation-dest (node-cont ref)))) (when (or (not dest) @@ -1087,19 +1146,18 @@ (return nil)) (let ((home (node-home-lambda ref))) (unless (eq home clambda) - (when call-fun + (when outside-call (return nil)) - (setq call-fun home)) + (setq outside-call dest)) (unless (node-tail-p dest) - (when (or non-tail (eq home clambda)) + (when (or outside-non-tail-call (eq home clambda)) (return nil)) - (setq non-tail dest))))) + (setq outside-non-tail-call dest))))) (ok-initial-convert-p clambda)) - (setf (functional-kind clambda) :assignment) - (let-convert clambda - (or non-tail - (continuation-dest - (node-cont (first (leaf-refs clambda)))))) - (when non-tail - (reoptimize-call non-tail)) - t)))) + (cond (outside-call (setf (functional-kind clambda) :assignment) + (let-convert clambda outside-call) + (when outside-non-tail-call + (reoptimize-call outside-non-tail-call)) + t) + (t (delete-lambda clambda) + nil))))))