(defun constant-lvar-p (thing)
(declare (type (or lvar null) thing))
(and (lvar-p thing)
- (let ((use (principal-lvar-use thing)))
- (and (ref-p use) (constant-p (ref-leaf use))))))
+ (or (let ((use (principal-lvar-use thing)))
+ (and (ref-p use) (constant-p (ref-leaf use))))
+ ;; check for EQL types (but not singleton numeric types)
+ (let ((type (lvar-type thing)))
+ (values (type-singleton-p type))))))
;;; Return the constant value for an LVAR whose only use is a constant
;;; node.
(declaim (ftype (function (lvar) t) lvar-value))
(defun lvar-value (lvar)
- (let ((use (principal-lvar-use lvar)))
- (constant-value (ref-leaf use))))
+ (let ((use (principal-lvar-use lvar))
+ (type (lvar-type lvar))
+ leaf)
+ (if (and (ref-p use)
+ (constant-p (setf leaf (ref-leaf use))))
+ (constant-value leaf)
+ (multiple-value-bind (constantp value) (type-singleton-p type)
+ (unless constantp
+ (error "~S used on non-constant LVAR ~S" 'lvar-value lvar))
+ value))))
\f
;;;; interface for obtaining results of type inference
: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))
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))
;;; 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:~
(dest (lvar-dest lvar)))
(substitute-lvar internal-lvar lvar)
(let ((cast (insert-cast-before dest lvar type policy)))
- (use-lvar cast internal-lvar))))
- (values))
+ (use-lvar cast internal-lvar)
+ t))))
\f
;;;; IR1-OPTIMIZE
;;; 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
- (let ((kind (combination-kind node))
- (info (combination-fun-info node)))
- (when (and (eq kind :known) (fun-info-p info))
- (let ((attr (fun-info-attributes info)))
- (when (and (not (ir1-attributep attr call))
- ;; ### For now, don't delete potentially
- ;; flushable calls when they have the CALL
- ;; attribute. Someday we should look at the
- ;; functional args to determine if they have
- ;; any side effects.
- (if (policy node (= safety 3))
- (ir1-attributep attr flushable)
- (ir1-attributep attr unsafely-flushable)))
- (flush-combination node))))))
+ (when (flushable-combination-p node)
+ (setf victim node)
+ (flush-combination node)))
(mv-combination
(when (eq (basic-combination-kind node) :local)
(let ((fun (combination-lambda node)))
(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)
\f
;;;; local call return type propagation
\f
;;;; IF optimization
-;;; If the test has multiple uses, replicate the node when possible.
-;;; Also check whether the predicate is known to be true or false,
+;;; Utility: return T if both argument cblocks are equivalent. For now,
+;;; detect only blocks that read the same leaf into the same lvar, and
+;;; continue to the same block.
+(defun cblocks-equivalent-p (x y)
+ (declare (type cblock x y))
+ (and (ref-p (block-start-node x))
+ (eq (block-last x) (block-start-node x))
+
+ (ref-p (block-start-node y))
+ (eq (block-last y) (block-start-node y))
+
+ (equal (block-succ x) (block-succ y))
+ (eql (ref-lvar (block-start-node x)) (ref-lvar (block-start-node y)))
+ (eql (ref-leaf (block-start-node x)) (ref-leaf (block-start-node y)))))
+
+;;; Check whether the predicate is known to be true or false,
;;; deleting the IF node in favor of the appropriate branch when this
;;; 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...
+;;; 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))
(block (node-block node)))
-
- (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)))))
-
(let* ((type (lvar-type test))
+ (consequent (if-consequent node))
+ (alternative (if-alternative node))
(victim
(cond ((constant-lvar-p test)
- (if (lvar-value test)
- (if-alternative node)
- (if-consequent node)))
+ (if (lvar-value test) alternative consequent))
((not (types-equal-or-intersect type (specifier-type 'null)))
- (if-alternative node))
+ alternative)
((type= type (specifier-type 'null))
- (if-consequent node)))))
+ 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))))
- (values))
+ (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 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
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil)))
- (when info
- (check-important-result node info)
- (let ((fun (fun-info-destroyed-constant-args info)))
- (when fun
- (let ((destroyed-constant-args (funcall fun args)))
- (when destroyed-constant-args
- (let ((*compiler-error-context* node))
- (warn 'constant-modified
- :fun-name (lvar-fun-name
- (basic-combination-fun node)))
- (setf (basic-combination-kind node) :error)
- (return-from ir1-optimize-combination))))))
- (let ((fun (fun-info-derive-type info)))
- (when fun
- (let ((res (funcall fun node)))
- (when res
- (derive-node-type node (coerce-to-values res))
- (maybe-terminate-block node nil)))))))
+ (cond (info
+ (check-important-result node info)
+ (let ((fun (fun-info-destroyed-constant-args info)))
+ (when fun
+ (let ((destroyed-constant-args (funcall fun args)))
+ (when destroyed-constant-args
+ (let ((*compiler-error-context* node))
+ (warn 'constant-modified
+ :fun-name (lvar-fun-name
+ (basic-combination-fun node)))
+ (setf (basic-combination-kind node) :error)
+ (return-from ir1-optimize-combination))))))
+ (let ((fun (fun-info-derive-type info)))
+ (when fun
+ (let ((res (funcall fun node)))
+ (when res
+ (derive-node-type node (coerce-to-values res))
+ (maybe-terminate-block node nil))))))
+ (t
+ ;; Check against the DEFINED-TYPE unless TYPE is already good.
+ (let* ((fun (basic-combination-fun node))
+ (uses (lvar-uses fun))
+ (leaf (when (ref-p uses) (ref-leaf uses))))
+ (multiple-value-bind (type defined-type)
+ (if (global-var-p leaf)
+ (values (leaf-type leaf) (leaf-defined-type leaf))
+ (values nil nil))
+ (when (and (not (fun-type-p type)) (fun-type-p defined-type))
+ (validate-call-type node type leaf)))))))
(:known
(aver info)
(dolist (arg args)
;; 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
;;; syntax check, arg/result type processing, but still call
;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
;;; and that checking is done by local call analysis.
-(defun validate-call-type (call type defined-type ir1-converting-not-optimizing-p)
+(defun validate-call-type (call type fun &optional ir1-converting-not-optimizing-p)
(declare (type combination call) (type ctype type))
- (cond ((not (fun-type-p type))
- (aver (multiple-value-bind (val win)
- (csubtypep type (specifier-type 'function))
- (or val (not win))))
- ;; In the commonish case where the function has been defined
- ;; in another file, we only get FUNCTION for the type; but we
- ;; can check whether the current call is valid for the
- ;; existing definition, even if only to STYLE-WARN about it.
- (when defined-type
- (valid-fun-use call defined-type
+ (let* ((where (when fun (leaf-where-from fun)))
+ (same-file-p (eq :defined-here where)))
+ (cond ((not (fun-type-p type))
+ (aver (multiple-value-bind (val win)
+ (csubtypep type (specifier-type 'function))
+ (or val (not win))))
+ ;; Using the defined-type too early is a bit of a waste: during
+ ;; conversion we cannot use the untrusted ASSERT-CALL-TYPE, etc.
+ (when (and fun (not ir1-converting-not-optimizing-p))
+ (let ((defined-type (leaf-defined-type fun)))
+ (when (and (fun-type-p defined-type)
+ (neq fun (combination-type-validated-for-leaf call)))
+ ;; Don't validate multiple times against the same leaf --
+ ;; it doesn't add any information, but may generate the same warning
+ ;; multiple times.
+ (setf (combination-type-validated-for-leaf call) fun)
+ (when (and (valid-fun-use call defined-type
+ :argument-test #'always-subtypep
+ :result-test nil
+ :lossage-fun (if same-file-p
+ #'compiler-warn
+ #'compiler-style-warn)
+ :unwinnage-fun #'compiler-notify)
+ same-file-p)
+ (assert-call-type call defined-type nil)
+ (maybe-terminate-block call ir1-converting-not-optimizing-p)))))
+ (recognize-known-call call ir1-converting-not-optimizing-p))
+ ((valid-fun-use call type
:argument-test #'always-subtypep
:result-test nil
- :lossage-fun #'compiler-style-warn
- :unwinnage-fun #'compiler-notify))
- (recognize-known-call call ir1-converting-not-optimizing-p))
- ((valid-fun-use call type
- :argument-test #'always-subtypep
- :result-test nil
- ;; KLUDGE: Common Lisp is such a dynamic
- ;; language that all we can do here in
- ;; general is issue a STYLE-WARNING. It
- ;; would be nice to issue a full WARNING
- ;; in the special case of of type
- ;; mismatches within a compilation unit
- ;; (as in section 3.2.2.3 of the spec)
- ;; but at least as of sbcl-0.6.11, we
- ;; don't keep track of whether the
- ;; mismatched data came from the same
- ;; compilation unit, so we can't do that.
- ;; -- WHN 2001-02-11
- ;;
- ;; FIXME: Actually, I think we could
- ;; issue a full WARNING if the call
- ;; violates a DECLAIM FTYPE.
- :lossage-fun #'compiler-style-warn
- :unwinnage-fun #'compiler-notify)
- (assert-call-type call type)
- (maybe-terminate-block call ir1-converting-not-optimizing-p)
- (recognize-known-call call ir1-converting-not-optimizing-p))
- (t
- (setf (combination-kind call) :error)
- (values nil nil))))
+ :lossage-fun #'compiler-warn
+ :unwinnage-fun #'compiler-notify)
+ (assert-call-type call type)
+ (maybe-terminate-block call ir1-converting-not-optimizing-p)
+ (recognize-known-call call ir1-converting-not-optimizing-p))
+ (t
+ (setf (combination-kind call) :error)
+ (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
(derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full
(multiple-value-bind (leaf info)
- (validate-call-type call (lvar-type fun-lvar) nil nil)
+ (let* ((uses (lvar-uses fun-lvar))
+ (leaf (when (ref-p uses) (ref-leaf uses))))
+ (validate-call-type call (lvar-type fun-lvar) leaf))
(cond ((functional-p leaf)
(convert-call-if-possible
(lvar-uses (basic-combination-fun call))
'(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)))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
(setf (combination-kind call) :full)
- (maybe-propagate-dynamic-extent call new-fun)
(locall-analyze-component *current-component*))))
(values))
(declare (type lvar arg) (type lambda-var var))
(binding* ((ref (first (leaf-refs var)))
(lvar (node-lvar ref) :exit-if-null)
- (dest (lvar-dest lvar)))
+ (dest (lvar-dest lvar))
+ (dest-lvar (when (valued-node-p dest) (node-lvar dest))))
(when (and
;; Think about (LET ((A ...)) (IF ... A ...)): two
;; LVAR-USEs should not be met on one path. Another problem
;; is with dynamic-extent.
(eq (lvar-uses lvar) ref)
(not (block-delete-p (node-block ref)))
+ ;; If the destinatation is dynamic extent, don't substitute unless
+ ;; the source is as well.
+ (or (not dest-lvar)
+ (not (lvar-dynamic-extent dest-lvar))
+ (lvar-dynamic-extent lvar))
(typecase dest
;; we should not change lifetime of unknown values lvars
(cast
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))))))
;;; variable, we compute the union of the types across all calls and
;;; propagate this type information to the var's refs.
;;;
-;;; If the function has an XEP, then we don't do anything, since we
-;;; won't discover anything.
+;;; 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
;;; right here.
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
- (unless (or (functional-entry-fun fun)
- (lambda-optional-dispatch 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))))
+ (unless (functional-entry-fun fun)
+ (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))
\f
(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)))
(flush-lvar-externally-checkable-type arg))
(setf (combination-args use) nil)
(flush-dest list)
+ (flush-combination use)
(setf (combination-args node) args))
t)))
(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
projects / sbcl.git / blobdiff