(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)))
;;; all functions in the tail set to be equivalent, this amounts to
;;; bringing the entire tail set up to date. We iterate over the
;;; returns for all the functions in the tail set, reanalyzing them
-;;; all (not treating Node specially.)
+;;; all (not treating NODE specially.)
;;;
;;; When we are done, we check whether the new type is different from
;;; the old TAIL-SET-TYPE. If so, we set the type and also reoptimize
(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
;;; -- either continuation has a funky TYPE-CHECK annotation.
;;; -- the continuations have incompatible assertions, so the new asserted type
;;; would be NIL.
-;;; -- the var's DEST has a different policy than the ARG's (think safety).
+;;; -- the VAR's DEST has a different policy than the ARG's (think safety).
;;;
;;; We change the REF to be a reference to NIL with unused value, and
;;; let it be flushed as dead code. A side effect of this substitution
(dest (continuation-dest cont)))
(when (and (eq (continuation-use cont) ref)
dest
- (not (typep dest '(or creturn exit mv-combination)))
+ (continuation-single-value-p cont)
(eq (node-home-lambda ref)
(lambda-home (lambda-var-home var)))
(member (continuation-type-check arg) '(t nil))
;;; If the function has an XEP, then we don't do anything, since we
;;; won't discover anything.
;;;
-;;; We can clear the Continuation-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
+;;; We can clear the CONTINUATION-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 right here.
(defun propagate-local-call-args (call fun)
(declare (type combination call) (type clambda fun))
(setf (node-prev use) nil)
(setf (continuation-next node-prev) nil)
(collect ((res vals))
- (loop as cont = (make-continuation use)
+ (loop for cont = (make-continuation use)
and prev = node-prev then cont
repeat (- nvars nvals)
do (reference-constant prev cont nil)
(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:
;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them
;;; args of the VALUES-LIST call, flushing the old argument
;;; continuation (allowing the LIST to be flushed.)
+;;;
+;;; FIXME: Thus we lose possible type assertions on (LIST ...).
(defoptimizer (values-list optimizer) ((list) node)
(let ((use (continuation-use list)))
(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)
;;; to a PROG1. This allows the computation of the additional values
;;; to become dead code.
(deftransform values ((&rest vals) * * :node node)
- (when (typep (continuation-dest (node-cont node))
- '(or creturn exit mv-combination))
+ (unless (continuation-single-value-p (node-cont node))
(give-up-ir1-transform))
(setf (node-derived-type node) *wild-type*)
(if vals
projects / sbcl.git / blobdiff