X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=f98462107ddd01d20e806a8d96ad77d63edeef93;hb=d306e2d23b38487488eb93881dad836e439e0c77;hp=3c5d7a3df4eab8ff4b0fac6994ef3a4952167a5c;hpb=14098373376d990b92a21df123da663b40af7196;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 3c5d7a3..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)))))) @@ -1988,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))) @@ -2020,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))) @@ -2098,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