;;; 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:~
;;; 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)
(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