;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************

;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment

  "$Header: src/compiler/ir1util.lisp $")

;;;

;;; **********************************************************************
;;;
;;;    This file contains random utilities used for manipulating the IR1
;;; representation.
;;;
;;; Written by Rob MacLachlan
;;;

(in-package "C")

(intl:textdomain "cmucl")

(export '(*compiler-notification-function*))
(in-package "EXTENSIONS")

(export '(*error-print-level* *error-print-length* *error-print-lines*

	  def-source-context *undefined-warning-limit*

	  *enclosing-source-cutoff* *inline-expansion-limit*))

(in-package "C")


;;;; Cleanup hackery:

;;; Node-Enclosing-Cleanup  --  Interface

;;;

;;;    Return the innermost cleanup enclosing Node, or NIL if there is none in
;;; its function.  If Node has no cleanup, but is in a let, then we must still
;;; check the environment that the call is in.

;;;

(defun node-enclosing-cleanup (node)
  (declare (type node node))

  (do ((lexenv (node-lexenv node)
	       (lambda-call-lexenv (lexenv-lambda lexenv))))
      ((null lexenv) nil)
    (let ((cup (lexenv-cleanup lexenv)))
      (when cup (return cup)))))

;;; Insert-Cleanup-Code  --  Interface
;;;
;;;    Convert the Form in a block inserted between Block1 and Block2 as an
;;; implicit MV-Prog1.  The inserted block is returned.  Node is used for IR1
;;; context when converting the form.  Note that the block is not assigned a
;;; number, and is linked into the DFO at the beginning.  We indicate that we

;;; have trashed the DFO by setting Component-Reanalyze.  If Cleanup is
;;; supplied, then convert with that cleanup.

;;;

(defun insert-cleanup-code (block1 block2 node form &optional cleanup)
  (declare (type cblock block1 block2) (type node node)
	   (type (or cleanup null) cleanup))

  (setf (component-reanalyze (block-component block1)) t)

  (with-ir1-environment node
    (let* ((start (make-continuation))
	   (block (continuation-starts-block start))

	   (cont (make-continuation))
	   (*lexical-environment*
	   (if cleanup
	       (make-lexenv :cleanup cleanup)
	       *lexical-environment*)))

      (change-block-successor block1 block2 block)
      (link-blocks block block2)
      (ir1-convert start cont form)
      (setf (block-last block) (continuation-use cont))
      block)))
  

;;;; Continuation use hacking:

;;; Find-Uses  --  Interface
;;;
;;;    Return a list of all the nodes which use Cont.
;;;
(defun find-uses (cont)

  (declare (type continuation cont) (values list))

  (ecase (continuation-kind cont)
    ((:block-start :deleted-block-start)
     (block-start-uses (continuation-block cont)))
    (:inside-block (list (continuation-use cont)))

    (:unused nil)
    (:deleted nil)))

;;; Delete-Continuation-Use  --  Interface
;;;
;;;    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.
;;;
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
;;; changed.
;;;
(defun delete-continuation-use (node)

  (declare (type node node))

  (let* ((cont (node-cont node))
	 (block (continuation-block cont)))
    (ecase (continuation-kind cont)
      (:deleted)
      ((:block-start :deleted-block-start)
       (let ((uses (delete node (block-start-uses block))))
	 (setf (block-start-uses block) uses)
	 (setf (continuation-use cont)
	       (if (cdr uses) nil (car uses)))))
      (:inside-block
       (setf (continuation-kind cont) :unused)
       (setf (continuation-block cont) nil)
       (setf (continuation-use cont) nil)
       (setf (continuation-next cont) nil)))
    (setf (node-cont node) nil)))


;;; Add-Continuation-Use  --  Interface
;;;
;;;    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.)
;;;
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
;;; changed.
;;;
(defun add-continuation-use (node cont)

  (declare (type node node) (type continuation cont))

  (assert (not (node-cont node)))
  (let ((block (continuation-block cont)))
    (ecase (continuation-kind cont)
      (:deleted)
      (:unused
       (assert (not block))
       (let ((block (node-block node)))
	 (assert block)
	 (setf (continuation-block cont) block))
       (setf (continuation-kind cont) :inside-block)
       (setf (continuation-use cont) node))
      ((:block-start :deleted-block-start)
       (let ((uses (cons node (block-start-uses block))))
	 (setf (block-start-uses block) uses)
	 (setf (continuation-use cont)
	       (if (cdr uses) nil (car uses)))))))
  (setf (node-cont node) cont))


