X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=b25a7754f553879f90a91b0f2b222df02f73d1d6;hb=11214915e9b3151ec66dc3e30e1aa7638c676428;hp=2fdd9d9cb312e279efb413c1d6d600dfa6d1f3a3;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 2fdd9d9..b25a775 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -347,7 +347,7 @@ ;; If next-cont does have a dest, it must be ;; unreachable, since there are no uses. ;; DELETE-CONTINUATION will mark the dest block as - ;; delete-p [and also this block, unless it is no + ;; DELETE-P [and also this block, unless it is no ;; longer backward reachable from the dest block.] (delete-continuation next-cont) (setf (node-prev next-node) last-cont) @@ -497,7 +497,7 @@ (defun ir1-optimize-return (node) (declare (type creturn node)) (let* ((tails (lambda-tail-set (return-lambda node))) - (funs (tail-set-functions tails))) + (funs (tail-set-funs tails))) (collect ((res *empty-type* values-type-union)) (dolist (fun funs) (let ((return (lambda-return fun))) @@ -509,7 +509,7 @@ (when (type/= (res) (tail-set-type tails)) (setf (tail-set-type tails) (res)) - (dolist (fun (tail-set-functions tails)) + (dolist (fun (tail-set-funs tails)) (dolist (ref (leaf-refs fun)) (reoptimize-continuation (node-cont ref))))))) @@ -548,13 +548,13 @@ (flush-dest test) (when (rest (block-succ block)) (unlink-blocks block victim)) - (setf (component-reanalyze (block-component (node-block node))) t) + (setf (component-reanalyze (node-component node)) t) (unlink-node node)))) (values)) -;;; Create a new copy of an IF Node that tests the value of the node -;;; Use. The test must have >1 use, and must be immediately used by -;;; Use. Node must be the only node in its block (implying that +;;; Create a new copy of an IF node that tests the value of the node +;;; USE. The test must have >1 use, and must be immediately used by +;;; USE. NODE must be the only node in its block (implying that ;;; block-start = if-test). ;;; ;;; This optimization has an effect semantically similar to the @@ -568,7 +568,7 @@ ;;; become unreachable, resulting in a spurious note. (defun convert-if-if (use node) (declare (type node use) (type cif node)) - (with-ir1-environment node + (with-ir1-environment-from-node node (let* ((block (node-block node)) (test (if-test node)) (cblock (if-consequent node)) @@ -580,7 +580,7 @@ :consequent cblock :alternative ablock)) (new-block (continuation-starts-block new-cont))) - (prev-link new-node new-cont) + (link-node-to-previous-continuation new-node new-cont) (setf (continuation-dest new-cont) new-node) (add-continuation-use new-node dummy-cont) (setf (block-last new-block) new-node) @@ -687,8 +687,8 @@ ;; cross-compiler doesn't know how to evaluate it. #+sb-xc-host (let* ((ref (continuation-use (combination-fun node))) - (fun (leaf-name (ref-leaf ref)))) - (fboundp fun))) + (fun-name (leaf-source-name (ref-leaf ref)))) + (fboundp fun-name))) (constant-fold-call node) (return-from ir1-optimize-combination))) @@ -767,7 +767,7 @@ ;;; wondering if something should be done to special-case the call. If ;;; CALL is a call to a global function, then see whether it defined ;;; or known: -;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert +;;; -- If a DEFINED-FUN should be inline expanded, then convert ;;; the expansion and change the call to call it. Expansion is ;;; enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is ;;; true, we never expand, since this function has already been @@ -788,8 +788,8 @@ (declare (type combination call)) (let* ((ref (continuation-use (basic-combination-fun call))) (leaf (when (ref-p ref) (ref-leaf ref))) - (inlinep (if (defined-function-p leaf) - (defined-function-inlinep leaf) + (inlinep (if (defined-fun-p leaf) + (defined-fun-inlinep leaf) :no-chance))) (cond ((eq inlinep :notinline) (values nil nil)) @@ -800,34 +800,38 @@ (:inline t) (:no-chance nil) ((nil :maybe-inline) (policy call (zerop space)))) - (defined-function-inline-expansion leaf) - (let ((fun (defined-function-functional leaf))) + ;; FIXME: In sbcl-0.pre7.87, it looks as though we'll + ;; get here when LEAF is a GLOBAL-VAR (not a DEFINED-FUN) + ;; whenever (ZEROP SPACE), in which case we'll die with + ;; a type error when we try to access LEAF as a DEFINED-FUN. + (defined-fun-inline-expansion leaf) + (let ((fun (defined-fun-functional leaf))) (or (not fun) (and (eq inlinep :inline) (functional-kind fun)))) (inline-expansion-ok call)) (flet ((frob () (let ((res (ir1-convert-lambda-for-defun - (defined-function-inline-expansion leaf) + (defined-fun-inline-expansion leaf) leaf t #'ir1-convert-inline-lambda))) - (setf (defined-function-functional leaf) res) + (setf (defined-fun-functional leaf) res) (change-ref-leaf ref res)))) (if ir1-p (frob) - (with-ir1-environment call + (with-ir1-environment-from-node call (frob) - (local-call-analyze *current-component*)))) + (locall-analyze-component *current-component*)))) (values (ref-leaf (continuation-use (basic-combination-fun call))) nil)) (t - (let* ((name (leaf-name leaf)) + (let* ((name (leaf-source-name leaf)) (info (info :function :info (if (slot-accessor-p leaf) - (if (consp name) - '%slot-setter - '%slot-accessor) - name)))) + (if (consp source-name) ; i.e. if SETF function + '%slot-setter + '%slot-accessor) + name)))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) @@ -875,7 +879,7 @@ (values nil nil)))) ;;; This is called by IR1-OPTIMIZE when the function for a call has -;;; changed. If the call is local, we try to let-convert it, and +;;; changed. If the call is local, we try to LET-convert it, and ;;; derive the result type. If it is a :FULL call, we validate it ;;; against the type, which recognizes known calls, does inline ;;; expansion, etc. If a call to a predicate in a non-conditional @@ -900,19 +904,30 @@ (continuation-use (basic-combination-fun call)) call)) ((not leaf)) - ((or (info :function :source-transform (leaf-name leaf)) + ((or (info :function :source-transform (leaf-source-name leaf)) (and info (ir1-attributep (function-info-attributes info) predicate) (let ((dest (continuation-dest (node-cont call)))) (and dest (not (if-p dest)))))) - (let ((name (leaf-name leaf))) - (when (symbolp name) - (let ((dums (make-gensym-list (length - (combination-args call))))) - (transform-call call - `(lambda ,dums - (,name ,@dums)))))))))))) + (when (and (leaf-has-source-name-p leaf) + ;; FIXME: This SYMBOLP is part of a literal + ;; translation of a test in the old CMU CL + ;; source, and it's not quite clear what + ;; the old source meant. Did it mean "has a + ;; valid name"? Or did it mean "is an + ;; ordinary function name, not a SETF + ;; function"? Either way, the old CMU CL + ;; code probably didn't deal with SETF + ;; functions correctly, and neither does + ;; this new SBCL code, and that should be fixed. + (symbolp (leaf-source-name leaf))) + (let ((dummies (make-gensym-list (length + (combination-args call))))) + (transform-call call + `(lambda ,dummies + (,(leaf-source-name leaf) + ,@dummies))))))))))) (values)) ;;;; known function optimization @@ -1068,18 +1083,20 @@ ;;; integrated into the control flow. (defun transform-call (node res) (declare (type combination node) (list res)) - (with-ir1-environment node - (let ((new-fun (ir1-convert-inline-lambda res)) + (with-ir1-environment-from-node node + (let ((new-fun (ir1-convert-inline-lambda + res + :debug-name "something inlined in TRANSFORM-CALL")) (ref (continuation-use (combination-fun node)))) (change-ref-leaf ref new-fun) (setf (combination-kind node) :full) - (local-call-analyze *current-component*))) + (locall-analyze-component *current-component*))) (values)) ;;; Replace a call to a foldable function of constant arguments with ;;; the result of evaluating the form. We insert the resulting ;;; constant node after the call, stealing the call's continuation. We -;;; give the call a continuation with no Dest, which should cause it +;;; give the call a continuation with no DEST, which should cause it ;;; and its arguments to go away. If there is an error during the ;;; evaluation, we give a warning and leave the call alone, making the ;;; call a :ERROR call. @@ -1090,10 +1107,10 @@ (declare (type combination call)) (let* ((args (mapcar #'continuation-value (combination-args call))) (ref (continuation-use (combination-fun call))) - (fun (leaf-name (ref-leaf ref)))) + (fun-name (leaf-source-name (ref-leaf ref)))) (multiple-value-bind (values win) - (careful-call fun args call "constant folding") + (careful-call fun-name args call "constant folding") (if (not win) (setf (combination-kind call) :error) (let ((dummies (make-gensym-list (length args)))) @@ -1158,12 +1175,11 @@ ((or constant functional) t) (lambda-var (null (lambda-var-sets leaf))) - (defined-function - (not (eq (defined-function-inlinep leaf) :notinline))) + (defined-fun + (not (eq (defined-fun-inlinep leaf) :notinline))) (global-var (case (global-var-kind leaf) - (:global-function t) - (:constant t)))))) + (:global-function t)))))) ;;; If we have a non-set LET var with a single use, then (if possible) ;;; replace the variable reference's CONT with the arg continuation. @@ -1226,7 +1242,7 @@ ;;; changes. We look at each changed argument. If the corresponding ;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we ;;; consider substituting for the variable, and also propagate -;;; derived-type information for the arg to all the Var's refs. +;;; derived-type information for the arg to all the VAR's refs. ;;; ;;; Substitution is inhibited when the arg leaf's derived type isn't a ;;; subtype of the argument's asserted type. This prevents type @@ -1235,7 +1251,7 @@ ;;; ;;; Substitution of individual references is inhibited if the ;;; reference is in a different component from the home. This can only -;;; happen with closures over top-level lambda vars. In such cases, +;;; happen with closures over top level lambda vars. In such cases, ;;; the references may have already been compiled, and thus can't be ;;; retroactively modified. ;;; @@ -1243,7 +1259,7 @@ ;;; are done, then we delete the LET. ;;; ;;; Note that we are responsible for clearing the -;;; Continuation-Reoptimize flags. +;;; CONTINUATION-REOPTIMIZE flags. (defun propagate-let-args (call fun) (declare (type combination call) (type clambda fun)) (loop for arg in (combination-args call) @@ -1260,15 +1276,13 @@ (values-subtypep (leaf-type leaf) (continuation-asserted-type arg))) (propagate-to-refs var (continuation-type arg)) - (let ((this-comp (block-component (node-block use)))) + (let ((use-component (node-component use))) (substitute-leaf-if #'(lambda (ref) - (cond ((eq (block-component (node-block ref)) - this-comp) + (cond ((eq (node-component ref) use-component) t) (t - (aver (eq (functional-kind (lambda-home fun)) - :top-level)) + (aver (lambda-toplevelish-p (lambda-home fun))) nil))) leaf var)) t))))) @@ -1297,7 +1311,7 @@ (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) - (unless (or (functional-entry-function fun) + (unless (or (functional-entry-fun fun) (lambda-optional-dispatch fun)) (let* ((vars (lambda-vars fun)) (union (mapcar #'(lambda (arg var) @@ -1466,7 +1480,7 @@ min) (t nil)))) (when count - (with-ir1-environment node + (with-ir1-environment-from-node node (let* ((dums (make-gensym-list count)) (ignore (gensym)) (fun (ir1-convert-lambda @@ -1475,7 +1489,7 @@ (funcall ,(ref-leaf ref) ,@dums))))) (change-ref-leaf ref fun) (aver (eq (basic-combination-kind node) :full)) - (local-call-analyze *current-component*) + (locall-analyze-component *current-component*) (aver (eq (basic-combination-kind node) :local))))))))) (values)) @@ -1510,7 +1524,7 @@ (mapc #'flush-dest (subseq vals nvars)) (setq vals (subseq vals 0 nvars))) ((< nvals nvars) - (with-ir1-environment use + (with-ir1-environment-from-node use (let ((node-prev (node-prev use))) (setf (node-prev use) nil) (setf (continuation-next node-prev) nil) @@ -1521,7 +1535,8 @@ do (reference-constant prev cont nil) (res cont)) (setq vals (res))) - (prev-link use (car (last vals))))))) + (link-node-to-previous-continuation use + (car (last vals))))))) (setf (combination-args use) vals) (flush-dest (combination-fun use)) (let ((fun-cont (basic-combination-fun call)))