(setf (node-next (block-last block)) nil)
block))))
\f
-;;;; continuation use hacking
+;;;; lvar use hacking
;;; Return a list of all the nodes which use LVAR.
(declaim (ftype (sfunction (lvar) list) find-uses))
(principal-lvar-use (cast-value use))
use)))
-;;; Update continuation use information so that NODE is no longer a
-;;; use of its CONT. If the old continuation doesn't start its block,
-;;; then we don't update the BLOCK-START-USES, since it will be
-;;; deleted when we are done.
+;;; Update lvar use information so that NODE is no longer a use of its
+;;; LVAR.
;;;
;;; Note: if you call this function, you may have to do a
-;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
-;;; has changed.
+;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
+;;; changed.
(declaim (ftype (sfunction (node) (values))
delete-lvar-use
%delete-lvar-use))
;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may
;;; be given a new use.
(defun %delete-lvar-use (node)
- (let* ((lvar (node-lvar node)))
+ (let ((lvar (node-lvar node)))
(when lvar
(if (listp (lvar-uses lvar))
(let ((new-uses (delq node (lvar-uses lvar))))
(setf (lvar-uses lvar) nil))
(setf (node-lvar node) nil)))
(values))
-;;; Delete NODE from its LVAR uses.
+;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete
+;;; its DEST's block, which must be unreachable.
(defun delete-lvar-use (node)
(let ((lvar (node-lvar node)))
(when lvar
(reoptimize-lvar lvar))))
(values))
-;;; Update continuation use information so that NODE uses CONT. If
-;;; CONT is :UNUSED, then we set its block to NODE's NODE-BLOCK (which
-;;; must be set.)
+;;; Update lvar use information so that NODE uses LVAR.
;;;
;;; Note: if you call this function, you may have to do a
-;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
-;;; has changed.
+;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has
+;;; changed.
(declaim (ftype (sfunction (node (or lvar null)) (values)) add-lvar-use))
(defun add-lvar-use (node lvar)
(aver (not (node-lvar node)))
(defun immediately-used-p (lvar node)
(declare (type lvar lvar) (type node node))
(aver (eq (node-lvar node) lvar))
- (and (eq (lvar-dest lvar)
- (acond ((node-next node)
- (ctran-next it))
- (t (let* ((block (node-block node))
- (next-block (first (block-succ block))))
- (block-start-node next-block)))))))
+ (let ((dest (lvar-dest lvar)))
+ (acond ((node-next node)
+ (eq (ctran-next it) dest))
+ (t (eq (block-start (first (block-succ (node-block node))))
+ (node-prev dest))))))
\f
-;;;; continuation substitution
+;;;; lvar substitution
;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be
;;; NIL. We do not flush OLD's DEST.
(declare (type lvar old)
(type (or lvar null) new))
- (do-uses (node old)
- (%delete-lvar-use node)
- (when new
- (add-lvar-use node new)))
-
- (when new (reoptimize-lvar new))
+ (cond (new (do-uses (node old)
+ (%delete-lvar-use node)
+ (add-lvar-use node new))
+ (reoptimize-lvar new))
+ (t (flush-dest old)))
(values))
\f
;;;; block starting/creation
((:inside-block)
(node-ends-block (ctran-use ctran)))))
(values))
+
+;;; CTRAN must be the last ctran in an incomplete block; finish the
+;;; block and start a new one if necessary.
+(defun start-block (ctran)
+ (declare (type ctran ctran))
+ (aver (not (ctran-next ctran)))
+ (ecase (ctran-kind ctran)
+ (:inside-block
+ (let ((block (ctran-block ctran))
+ (node (ctran-use ctran)))
+ (aver (not (block-last block)))
+ (aver node)
+ (setf (block-last block) node)
+ (setf (node-next node) nil)
+ (setf (ctran-use ctran) nil)
+ (setf (ctran-kind ctran) :unused)
+ (setf (ctran-block ctran) nil)
+ (link-blocks block (ctran-starts-block ctran))))
+ (:block-start)))
\f
;;;;
(declare (type node node))
(do ((fun (lexenv-lambda (node-lexenv node))
(lexenv-lambda (lambda-call-lexenv fun))))
- ((not (eq (functional-kind fun) :deleted))
+ ((not (memq (functional-kind fun) '(:deleted :zombie)))
(lambda-home fun))
(when (eq (lambda-home fun) fun)
(return fun))))
(defun node-dest (node)
(awhen (node-lvar node) (lvar-dest it)))
+(declaim (inline block-to-be-deleted-p))
+(defun block-to-be-deleted-p (block)
+ (or (block-delete-p block)
+ (eq (functional-kind (block-home-lambda block)) :deleted)))
+
+;;; Checks whether NODE is in a block to be deleted
+(declaim (inline node-to-be-deleted-p))
+(defun node-to-be-deleted-p (node)
+ (block-to-be-deleted-p (node-block node)))
+
(declaim (ftype (sfunction (clambda) cblock) lambda-block))
(defun lambda-block (clambda)
(node-block (lambda-bind clambda)))
(first forms)
(values (find-original-source path)))))
-;;; Return NODE-SOURCE-FORM, T if continuation has a single use,
-;;; otherwise NIL, NIL.
+;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise
+;;; NIL, NIL.
(defun lvar-source (lvar)
(let ((use (lvar-uses lvar)))
(if (listp use)
(defun ctran-home-lambda (ctran)
(ctran-home-lambda-or-null ctran))
+(declaim (inline cast-single-value-p))
+(defun cast-single-value-p (cast)
+ (not (values-type-p (cast-asserted-type cast))))
+
#!-sb-fluid (declaim (inline lvar-single-value-p))
(defun lvar-single-value-p (lvar)
(or (not lvar)
(cast
(locally
(declare (notinline lvar-single-value-p))
- (and (not (values-type-p (cast-asserted-type dest)))
+ (and (cast-single-value-p dest)
(lvar-single-value-p (node-lvar dest)))))
(t
t)))))
type-restrictions
(lambda (lexenv-lambda default))
(cleanup (lexenv-cleanup default))
+ (handled-conditions (lexenv-handled-conditions default))
(policy (lexenv-policy default)))
(macrolet ((frob (var slot)
`(let ((old (,slot default)))
(frob blocks lexenv-blocks)
(frob tags lexenv-tags)
(frob type-restrictions lexenv-type-restrictions)
- lambda cleanup policy)))
+ lambda cleanup handled-conditions policy)))
;;; Makes a LEXENV, suitable for using in a MACROLET introduced
;;; macroexpander
(lexenv-type-restrictions lexenv) ; XXX
nil
nil
+ (lexenv-handled-conditions lexenv)
(lexenv-policy lexenv))))
\f
;;;; flow/DFO/component hackery
(setf (block-prev next) block))
(values))
+;;; List all NLX-INFOs which BLOCK can exit to.
+;;;
+;;; We hope that no cleanup actions are performed in the middle of
+;;; BLOCK, so it is enough to look only at cleanups in the block
+;;; end. The tricky thing is a special cleanup block; all its nodes
+;;; have the same cleanup info, corresponding to the start, so the
+;;; same approach returns safe result.
+(defun map-block-nlxes (fun block)
+ (loop for cleanup = (block-end-cleanup block)
+ then (node-enclosing-cleanup (cleanup-mess-up cleanup))
+ while cleanup
+ do (let ((mess-up (cleanup-mess-up cleanup)))
+ (case (cleanup-kind cleanup)
+ ((:block :tagbody)
+ (aver (entry-p mess-up))
+ (loop for exit in (entry-exits mess-up)
+ for nlx-info = (find-nlx-info exit)
+ do (funcall fun nlx-info)))
+ ((:catch :unwind-protect)
+ (aver (combination-p mess-up))
+ (let* ((arg-lvar (first (basic-combination-args mess-up)))
+ (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar)))))
+ (funcall fun nlx-info)))))))
+
;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for
;;; the head and tail which are set to T.
(declaim (ftype (sfunction (component) (values)) clear-flags))
(clambda (delete-lambda fun)))
(values))
-;;; Deal with deleting the last reference to a CLAMBDA. Since there is
-;;; only one way into a CLAMBDA, deleting the last reference to a
-;;; CLAMBDA ensures that there is no way to reach any of the code in
-;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to
-;;; :DELETED, causing IR1 optimization to delete blocks in that
-;;; CLAMBDA.
+;;; Deal with deleting the last reference to a CLAMBDA, which means
+;;; that the lambda is unreachable, so that its body may be
+;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on
+;;; IR1-OPTIMIZE to delete its blocks.
(defun delete-lambda (clambda)
(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)))
+ (aver (or (eq original-kind :zombie) bind))
(setf (functional-kind clambda) :deleted)
(setf (lambda-bind clambda) nil)
- (dolist (let (lambda-lets clambda))
- (setf (lambda-bind let) nil)
- (setf (functional-kind let) :deleted))
- ;; LET may be deleted if its BIND is unreachable. Autonomous
- ;; function may be deleted if it has no reachable references.
- (unless (member original-kind '(:let :mv-let :assignment))
- (dolist (ref (lambda-refs clambda))
- (mark-for-deletion (node-block ref))))
+ (labels ((delete-children (lambda)
+ (dolist (child (lambda-children lambda))
+ (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))
;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
;; that we're using the old value of the KIND slot, not the
;; current slot value, which has now been set to :DELETED.)
- (if (member original-kind '(:let :mv-let :assignment))
- (let ((home (lambda-home clambda)))
- (setf (lambda-lets home) (delete clambda (lambda-lets home))))
- ;; If the function isn't a LET, we unlink the function head
- ;; and tail from the component head and tail to indicate that
- ;; the code is unreachable. We also delete the function from
- ;; COMPONENT-LAMBDAS (it won't be there before local call
- ;; analysis, but no matter.) If the lambda was never
- ;; referenced, we give a note.
- (let* ((bind-block (node-block bind))
- (component (block-component bind-block))
- (return (lambda-return clambda))
- (return-block (and return (node-block return))))
- (unless (leaf-ever-used clambda)
- (let ((*compiler-error-context* bind))
- (compiler-notify 'code-deletion-note
- :format-control "deleting unused function~:[.~;~:*~% ~S~]"
- :format-arguments (list (leaf-debug-name clambda)))))
- (unless (block-delete-p bind-block)
- (unlink-blocks (component-head component) bind-block))
- (when (and return-block (not (block-delete-p return-block)))
- (mark-for-deletion return-block)
- (unlink-blocks return-block (component-tail component)))
- (setf (component-reanalyze component) t)
- (let ((tails (lambda-tail-set clambda)))
- (setf (tail-set-funs tails)
- (delete clambda (tail-set-funs tails)))
- (setf (lambda-tail-set clambda) nil))
- (setf (component-lambdas component)
- (delete clambda (component-lambdas component)))))
+ (case original-kind
+ (:zombie)
+ ((:let :mv-let :assignment)
+ (let ((bind-block (node-block bind)))
+ (mark-for-deletion bind-block))
+ (let ((home (lambda-home clambda)))
+ (setf (lambda-lets home) (delete clambda (lambda-lets home))))
+ ;; KLUDGE: In presence of NLEs we cannot always understand that
+ ;; LET's BIND dominates its body [for a LET "its" body is not
+ ;; quite its]; let's delete too dangerous for IR2 stuff. --
+ ;; APD, 2004-01-01
+ (dolist (var (lambda-vars clambda))
+ (flet ((delete-node (node)
+ (mark-for-deletion (node-block node))))
+ (mapc #'delete-node (leaf-refs var))
+ (mapc #'delete-node (lambda-var-sets var)))))
+ (t
+ ;; Function has no reachable references.
+ (dolist (ref (lambda-refs clambda))
+ (mark-for-deletion (node-block ref)))
+ ;; If the function isn't a LET, we unlink the function head
+ ;; and tail from the component head and tail to indicate that
+ ;; the code is unreachable. We also delete the function from
+ ;; COMPONENT-LAMBDAS (it won't be there before local call
+ ;; analysis, but no matter.) If the lambda was never
+ ;; referenced, we give a note.
+ (let* ((bind-block (node-block bind))
+ (component (block-component bind-block))
+ (return (lambda-return clambda))
+ (return-block (and return (node-block return))))
+ (unless (leaf-ever-used clambda)
+ (let ((*compiler-error-context* bind))
+ (compiler-notify 'code-deletion-note
+ :format-control "deleting unused function~:[.~;~:*~% ~S~]"
+ :format-arguments (list (leaf-debug-name clambda)))))
+ (unless (block-delete-p bind-block)
+ (unlink-blocks (component-head component) bind-block))
+ (when (and return-block (not (block-delete-p return-block)))
+ (mark-for-deletion return-block)
+ (unlink-blocks return-block (component-tail component)))
+ (setf (component-reanalyze component) t)
+ (let ((tails (lambda-tail-set clambda)))
+ (setf (tail-set-funs tails)
+ (delete clambda (tail-set-funs tails)))
+ (setf (lambda-tail-set clambda) nil))
+ (setf (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
(delete-lambda leaf))
(:external
(delete-lambda leaf))
- ((:deleted :optional))))
+ ((:deleted :zombie :optional))))
(optional-dispatch
(unless (eq (functional-kind leaf) :deleted)
(delete-optional-dispatch leaf)))))
(let ((prev (node-prev use)))
(let ((block (ctran-block prev)))
(setf (component-reoptimize (block-component block)) t)
- (setf (block-attributep (block-flags block) flush-p type-asserted)
+ (setf (block-attributep (block-flags block)
+ flush-p type-asserted type-check)
t)))
(setf (node-lvar use) nil))
(setf (lvar-uses lvar) nil))
(unless (block-delete-p block)
(mark-for-deletion block))))))
+;;; Queue the block for deletion
+(defun delete-block-lazily (block)
+ (declare (type cblock block))
+ (unless (block-delete-p block)
+ (setf (block-delete-p block) t)
+ (push block (component-delete-blocks (block-component block)))))
+
;;; Do a graph walk backward from BLOCK, marking all predecessor
;;; blocks with the DELETE-P flag.
(defun mark-for-deletion (block)
(let* ((component (block-component block))
(head (component-head component)))
(labels ((helper (block)
- (setf (block-delete-p block) t)
+ (delete-block-lazily block)
(dolist (pred (block-pred block))
(unless (or (block-delete-p pred)
(eq pred head))
;;; This function does what is necessary to eliminate the code in it
;;; from the IR1 representation. This involves unlinking it from its
;;; predecessors and successors and deleting various node-specific
-;;; semantic information.
+;;; semantic information. BLOCK must be already removed from
+;;; COMPONENT-DELETE-BLOCKS.
(defun delete-block (block &optional silent)
(declare (type cblock block))
(aver (block-component block)) ; else block is already deleted!
+ #!+high-security (aver (not (memq block (component-delete-blocks (block-component block)))))
(unless silent
(note-block-deletion block))
(setf (block-delete-p block) t)
(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))
(unless (policy *compiler-error-context* (= inhibit-warnings 3))
;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
;; requires this to be no more than a STYLE-WARNING.
+ #-sb-xc-host
(compiler-style-warn "The variable ~S is defined but never used."
- (leaf-debug-name var)))
+ (leaf-debug-name var))
+ ;; There's no reason to accept this kind of equivocation
+ ;; when compiling our own code, though.
+ #+sb-xc-host
+ (compiler-warn "The variable ~S is defined but never used."
+ (leaf-debug-name var)))
(setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN
(values))
(unlink-blocks block next)
(dolist (pred (block-pred block))
(change-block-successor pred block next))
- (remove-from-dfo block)
+ (when (block-delete-p block)
+ (let ((component (block-component block)))
+ (setf (component-delete-blocks component)
+ (delq block (component-delete-blocks component)))))
+ (remove-from-dfo block)
(setf (block-delete-p block) t)
(setf (node-prev node) nil)
t)))))))
(aver (null (component-new-functionals component)))
(setf (component-kind component) :deleted)
(do-blocks (block component)
- (setf (block-delete-p block) t))
+ (delete-block-lazily block))
(dolist (fun (component-lambdas component))
- (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))
+ (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)))
+ (clean-component component)
(values))
+;;; Remove all pending blocks to be deleted. Return the nearest live
+;;; block after or equal to BLOCK.
+(defun clean-component (component &optional block)
+ (loop while (component-delete-blocks component)
+ ;; actual deletion of a block may queue new blocks
+ do (let ((current (pop (component-delete-blocks component))))
+ (when (eq block current)
+ (setq block (block-next block)))
+ (delete-block current)))
+ block)
+
;;; Convert code of the form
;;; (FOO ... (FUN ...) ...)
;;; to
;;; arguments.
(defun extract-fun-args (lvar fun num-args)
#!+sb-doc
- "If CONT is a call to FUN with NUM-ARGS args, change those arguments
+ "If LVAR is a call to FUN with NUM-ARGS args, change those arguments
to feed directly to the LVAR-DEST of LVAR, which must be a
combination."
(declare (type lvar lvar)
(append before-args inside-args after-args))
(change-ref-leaf (lvar-uses inside-fun)
(find-free-fun 'list "???"))
- (setf (combination-kind inside)
- (info :function :info 'list))
+ (setf (combination-fun-info inside) (info :function :info 'list)
+ (combination-kind inside) :known)
(setf (node-derived-type inside) *wild-type*)
(flush-dest lvar)
(values))))))
(flet ((frob (l)
(find home l
:key #'node-home-lambda
- :test-not #'eq)))
+ :test #'neq)))
(or (frob (leaf-refs var))
(frob (basic-var-sets var)))))))))
;;; exits to CONT in that entry, then return it, otherwise return NIL.
(defun find-nlx-info (exit)
(declare (type exit exit))
- (let* ((entry (exit-entry exit))
- (entry-cleanup (entry-cleanup entry)))
+ (let ((entry (exit-entry exit)))
(dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
(when (eq (nlx-info-exit nlx) exit)
(return nlx)))))
(aver (functional-letlike-p fun))
(lvar-dest (node-lvar (first (leaf-refs fun)))))
-;;; Return the initial value continuation for a LET variable, or NIL
-;;; if there is none.
+;;; Return the initial value lvar for a LET variable, or NIL if there
+;;; is none.
(defun let-var-initial-value (var)
(declare (type lambda-var var))
(let ((fun (lambda-var-home var)))
;; analysis, it is LET-converted: LET-converted functionals
;; are too badly trashed to expand them inline, and deleted
;; LET-converted functionals are even worse.
- (eql (functional-kind functional) :deleted)))
+ (memq (functional-kind functional) '(:deleted :zombie))))
(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 (eq kind :known)
+ (let ((info (basic-combination-fun-info call)))
+ (and
+ (not (fun-info-ir2-convert info))
+ (dolist (template (fun-info-templates info) 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