;;; Immediately-Used-P  --  Interface
;;;
;;;    Return true if Cont is the Node-Cont for Node and Cont is transferred to
;;; immediately after the evaluation of Node.
;;;
(defun immediately-used-p (cont node)
  (declare (type continuation cont) (type node node))
  (and (eq (node-cont node) cont)
       (not (eq (continuation-kind cont) :deleted))
       (let ((cblock (continuation-block cont))
	     (nblock (node-block node)))
	 (or (eq cblock nblock)
	     (let ((succ (block-succ nblock)))
	       (and (= (length succ) 1)
		    (eq (first succ) cblock)))))))


;;;; Continuation substitution:

;;; Substitute-Continuation  --  Interface
;;;
;;;    In Old's Dest, replace Old with New.  New's Dest must initially be NIL.
;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note
;;; potential optimization opportunities.
;;;
(defun substitute-continuation (new old)
  (declare (type continuation old new))
  (assert (not (continuation-dest new)))
  (let ((dest (continuation-dest old)))
    (etypecase dest
      ((or ref bind))
      (cif (setf (if-test dest) new))
      (cset (setf (set-value dest) new))
      (creturn (setf (return-result dest) new))
      (exit (setf (exit-value dest) new))
      (basic-combination
       (if (eq old (basic-combination-fun dest))
	   (setf (basic-combination-fun dest) new)
	   (setf (basic-combination-args dest)
		 (nsubst new old (basic-combination-args dest))))))

    (flush-dest old)
    (setf (continuation-dest new) dest))
  (undefined-value))

;;; Substitute-Continuation-Uses  --  Interface
;;;
;;;    Replace all uses of Old with uses of New, where New has an arbitary
;;; number of uses.  If New will end up with more than one use, then we must
;;; arrange for it to start a block if it doesn't already.
;;;
(defun substitute-continuation-uses (new old)
  (declare (type continuation old new))
  (unless (and (eq (continuation-kind new) :unused)
	       (eq (continuation-kind old) :inside-block))
    (ensure-block-start new))

  (do-uses (node old)
    (delete-continuation-use node)
    (add-continuation-use node new))

  (dolist (cont-ref (continuation-refs old))
    (setf (cont-ref-cont cont-ref) new))

  (reoptimize-continuation new)
  (undefined-value))


;;;; Block starting/creation:

;;; Continuation-Starts-Block  --  Interface
;;;
;;;    Return the block that Continuation is the start of, making a block if
;;; necessary.  This function is called by IR1 translators which may cause a
;;; continuation to be used more than once.  Every continuation which may be
;;; used more than once must start a block by the time that anyone does a
;;; Use-Continuation on it.
;;; 
;;;    We also throw the block into the next/prev list for the
;;; *current-component* so that we keep track of which blocks we have made.
;;;
(defun continuation-starts-block (cont)
  (declare (type continuation cont))
  (ecase (continuation-kind cont)
    (:unused
     (assert (not (continuation-block cont)))
     (let* ((head (component-head *current-component*))
	    (next (block-next head))
	    (new-block (make-block cont)))
       (setf (block-next new-block) next)
       (setf (block-prev new-block) head)
       (setf (block-prev next) new-block)
       (setf (block-next head) new-block)
       (setf (continuation-block cont) new-block)
       (setf (continuation-use cont) nil)
       (setf (continuation-kind cont) :block-start)
       new-block))
    (:block-start
     (continuation-block cont))))

