X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=e16d8d60baa163b1d619b9b9af8fbc099becba86;hb=9ef324a619b3ea13ba688d4be2ef22931e62a744;hp=9846de756b9518c5df290cbf83fe78ef310c52ed;hpb=13fb43363e194ac787e287f447856165d6bb064d;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 9846de7..e16d8d6 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))))) @@ -427,7 +428,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. ;;; @@ -456,7 +457,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 @@ -578,6 +580,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) @@ -617,17 +621,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) @@ -766,10 +781,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 @@ -788,18 +803,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. @@ -808,17 +825,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)) @@ -852,7 +869,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))) @@ -970,58 +990,83 @@ (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 (> DEBUG SPEED) 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 (> debug speed)) + (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 @@ -1096,8 +1141,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) @@ -1105,19 +1150,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))))))