;;; Deal with deleting the last reference to a CLAMBDA. It is called
;;; in two situations: when the lambda is unreachable (so that its
-;;; body mey be deleted), and when it is an effectless LET (in this
+;;; body may be deleted), and when it is an effectless LET (in this
;;; case its body is reachable and is not completely "its"). We set
;;; FUNCTIONAL-KIND to :DELETED and rely on IR1-OPTIMIZE to delete its
;;; blocks.
(declare (type clambda clambda))
(let ((original-kind (functional-kind clambda))
(bind (lambda-bind clambda)))
- (aver (not (member original-kind '(:deleted :optional :toplevel))))
+ (aver (not (member original-kind '(:deleted :toplevel))))
(aver (not (functional-has-external-references-p clambda)))
(setf (functional-kind clambda) :deleted)
(setf (lambda-bind clambda) nil)
- (when bind ; CLAMBDA is deleted due to unreachability
+ (when bind ; CLAMBDA is deleted due to unreachability
(labels ((delete-children (lambda)
(dolist (child (lambda-children lambda))
- (if (eq (functional-kind child) :deleted)
- (delete-children child)
- (delete-lambda child)))
+ (cond ((eq (functional-kind child) :deleted)
+ (delete-children child))
+ (t
+ (delete-lambda child))))
(setf (lambda-children lambda) nil)
(setf (lambda-parent lambda) nil)))
(delete-children clambda)))
(delete clambda (tail-set-funs tails)))
(setf (lambda-tail-set clambda) nil))
(setf (component-lambdas component)
- (delete clambda (component-lambdas component)))))
+ (delq clambda (component-lambdas component)))))
;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
;; ENTRY-FUN so that people will know that it is not an entry
(do-nodes-carefully (node block)
(when (valued-node-p node)
(delete-lvar-use node))
- (typecase node
+ (etypecase node
(ref (delete-ref node))
(cif (flush-dest (if-test node)))
;; The next two cases serve to maintain the invariant that a LET
(when entry
(setf (entry-exits entry)
(delq node (entry-exits entry))))))
+ (entry
+ (dolist (exit (entry-exits node))
+ (mark-for-deletion (node-block exit)))
+ (let ((home (node-home-lambda node)))
+ (setf (lambda-entries home) (delq node (lambda-entries home)))))
(creturn
(flush-dest (return-result node))
(delete-return node))
(do-blocks (block component)
(setf (block-delete-p block) t))
(dolist (fun (component-lambdas component))
- (setf (functional-kind fun) nil)
- (setf (functional-entry-fun fun) nil)
- (setf (leaf-refs fun) nil)
- (delete-functional fun))
+ (unless (eq (functional-kind fun) :deleted)
+ (setf (functional-kind fun) nil)
+ (setf (functional-entry-fun fun) nil)
+ (setf (leaf-refs fun) nil)
+ (delete-functional fun)))
(do-blocks (block component)
(delete-block block))
(values))
;; LET-converted functionals are even worse.
(eql (functional-kind functional) :deleted)))
(throw 'locall-already-let-converted functional)))
+
+(defun call-full-like-p (call)
+ (declare (type combination call))
+ (let ((kind (basic-combination-kind call)))
+ (or (eq kind :full)
+ (and (fun-info-p kind)
+ (not (fun-info-ir2-convert kind))
+ (dolist (template (fun-info-templates kind) t)
+ (when (eq (template-ltn-policy template) :fast-safe)
+ (multiple-value-bind (val win)
+ (valid-fun-use call (template-type template))
+ (when (or val (not win)) (return nil)))))))))
\f
;;;; careful call