;;; Ensure-Block-Start  --  Interface
;;;
;;;    Ensure that Cont is the start of a block (or deleted) so that the use
;;; set can be freely manipulated.
;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last
;;;    in its block, then we make it the start of a new deleted block.
;;; -- If the continuation is :Inside-Block inside a block, then we split the
;;;    block using Node-Ends-Block, which makes the continuation be a
;;;    :Block-Start.
;;;
(defun ensure-block-start (cont)
  (declare (type continuation cont))
  (let ((kind (continuation-kind cont)))
    (ecase kind
      ((:deleted :block-start :deleted-block-start))
      ((:unused :inside-block)
       (let ((block (continuation-block cont)))
	 (cond ((or (eq kind :unused)
		    (eq (node-cont (block-last block)) cont))
		(setf (continuation-block cont)

		      (make-block-key :start cont  :component nil
				      :start-uses (find-uses cont)))

		(setf (continuation-kind cont) :deleted-block-start))
	       (t
		(node-ends-block (continuation-use cont))))))))
  (undefined-value))



;;;; Misc shortand functions:

;;; NODE-HOME-LAMBDA  --  Interface
;;;

;;;    Return the home (i.e. enclosing non-let) lambda for NODE.  Since the

;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV
;;; thread until we find a lambda that isn't deleted, and then return its home.
;;;
(declaim (maybe-inline node-home-lambda))
(defun node-home-lambda (node)
  (declare (type node node))
  (do ((fun (lexenv-lambda (node-lexenv node))
	    (lexenv-lambda (lambda-call-lexenv fun))))
      ((not (eq (functional-kind fun) :deleted))
       (lambda-home fun))
    (when (eq (lambda-home fun) fun)
      (return fun))))

;;; NODE-xxx  --  Interface

;;;

(declaim (inline node-block node-tlf-number))
(declaim (maybe-inline node-environment))

(defun node-block (node)
  (declare (type node node))
  (the cblock (continuation-block (node-prev node))))
;;;

(defun node-environment (node)

  (declare (type node node) (inline node-home-lambda))
  (the environment (lambda-environment (node-home-lambda node))))

;;; BLOCK-xxx-CLEANUP  --  Interface
;;;
;;;    Return the enclosing cleanup for environment of the first or last node
;;; in Block.
;;;
(defun block-start-cleanup (block)
  (declare (type cblock block))
  (node-enclosing-cleanup (continuation-next (block-start block))))
;;;
(defun block-end-cleanup (block)
  (declare (type cblock block))
  (node-enclosing-cleanup (block-last block)))


;;; BLOCK-HOME-LAMBDA  --  Interface
;;;
;;;    Return the non-let lambda that holds Block's code.
;;;
(defun block-home-lambda (block)

  (declare (type cblock block) (inline node-home-lambda))
  (node-home-lambda (block-last block)))

;;; BLOCK-ENVIRONMENT  --  Interface
;;;
;;;    Return the IR1 environment for Block.
;;;
(defun block-environment (block)

  (declare (type cblock block) (inline node-home-lambda))
  (lambda-environment (node-home-lambda (block-last block))))

;;;
;;; Value is true if Block in unreachable and thus can be deleted.
;;;
(defun block-unreachable-p (block)
  (declare (type cblock block))
  (or (block-delete-p block)
      (null (block-pred block))
      (eq (functional-kind (block-home-lambda block)) :deleted)))

;;; SOURCE-PATH-TLF-NUMBER  --  Interface
;;;
;;;    Return the Top Level Form number of path, i.e. the ordinal number of
;;; its orignal source's top-level form in its compilation unit.
;;;
(defun source-path-tlf-number (path)
  (declare (list path))
  (car (last path)))


;;; SOURCE-PATH-ORIGINAL-SOURCE  --  Interface
;;;

;;;    Return the (reversed) list for the PATH in the original source (with the

;;; TLF number last.)
;;; 
(defun source-path-original-source (path)

  (declare (list path) (inline member))
  (cddr (member 'original-source-start path :test #'eq)))

;;; SOURCE-PATH-FORM-NUMBER  --  Interface
;;;

;;;    Return the Form Number of PATH's orignal source inside the Top Level

;;; Form that contains it.  This is determined by the order that we walk the
;;; subforms of the top level source form.
;;;
(defun source-path-form-number (path)

  (declare (list path) (inline member))
  (cadr (member 'original-source-start path :test #'eq)))

