X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flocall.lisp;h=be089db61406e8b64a483702e5891d0820887f23;hb=9767de1cecfe50560fe1da69fd458b6148a66da3;hp=ae4ad080dba81e34272ceb09d17fe891dd6178ad;hpb=f294da03824843f07d781e655d5a5e70c2c4851e;p=sbcl.git diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index ae4ad08..be089db 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -34,17 +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) - (lexenv-policy (node-lexenv call)))) - (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)) @@ -112,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 @@ -147,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 @@ -176,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. @@ -199,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))) @@ -318,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,9 +347,9 @@ 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" + (compiler-notify "couldn't inline expand because expansion ~ + calls this LET-converted local function:~ + ~% ~S" (leaf-debug-name losing-local-functional))) original-functional) (t @@ -434,7 +433,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) @@ -442,8 +444,7 @@ (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)) @@ -502,8 +503,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 @@ -600,7 +602,7 @@ (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)) @@ -614,7 +616,7 @@ (setq allow-found t allowp (continuation-value val))) (t (when flame - (compiler-note "non-constant :ALLOW-OTHER-KEYS value")) + (compiler-notify "non-constant :ALLOW-OTHER-KEYS value")) (setf (basic-combination-kind call) :error) (return-from convert-more-call))))) (dolist (var (key-vars) @@ -637,7 +639,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) @@ -708,7 +710,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)) @@ -832,15 +834,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)) @@ -854,13 +847,9 @@ (let ((result (return-result return)) (cont (node-cont call)) (call-type (node-derived-type call))) - (when (eq (continuation-use cont) call) - (set-continuation-type-assertion - cont - (continuation-asserted-type result) - (continuation-type-to-check 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)) @@ -953,7 +942,11 @@ (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)