X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=360c241d5071d763d5d27acc47adfc5f26dc155d;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=3d163b8f3378974b9e4d69d450c6bdb96c394ff7;hpb=581e3d62de8cb37e13ad9db63e5537c0f962be28;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 3d163b8..360c241 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -34,16 +34,14 @@ ;;; continuations. (defun propagate-to-args (call fun) (declare (type combination call) (type clambda fun)) - (do ((args (basic-combination-args call) (cdr args)) - (vars (lambda-vars fun) (cdr vars))) - ((null args)) - (let ((arg (car args)) - (var (car vars))) - (cond ((leaf-refs var) - (assert-continuation-type arg (leaf-type var))) - (t - (flush-dest arg) - (setf (car args) nil))))) + (loop with policy = (lexenv-policy (node-lexenv call)) + for args on (basic-combination-args call) + and var in (lambda-vars fun) + for arg = (assert-continuation-type (car args) + (leaf-type var) policy) + do (unless (leaf-refs var) + (flush-dest (car args)) + (setf (car args) nil))) (values)) @@ -111,9 +109,9 @@ ;;; ;;; If there is a &MORE arg, then there are a couple of optimizations ;;; that we make (more for space than anything else): -;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since +;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since ;;; no argument count error is possible. -;;; -- We can omit the = clause for the last entry-point, allowing the +;;; -- We can omit the = clause for the last entry-point, allowing the ;;; case of 0 more args to fall through to the more entry. ;;; ;;; We don't bother to policy conditionalize wrong arg errors in @@ -133,21 +131,11 @@ (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)) (locally - ;; KLUDGE: The intent here is to enable tail recursion - ;; optimization, since leaving frames for wrapper - ;; functions like this on the stack is actually more - ;; annoying than helpful for debugging. Unfortunately - ;; trying to express this by messing with the - ;; ANSI-standard declarations is a little awkward, since - ;; no matter how we do it we'll tend to have side-effects - ;; on things like SPEED-vs.-SAFETY comparisons. Perhaps - ;; it'd be better to define a new SB-EXT:TAIL-RECURSIVELY - ;; declaration and use that? -- WHN 2002-07-08 - (declare (optimize (speed 2) (debug 1))) + (declare (optimize (merge-tail-calls 3))) (%funcall ,fun ,@temps))))) (optional-dispatch (let* ((min (optional-dispatch-min-args fun)) @@ -156,11 +144,12 @@ (n-supplied (gensym)) (temps (make-gensym-list max))) (collect ((entries)) - (do ((eps (optional-dispatch-entry-points fun) (rest eps)) - (n min (1+ n))) - ((null eps)) - (entries `((= ,n-supplied ,n) - (%funcall ,(first eps) ,@(subseq temps 0 n))))) + ;; Force convertion of all entries + (optional-dispatch-entry-point-fun fun 0) + (loop for ep in (optional-dispatch-entry-points fun) + and n from min + do (entries `((= ,n-supplied ,n) + (%funcall ,(force ep) ,@(subseq temps 0 n))))) `(lambda (,n-supplied ,@temps) ;; FIXME: Make sure that INDEX type distinguishes between ;; target and host. (Probably just make the SB!XC:DEFTYPE @@ -175,11 +164,7 @@ `(multiple-value-bind (,n-context ,n-count) (%more-arg-context ,n-supplied ,max) (locally - ;; KLUDGE: As above, we're trying to - ;; enable tail recursion optimization and - ;; any other effects of this declaration - ;; are accidental. -- WHN 2002-07-08 - (declare (optimize (speed 2) (debug 1))) + (declare (optimize (merge-tail-calls 3))) (%funcall ,more ,@temps ,n-context ,n-count))))))) (t (%arg-count-error ,n-supplied))))))))) @@ -189,7 +174,7 @@ ;;; then associate this lambda with FUN as its XEP. After the ;;; conversion, we iterate over the function's associated lambdas, ;;; redoing local call analysis so that the XEP calls will get -;;; converted. +;;; converted. ;;; ;;; We set REANALYZE and REOPTIMIZE in the component, just in case we ;;; discover an XEP after the initial local call analyze pass. @@ -212,7 +197,7 @@ (locall-analyze-fun-1 fun)) (optional-dispatch (dolist (ep (optional-dispatch-entry-points fun)) - (locall-analyze-fun-1 ep)) + (locall-analyze-fun-1 (force ep))) (when (optional-dispatch-more-entry fun) (locall-analyze-fun-1 (optional-dispatch-more-entry fun))))) res))) @@ -331,7 +316,8 @@ ;; COMPONENT is the only one here. Let's make that explicit. (aver (= 1 (length (functional-components clambda)))) (aver (eql component (first (functional-components clambda)))) - (when (component-new-functionals component) + (when (or (component-new-functionals component) + (component-reanalyze-functionals component)) (setf did-something t) (locall-analyze-component component)))) (unless did-something @@ -348,27 +334,35 @@ (>= speed compilation-speed))) (not (eq (functional-kind (node-home-lambda call)) :external)) (inline-expansion-ok call)) - (multiple-value-bind (losing-local-functional 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-note "couldn't inline expand because expansion ~ - calls this LET-converted local function:~ - ~% ~S" - (leaf-debug-name losing-local-functional))) - original-functional) - (t - (change-ref-leaf ref converted-lambda) - converted-lambda))) + (let* ((end (component-last-block (node-component call))) + (pred (block-prev end))) + (multiple-value-bind (losing-local-functional 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))) + (loop for block = (block-next pred) then (block-next block) + until (eq block end) + do (setf (block-delete-p block) t)) + (loop for block = (block-next pred) then (block-next block) + until (eq block end) + do (delete-block block t)) + original-functional) + (t + (change-ref-leaf ref converted-lambda) + converted-lambda)))) original-functional)) ;;; Dispatch to the appropriate function to attempt to convert a call. @@ -447,7 +441,10 @@ (not (functional-entry-fun fun)) (= (length (leaf-refs fun)) 1) (= (length (basic-combination-args call)) 1)) - (let ((ep (car (last (optional-dispatch-entry-points fun))))) + (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) @@ -455,8 +452,8 @@ (assert-continuation-type (first (basic-combination-args call)) - (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep)) - :rest *universal-type*)))) + (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 @@ -514,8 +511,9 @@ (setf (basic-combination-kind call) :error)) ((<= call-args max-args) (convert-call ref call - (elt (optional-dispatch-entry-points fun) - (- call-args min-args)))) + (let ((*current-component* (node-component ref))) + (optional-dispatch-entry-point-fun + fun (- call-args min-args))))) ((optional-dispatch-more-entry fun) (convert-more-call ref call fun)) (t @@ -545,8 +543,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))))))) @@ -578,6 +576,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) @@ -610,24 +610,35 @@ (let ((cont (first key))) (unless (constant-continuation-p cont) (when flame - (compiler-note "non-constant keyword in keyword call")) + (compiler-notify "non-constant keyword in keyword call")) (setf (basic-combination-kind call) :error) (return-from convert-more-call)) (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-notify "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) @@ -636,7 +647,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) @@ -707,7 +718,7 @@ (join-components component clambda-component))) (let ((*current-component* component)) (node-ends-block call)) - ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other + ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other ;; uses of '=.*length' which could also be converted to use ;; DESTRUCTURING-BIND or PROPER-LIST-OF-LENGTH-P. (aver (= (length (block-succ call-block)) 1)) @@ -766,10 +777,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,20 +799,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-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. @@ -831,15 +842,6 @@ ;;; node, and change the control flow to transfer to NEXT-BLOCK ;;; instead. Move all the uses of the result continuation to CALL's ;;; CONT. -;;; -;;; If the actual continuation is only used by the LET call, then we -;;; intersect the type assertion on the dummy continuation with the -;;; assertion for the actual continuation; in all other cases -;;; assertions on the dummy continuation are lost. -;;; -;;; We also intersect the derived type of the CALL with the derived -;;; type of all the dummy continuation's uses. This serves mainly to -;;; propagate TRULY-THE through LETs. (defun move-return-uses (fun call next-block) (declare (type clambda fun) (type basic-combination call) (type cblock next-block)) @@ -853,10 +855,9 @@ (let ((result (return-result return)) (cont (node-cont call)) (call-type (node-derived-type call))) - (when (eq (continuation-use cont) call) - (assert-continuation-type cont (continuation-asserted-type result))) (unless (eq call-type *wild-type*) - (do-uses (use result) + ;; FIXME: Replace the call with unsafe CAST. -- APD, 2002-01-26 + (do-uses (use result) (derive-node-type use call-type))) (substitute-continuation-uses cont result))) (values)) @@ -940,12 +941,25 @@ (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))))) + (or next-block + (let ((block (node-block call-return))) + (when (block-delete-p block) + (setf (block-delete-p block) nil)) + block))))) (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)) @@ -978,15 +992,16 @@ ;; 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 + ;; 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)) + ;; 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