;;; SOURCE-PATH-FORMS  --  Interface
;;;
;;;    Return a list of all the enclosing forms not in the original source that
;;; converted to get to this form, with the immediate source for node at the
;;; start of the list.
;;;
(defun source-path-forms (path)
  (subseq path 0 (position 'original-source-start path)))

;;; NODE-SOURCE-FORM  --  Interface
;;;
;;;    Return the innermost source form for Node.
;;;
(defun node-source-form (node)
  (declare (type node node))
  (let* ((path (node-source-path node))
	 (forms (source-path-forms path)))
    (if forms
	(first forms)
	(values (find-original-source path)))))


;;; CONTINUATION-SOURCE-FORM  --  Interface
;;;
;;;    Return NODE-SOURCE-FORM, T if continuation has a single use, otherwise
;;; NIL, NIL.
;;;
(defun continuation-source (cont)
  (let ((use (continuation-use cont)))
    (if use
	(values (node-source-form use) t)
	(values nil nil))))


;;; Utilities for source location recording.  SOURCE-LOCATION returns
;;; a data structure describing the source location of the call site.
;;; The structure includes form numbers and the filename, if we

;;; compile a file, the user supplied info, if we compile from a
;;; stream, or the source form, if we compile a form directly.

;;;
;;; Some effort was made to keep the structures small.  We restrict
;;; form numbers to two 14 bit integers and encode them in a single

;;; fixnum.  The returned structures require 4 words (usually 16
;;; bytes).

(defstruct (form-numbers)
  ;; The tlf-number and form-number encoded in a fixnum.
  (form-numbers (required-argument) :type fixnum))

(defstruct (file-source-location
	     (:include form-numbers)
	     (:make-load-form-fun :just-dump-it-normally)
	     (:pure t))
  (pathname (required-argument) :type simple-string))

(defstruct (stream-source-location
	     (:include form-numbers)
	     (:make-load-form-fun :just-dump-it-normally)
	     (:pure t))
  user-info)

(defstruct (lisp-source-location
	     (:include form-numbers)
	     (:make-load-form-fun :just-dump-it-normally)
	     (:pure t))
  form)

(defun encode-form-numbers (tlf-number form-number)

  "Return the TLF-NUMBER and FORM-NUMBER encoded as fixnum, if
  possible.  Otherwise, return Nil."
  (when (and (typep tlf-number '(unsigned-byte 14))
	     (typep form-number '(unsigned-byte 14)))
    (logior tlf-number (ash form-number 14))))

(defun decode-form-numbers (fixnum)

  "Return the tlf-number and form-number from an encoded FIXNUM."

  (values (ldb (byte 14 0) fixnum) 
	  (ldb (byte 14 14) fixnum)))

(defun source-location ()

  "Return a source-location for the call site."

  nil)

(define-compiler-macro source-location (&whole whole)

  (let ((file-info (let ((rest (source-info-current-file *source-info*)))
		     (cond (rest (car rest))
			   ;; MAKE-LISP-SOURCE-INFO doesn't set current-file
			   (t (car (source-info-files *source-info*))))))

	(form-numbers (encode-form-numbers
		       (source-path-tlf-number *current-path*)
		       (source-path-form-number *current-path*))))

    (cond (form-numbers
	   (etypecase (file-info-name file-info)
	     (pathname
	      `(quote ,(make-file-source-location 
			:form-numbers form-numbers
			:pathname (namestring-for-debug-source file-info))))
	     ((member :stream)
	      `(quote ,(make-stream-source-location :form-numbers form-numbers
						    :user-info *user-source-info*)))
	     ((member :lisp)
	      `(quote ,(make-lisp-source-location 
			:form-numbers form-numbers
			:form (aref (file-info-forms file-info) 0))))))
	  (t
	   (warn "Dropping source-location because form numbers are too large: ~S ~S"
		 (source-path-tlf-number *current-path*)
		 (source-path-form-number *current-path*))
	   whole))))


;;; MAKE-LEXENV  --  Interface
;;;
;;;    Return a new LEXENV just like Default except for the specified slot
;;; values.  Values for the alist slots are NCONC'ed to the beginning of the
;;; current value, rather than replacing it entirely.
;;; 
(defun make-lexenv (&key (default *lexical-environment*)
			 functions variables blocks tags type-restrictions

			 options dynamic-extent

			 (lambda (lexenv-lambda default))
			 (cleanup (lexenv-cleanup default))

			 (cookie (lexenv-cookie default))
			 (interface-cookie (lexenv-interface-cookie default)))

  (macrolet ((frob (var slot)
	       `(let ((old (,slot default)))
		  (if ,var
		      (nconc ,var old)
		      old))))
    (internal-make-lexenv
     (frob functions lexenv-functions)
     (frob variables lexenv-variables)
     (frob blocks lexenv-blocks)
     (frob tags lexenv-tags)
     (frob type-restrictions lexenv-type-restrictions)

     lambda cleanup cookie interface-cookie

     (frob options lexenv-options)
     (frob dynamic-extent lexenv-dynamic-extent))))

;;; MAKE-INTERFACE-COOKIE  --  Interface
;;;
;;;    Return a cookie that defaults any unsupplied optimize qualities in the
;;; Interface-Cookie with the corresponding ones from the Cookie.
;;;
(defun make-interface-cookie (lexenv)
  (declare (type lexenv lexenv))
  (let ((icookie (lexenv-interface-cookie lexenv))
	(cookie (lexenv-cookie lexenv)))
    (make-cookie
     :speed (or (cookie-speed icookie) (cookie-speed cookie))
     :space (or (cookie-space icookie) (cookie-space cookie))
     :safety (or (cookie-safety icookie) (cookie-safety cookie))
     :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie))
     :brevity (or (cookie-brevity icookie) (cookie-brevity cookie))
     :debug (or (cookie-debug icookie) (cookie-debug cookie)))))


;;;; Flow/DFO/Component hackery:

;;; Link-Blocks  --  Interface

;;;

;;;    Join Block1 and Block2.

;;;

(declaim (inline link-blocks))

(defun link-blocks (block1 block2)

  (declare (type cblock block1 block2))

  (setf (block-succ block1)
	(if (block-succ block1)
	    (%link-blocks block1 block2)
	    (list block2)))

  (push block1 (block-pred block2))
  (undefined-value))

;;;
(defun %link-blocks (block1 block2)
  (declare (type cblock block1 block2) (inline member))
  (let ((succ1 (block-succ block1)))
    (assert (not (member block2 succ1 :test #'eq)))
    (cons block2 succ1)))

;;; UNLINK-BLOCKS  --  Interface
;;;
;;;    Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2.  If this leaves a
;;; successor with a single predecessor that ends in an IF, then set
;;; BLOCK-TEST-MODIFIED so that any test constraint will now be able to be
;;; propagated to the successor.

;;;
(defun unlink-blocks (block1 block2)

  (declare (type cblock block1 block2))

  (let ((succ1 (block-succ block1)))
    (if (eq block2 (car succ1))
	(setf (block-succ block1) (cdr succ1))
	(do ((succ (cdr succ1) (cdr succ))
	     (prev succ1 succ))
	    ((eq (car succ) block2)
	     (setf (cdr prev) (cdr succ)))
	  (assert succ))))

  (let ((new-pred (delq block1 (block-pred block2))))

    (setf (block-pred block2) new-pred)
    (when (and new-pred (null (rest new-pred)))
      (let ((pred-block (first new-pred)))
	(when (if-p (block-last pred-block))
	  (setf (block-test-modified pred-block) t)))))

  (undefined-value))

;;; Change-Block-Successor  --  Internal
;;;
;;;    Swing the succ/pred link between Block and Old to be between Block and
;;; New.  If Block ends in an IF, then we have to fix up the

;;; consequent/alternative blocks to point to New.  We also set
;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to the new
;;; successor.

;;;
(defun change-block-successor (block old new)

  (declare (type cblock new old block) (inline member))

  (unlink-blocks block old)

  (let ((last (block-last block))
	(comp (block-component block)))
    (setf (component-reanalyze comp) t)
    (typecase last
      (cif
       (setf (block-test-modified block) t)
       (let* ((succ-left (block-succ block))
	      (new (if (and (eq new (component-tail comp))
			    succ-left)
		       (first succ-left)
		       new)))
	 (unless (member new succ-left :test #'eq)
	   (link-blocks block new))
	 (macrolet ((frob (slot)
		      `(when (eq (,slot last) old)
			 (setf (,slot last) new))))
	   (frob if-consequent)

	   (frob if-alternative)
	   (when (eq (if-consequent last)
		     (if-alternative last))
	     ;; Allow IR1-OPTIMIZE to perform (IF test exp exp) =>
	     ;; (PROGN test exp) optimization, if it can.
	     (setf (component-reoptimize comp) t)))))

      (t
       (unless (member new (block-succ block) :test #'eq)
	 (link-blocks block new)))))

  
  (undefined-value))


;;; Remove-From-DFO  --  Interface
;;;
;;;    Unlink a block from the next/prev chain.  We also null out the
;;; Component.
;;;

(declaim (inline remove-from-dfo))

(defun remove-from-dfo (block)

  (declare (type cblock block))

  (let ((next (block-next block))
	(prev (block-prev block)))
    (setf (block-component block) nil)
    (setf (block-next prev) next)
    (setf (block-prev next) prev)))

;;; Add-To-DFO  --  Interface
;;;
;;;    Add Block to the next/prev chain following After.  We also set the
;;; Component to be the same as for After.
;;;

(declaim (inline add-to-dfo))

(defun add-to-dfo (block after)

  (declare (type cblock block after))

  (let ((next (block-next after))
	(comp (block-component after)))
    (assert (not (eq (component-kind comp) :deleted)))
    (setf (block-component block) comp)

    (setf (block-next after) block)
    (setf (block-prev block) after)
    (setf (block-next block) next)

    (setf (block-prev next) block))
  (undefined-value))

;;; Clear-Flags  --  Interface
;;;
;;;    Set the Flag for all the blocks in Component to NIL, except for the head
;;; and tail which are set to T.
;;;
(defun clear-flags (component)

  (declare (type component component))

  (let ((head (component-head component))
	(tail (component-tail component)))
    (setf (block-flag head) t)
    (setf (block-flag tail) t)
    (do-blocks (block component)
      (setf (block-flag block) nil))))


;;; Make-Empty-Component  --  Interface
;;;
;;;    Make a component with no blocks in it.  The Block-Flag is initially true
;;; in the head and tail blocks.
;;;
(defun make-empty-component ()

  (declare (values component))

  (let* ((head (make-block-key :start nil :component nil))
	 (tail (make-block-key :start nil :component nil))

	 (res (make-component :head head :tail tail
			      :outer-loop (make-loop :kind :outer :head head))))

    (setf (block-flag head) t)
    (setf (block-flag tail) t)
    (setf (block-component head) res)
    (setf (block-component tail) res)
    (setf (block-next head) tail)
    (setf (block-prev tail) head)
    res))


;;; Node-Ends-Block  --  Interface
;;;
;;;    Makes Node the Last node in its block, splitting the block if necessary.

;;; The new block is added to the DFO immediately following Node's block.

;;;
(defun node-ends-block (node)
  (declare (type node node))
  (let* ((block (node-block node))
	 (start (node-cont node))
	 (last (block-last block))
	 (last-cont (node-cont last)))
    (unless (eq last node)

      (assert (and (eq (continuation-kind start) :inside-block)
		   (not (block-delete-p block))))

      (let* ((succ (block-succ block))
	     (new-block
	      (make-block-key :start start
			      :component (block-component block)
			      :start-uses (list (continuation-use start))
			      :succ succ :last last)))
	(setf (continuation-kind start) :block-start)
	(dolist (b succ)
	  (setf (block-pred b)
		(cons new-block (remove block (block-pred b)))))
	(setf (block-succ block) ())
	(setf (block-last block) node)
	(link-blocks block new-block)
	(add-to-dfo new-block block)

	(setf (component-reanalyze (block-component block)) t)

	
	(do ((cont start (node-cont (continuation-next cont))))
	    ((eq cont last-cont)
	     (when (eq (continuation-kind last-cont) :inside-block)
	       (setf (continuation-block last-cont) new-block)))
	  (setf (continuation-block cont) new-block))

	(setf (block-type-asserted block) t)
	(setf (block-test-modified block) t))))

  (undefined-value))


;;;; Deleting stuff:

(declaim (start-block delete-ref delete-functional flush-dest

		      delete-continuation delete-block delete-lambda))

;;; Delete-Lambda-Var  --  Internal
;;;
;;;    Deal with deleting the last (read) reference to a lambda-var.  We
;;; iterate over all local calls flushing the corresponding argument, allowing

;;; the computation of the argument to be deleted.  We also mark the let for
;;; reoptimization, since it may be that we have deleted the last variable.

;;;
;;;    The lambda-var may still have some sets, but this doesn't cause too much
;;; difficulty, since we can efficiently implement write-only variables.  We
;;; iterate over the sets, marking their blocks for dead code flushing, since
;;; we can delete sets whose value is unused.
;;;
(defun delete-lambda-var (leaf)
  (declare (type lambda-var leaf))
  (let* ((fun (lambda-var-home leaf))
	 (n (position leaf (lambda-vars fun))))
    (dolist (ref (leaf-refs fun))
      (let* ((cont (node-cont ref))
	     (dest (continuation-dest cont)))
	(when (and (combination-p dest)
		   (eq (basic-combination-fun dest) cont)
		   (eq (basic-combination-kind dest) :local))

	  (let* ((args (basic-combination-args dest))
		 (arg (elt args n)))
	    (reoptimize-continuation arg)
	    (flush-dest arg)

	    (setf (elt args n) nil))))))

  (dolist (set (lambda-var-sets leaf))
    (setf (block-flush-p (node-block set)) t))

  (undefined-value))

;;; REOPTIMIZE-LAMBDA-VAR  --  Internal
;;;
;;;    Note that something interesting has happened to Var.  We only deal with
;;; LET variables, marking the corresponding initial value arg as needing to be
;;; reoptimized.
;;;
(defun reoptimize-lambda-var (var)
  (declare (type lambda-var var))
  (let ((fun (lambda-var-home var)))
    (when (and (eq (functional-kind fun) :let)
	       (leaf-refs var))

      (do ((args (basic-combination-args
		  (continuation-dest
		   (node-cont
		    (first (leaf-refs fun)))))
		 (cdr args))
	   (vars (lambda-vars fun) (cdr vars)))
	  ((eq (car vars) var)
	   (reoptimize-continuation (car args))))))

  (undefined-value))

;;; DELETE-FUNCTIONAL  --  Interface
;;;
;;;    This function deletes functions that have no references.  This need only
;;; be called on functions that never had any references, since otherwise
;;; DELETE-REF will handle the deletion. 
;;;
(defun delete-functional (fun)

  (assert (and (null (leaf-refs fun))
	       (not (functional-entry-function fun))))

  (etypecase fun
    (optional-dispatch (delete-optional-dispatch fun))
    (clambda (delete-lambda fun)))
  (undefined-value))

;;; Delete-Lambda  --  Internal
;;;
;;;    Deal with deleting the last reference to a lambda.  Since there is only
;;; one way into a lambda, deleting the last reference to a lambda 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 lambda.
;;;
;;;    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.

;;;
;;;    If the lambda is an XEP, then we null out the Entry-Function in its
;;; Entry-Function so that people will know that it is not an entry point
;;; anymore.
;;;
(defun delete-lambda (leaf)
  (declare (type clambda leaf))

  (let ((kind (functional-kind leaf))
	(bind (lambda-bind leaf)))

    (assert (not (member kind '(:deleted :optional))))

    (setf (functional-kind leaf) :deleted)

    (setf (lambda-bind leaf) nil)

    (dolist (let (lambda-lets leaf))

      (setf (lambda-bind let) nil)

      (setf (functional-kind let) :deleted))

    (if (member kind '(:let :mv-let :assignment))

	(let ((home (lambda-home leaf)))
	  (setf (lambda-lets home) (delete leaf (lambda-lets home))))

	(let* ((bind-block (node-block bind))

	       (component (block-component bind-block))
	       (return (lambda-return leaf)))

	  (dolist (ref (lambda-refs leaf))

	    (mark-for-deletion (node-block ref)))

	  (unless (leaf-ever-used leaf)
	    (let ((*compiler-error-context* bind))

	      (compiler-note _N"Deleting unused function~:[.~;~:*~%  ~S~]"

			     (leaf-name leaf))))

          (unless (block-delete-p bind-block)
	    (unlink-blocks (component-head component) bind-block))

	  (when return