(let* ((fun (combination-fun dest))
(args (combination-args dest))
(fun-type (continuation-type fun)))
+ (setf (continuation-%externally-checkable-type fun) *wild-type*)
(if (or (not (fun-type-p fun-type))
;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
(fun-type-wild-args fun-type))
~% ~S~%*** possible internal error? Please report this."
(type-specifier rtype) (type-specifier node-type))))
(setf (node-derived-type node) int)
+ (when (and (ref-p node)
+ (member-type-p int)
+ (null (rest (member-type-members int)))
+ (lambda-var-p (ref-leaf node)))
+ (change-ref-leaf node (find-constant (first (member-type-members int)))))
(reoptimize-continuation (node-cont node))))))
(values))
(let ((last (block-last block)))
(typecase last
(cif
- (flush-dest (if-test last))
- (when (unlink-node last)
- (return)))
+ (if (memq (continuation-type-check (if-test last))
+ '(nil :deleted))
+ ;; FIXME: Remove the test above when the bug 203
+ ;; will be fixed.
+ (progn
+ (flush-dest (if-test last))
+ (when (unlink-node last)
+ (return)))
+ (return)))
(exit
(when (maybe-delete-exit last)
(return)))))
:lossage-fun nil
:unwinnage-fun nil))
(ir1-attributep attr unsafely-flushable)))
- (flush-dest (combination-fun node))
- (dolist (arg (combination-args node))
- (flush-dest arg))
- (unlink-node node))))))
+ (flush-combination node))))))
(mv-combination
(when (eq (basic-combination-kind node) :local)
(let ((fun (combination-lambda node)))
(convert-if-if use node)
(when (continuation-use test) (return)))))
- (let* ((type (continuation-type test))
- (victim
- (cond ((constant-continuation-p test)
- (if (continuation-value test)
- (if-alternative node)
- (if-consequent node)))
- ((not (types-equal-or-intersect type (specifier-type 'null)))
- (if-alternative node))
- ((type= type (specifier-type 'null))
- (if-consequent node)))))
- (when victim
- (flush-dest test)
- (when (rest (block-succ block))
- (unlink-blocks block victim))
- (setf (component-reanalyze (node-component node)) t)
- (unlink-node node))))
+ (when (memq (continuation-type-check test)
+ '(nil :deleted))
+ ;; FIXME: Remove the test above when the bug 203 will be fixed.
+ (let* ((type (continuation-type test))
+ (victim
+ (cond ((constant-continuation-p test)
+ (if (continuation-value test)
+ (if-alternative node)
+ (if-consequent node)))
+ ((not (types-equal-or-intersect type (specifier-type 'null)))
+ (if-alternative node))
+ ((type= type (specifier-type 'null))
+ (if-consequent node)))))
+ (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))
;;; Create a new copy of an IF node that tests the value of the node
;;; possible to do this starting from debug names as well as source
;;; names, but as of sbcl-0.7.1.5, there was no need for this
;;; generality, since source names are always known to our callers.)
-(defun transform-call (node res source-name)
- (declare (type combination node) (list res))
+(defun transform-call (call res source-name)
+ (declare (type combination call) (list res))
(aver (and (legal-fun-name-p source-name)
(not (eql source-name '.anonymous.))))
- (with-ir1-environment-from-node node
+ (node-ends-block call)
+ (with-ir1-environment-from-node call
+ (with-component-last-block (*current-component*
+ (block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
:debug-name (debug-namify "LAMBDA-inlined ~A"
(as-debug-name
source-name
"<unknown function>"))))
- (ref (continuation-use (combination-fun node))))
+ (ref (continuation-use (combination-fun call))))
(change-ref-leaf ref new-fun)
- (setf (combination-kind node) :full)
- (locall-analyze-component *current-component*)))
+ (setf (combination-kind call) :full)
+ (locall-analyze-component *current-component*))))
(values))
;;; Replace a call to a foldable function of constant arguments with
(setf (continuation-next cont) next)
;; FIXME: type checking?
(reoptimize-continuation cont)
- (reoptimize-continuation prev))))
+ (reoptimize-continuation prev)
+ (flush-combination call))))
(t (let ((dummies (make-gensym-list (length args))))
(transform-call
call
(unlink-node call)
(when vals
(reoptimize-continuation (first vals)))
- (propagate-to-args use fun))
+ (propagate-to-args use fun)
+ (reoptimize-call use))
t)))
;;; If we see:
(when (and (combination-p use)
(eq (continuation-fun-name (combination-fun use))
'list))
+
+ ;; FIXME: VALUES might not satisfy an assertion on NODE-CONT.
(change-ref-leaf (continuation-use (combination-fun node))
(find-free-fun 'values "in a strange place"))
(setf (combination-kind node) :full)