X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f98462107ddd01d20e806a8d96ad77d63edeef93;hb=b2ed34b667665e52609cf431c00179b136be450d;hp=961d1c4427fc41904f9e61e1b8c49bafed257d47;hpb=12836ca105af62252aa0974c3f6992e60ce0ebf4;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 961d1c4..f984621 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -166,7 +166,14 @@ :specialized-element-type (array-type-specialized-element-type type)) ;; Simple arrays cannot change at all. type)) + ((union-type-p type) + ;; Conservative union type is an union of conservative types. + (let ((res *empty-type*)) + (dolist (part (union-type-types type) res) + (setf res (type-union res (conservative-type part)))))) (t + ;; Catch-all. + ;; ;; If the type contains some CONS types, the conservative type contains all ;; of them. (when (types-equal-or-intersect type (specifier-type 'cons)) @@ -222,7 +229,7 @@ it (coerce-to-values type))) (t (coerce-to-values type))))) dest))))) - (lvar-%externally-checkable-type lvar)) + (or (lvar-%externally-checkable-type lvar) *wild-type*)) #!-sb-fluid(declaim (inline flush-lvar-externally-checkable-type)) (defun flush-lvar-externally-checkable-type (lvar) (declare (type lvar lvar)) @@ -282,16 +289,20 @@ ;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the ;;; intersection is different from the old type, then we do a ;;; REOPTIMIZE-LVAR on the NODE-LVAR. -(defun derive-node-type (node rtype) +(defun derive-node-type (node rtype &key from-scratch) (declare (type valued-node node) (type ctype rtype)) - (let ((node-type (node-derived-type node))) - (unless (eq node-type rtype) + (let* ((initial-type (node-derived-type node)) + (node-type (if from-scratch + *wild-type* + initial-type))) + (unless (eq initial-type rtype) (let ((int (values-type-intersection node-type rtype)) (lvar (node-lvar node))) - (when (type/= node-type int) + (when (type/= initial-type int) (when (and *check-consistency* (eq int *empty-type*) (not (eq rtype *empty-type*))) + (aver (not from-scratch)) (let ((*compiler-error-context* node)) (compiler-warn "New inferred type ~S conflicts with old type:~ @@ -511,17 +522,19 @@ ;;; Delete any nodes in BLOCK whose value is unused and which have no ;;; side effects. We can delete sets of lexical variables when the set ;;; variable has no references. -(defun flush-dead-code (block) +(defun flush-dead-code (block &aux victim) (declare (type cblock block)) (setf (block-flush-p block) nil) (do-nodes-backwards (node lvar block :restart-p t) (unless lvar (typecase node (ref + (setf victim node) (delete-ref node) (unlink-node node)) (combination (when (flushable-combination-p node) + (setf victim node) (flush-combination node))) (mv-combination (when (eq (basic-combination-kind node) :local) @@ -530,27 +543,31 @@ (when (or (leaf-refs var) (lambda-var-sets var)) (return nil))) + (setf victim node) (flush-dest (first (basic-combination-args node))) (delete-let fun))))) (exit (let ((value (exit-value node))) (when value + (setf victim node) (flush-dest value) (setf (exit-value node) nil)))) (cset (let ((var (set-var node))) (when (and (lambda-var-p var) (null (leaf-refs var))) + (setf victim node) (flush-dest (set-value node)) (setf (basic-var-sets var) (delq node (basic-var-sets var))) (unlink-node node)))) (cast (unless (cast-type-check node) + (setf victim node) (flush-dest (cast-value node)) (unlink-node node)))))) - (values)) + victim) ;;;; local call return type propagation @@ -653,7 +670,8 @@ ;;; is the case. ;;; Similarly, when both branches are equivalent, branch directly to either ;;; of them. -;;; Also, if the test has multiple uses, replicate the node when possible. +;;; Also, if the test has multiple uses, replicate the node when possible... +;;; in fact, splice in direct jumps to the right branch if possible. (defun ir1-optimize-if (node) (declare (type cif node)) (let ((test (if-test node)) @@ -668,23 +686,67 @@ alternative) ((type= type (specifier-type 'null)) consequent) - ((cblocks-equivalent-p alternative consequent) + ((or (eq consequent alternative) ; Can this happen? + (cblocks-equivalent-p alternative consequent)) alternative)))) (when victim - (flush-dest test) - (when (rest (block-succ block)) - (unlink-blocks block victim)) - (setf (component-reanalyze (node-component node)) t) - (unlink-node node) + (kill-if-branch-1 node test block victim) (return-from ir1-optimize-if (values)))) + (tension-if-if-1 node test block) + (duplicate-if-if-1 node test block) + (values))) - (when (and (eq (block-start-node block) node) - (listp (lvar-uses test))) - (do-uses (use test) - (when (immediately-used-p test use) - (convert-if-if use node) - (when (not (listp (lvar-uses test))) (return)))))) - (values)) +;; When we know that we only have a single successor, kill the victim +;; ... unless the victim and the remaining successor are the same. +(defun kill-if-branch-1 (node test block victim) + (declare (type cif node)) + (flush-dest test) + (when (rest (block-succ block)) + (unlink-blocks block victim)) + (setf (component-reanalyze (node-component node)) t) + (unlink-node node)) + +;; When if/if conversion would leave (if ... (if nil ...)) or +;; (if ... (if not-nil ...)), splice the correct successor right +;; in. +(defun tension-if-if-1 (node test block) + (when (and (eq (block-start-node block) node) + (listp (lvar-uses test))) + (do-uses (use test) + (when (immediately-used-p test use) + (let* ((type (single-value-type (node-derived-type use))) + (target (if (type= type (specifier-type 'null)) + (if-alternative node) + (multiple-value-bind (typep surep) + (ctypep nil type) + (and (not typep) surep + (if-consequent node)))))) + (when target + (let ((pred (node-block use))) + (cond ((listp (lvar-uses test)) + (change-block-successor pred block target) + (delete-lvar-use use)) + (t + ;; only one use left. Just kill the now-useless + ;; branch to avoid spurious code deletion notes. + (aver (rest (block-succ block))) + (kill-if-branch-1 + node test block + (if (eql target (if-alternative node)) + (if-consequent node) + (if-alternative node))) + (return-from tension-if-if-1)))))))))) + +;; Finally, duplicate EQ-nil tests +(defun duplicate-if-if-1 (node test block) + (when (and (eq (block-start-node block) node) + (listp (lvar-uses test))) + (do-uses (use test) + (when (immediately-used-p test use) + (convert-if-if use node) + ;; leave the last use as is, instead of replacing + ;; the (singly-referenced) CIF node with a duplicate. + (when (not (listp (lvar-uses test))) (return)))))) ;;; 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 @@ -882,7 +944,7 @@ ;; The VM mostly knows how to handle this. We need ;; to massage the call slightly, though. (transform-call node transform (combination-fun-source-name node))) - (:default + ((:default :maybe) ;; Let transforms have a crack at it. (dolist (x (fun-info-transforms info)) #!+sb-show @@ -1304,7 +1366,7 @@ '(optimize (preserve-single-use-debug-variables 0)) (lexenv-policy - (combination-lexenv call))))) + (combination-lexenv call))))) (with-ir1-environment-from-node call (with-component-last-block (*current-component* (block-next (node-block call))) @@ -1715,9 +1777,7 @@ leaf var))) t))))) ((and (null (rest (leaf-refs var))) - ;; Don't substitute single-ref variables on high-debug / - ;; low speed, to improve the debugging experience. - (policy call (< preserve-single-use-debug-variables 3)) + (not (preserve-single-use-debug-var-p call var)) (substitute-single-use-lvar arg var))) (t (propagate-to-refs var (lvar-type arg)))))) @@ -1735,6 +1795,11 @@ ;;; If the function has an entry-fun, then we don't do anything: since ;;; it has a XEP we would not discover anything. ;;; +;;; If the function is an optional-entry-point, we will just make sure +;;; &REST lists are known to be lists. Doing the regular rigamarole +;;; can erronously propagate too strict types into refs: see +;;; BUG-655203-REGRESSION in tests/compiler.pure.lisp. +;;; ;;; We can clear the LVAR-REOPTIMIZE flags for arguments in all calls ;;; corresponding to changed arguments in CALL, since the only use in ;;; IR1 optimization of the REOPTIMIZE flag for local call args is @@ -1742,34 +1807,41 @@ (defun propagate-local-call-args (call fun) (declare (type combination call) (type clambda fun)) (unless (functional-entry-fun fun) - (let* ((vars (lambda-vars fun)) - (union (mapcar (lambda (arg var) - (when (and arg - (lvar-reoptimize arg) - (null (basic-var-sets var))) - (lvar-type arg))) - (basic-combination-args call) - vars)) - (this-ref (lvar-use (basic-combination-fun call)))) - - (dolist (arg (basic-combination-args call)) - (when arg - (setf (lvar-reoptimize arg) nil))) - - (dolist (ref (leaf-refs fun)) - (let ((dest (node-dest ref))) - (unless (or (eq ref this-ref) (not dest)) - (setq union - (mapcar (lambda (this-arg old) - (when old - (setf (lvar-reoptimize this-arg) nil) - (type-union (lvar-type this-arg) old))) - (basic-combination-args dest) - union))))) - - (loop for var in vars - and type in union - when type do (propagate-to-refs var type)))) + (if (lambda-optional-dispatch fun) + ;; We can still make sure &REST is known to be a list. + (loop for var in (lambda-vars fun) + do (let ((info (lambda-var-arg-info var))) + (when (and info (eq :rest (arg-info-kind info))) + (propagate-from-sets var (specifier-type 'list))))) + ;; The normal case. + (let* ((vars (lambda-vars fun)) + (union (mapcar (lambda (arg var) + (when (and arg + (lvar-reoptimize arg) + (null (basic-var-sets var))) + (lvar-type arg))) + (basic-combination-args call) + vars)) + (this-ref (lvar-use (basic-combination-fun call)))) + + (dolist (arg (basic-combination-args call)) + (when arg + (setf (lvar-reoptimize arg) nil))) + + (dolist (ref (leaf-refs fun)) + (let ((dest (node-dest ref))) + (unless (or (eq ref this-ref) (not dest)) + (setq union + (mapcar (lambda (this-arg old) + (when old + (setf (lvar-reoptimize this-arg) nil) + (type-union (lvar-type this-arg) old))) + (basic-combination-args dest) + union))))) + + (loop for var in vars + and type in union + when type do (propagate-to-refs var type))))) (values)) @@ -1976,6 +2048,15 @@ (unlink-node call) (when vals (reoptimize-lvar (first vals))) + ;; Propagate derived types from the VALUES call to its args: + ;; transforms can leave the VALUES call with a better type + ;; than its args have, so make sure not to throw that away. + (let ((types (values-type-types (node-derived-type use)))) + (dolist (val vals) + (when types + (let ((type (pop types))) + (assert-lvar-type val type '((type-check . 0))))))) + ;; Propagate declared types of MV-BIND variables. (propagate-to-args use fun) (reoptimize-call use)) t))) @@ -2008,6 +2089,7 @@ (flush-lvar-externally-checkable-type arg)) (setf (combination-args use) nil) (flush-dest list) + (flush-combination use) (setf (combination-args node) args)) t))) @@ -2086,17 +2168,20 @@ (unless (eq value-type *empty-type*) ;; FIXME: Do it in one step. - (filter-lvar - value - (if (cast-single-value-p cast) - `(list 'dummy) - `(multiple-value-call #'list 'dummy))) - (filter-lvar - (cast-value cast) - ;; FIXME: Derived type. - `(%compile-time-type-error 'dummy - ',(type-specifier atype) - ',(type-specifier value-type))) + (let ((context (cons (node-source-form cast) + (lvar-all-sources (cast-value cast))))) + (filter-lvar + value + (if (cast-single-value-p cast) + `(list 'dummy) + `(multiple-value-call #'list 'dummy))) + (filter-lvar + (cast-value cast) + ;; FIXME: Derived type. + `(%compile-time-type-error 'dummy + ',(type-specifier atype) + ',(type-specifier value-type) + ',context))) ;; KLUDGE: FILTER-LVAR does not work for non-returning ;; functions, so we declare the return type of ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type