;;; -*- Package: C -*-
;;;
;;; **********************************************************************
;;; 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/byte-comp.lisp $")

;;;
;;; **********************************************************************
;;;
;;; This file contains the noise to byte-compile stuff.  It uses the
;;; same front end as the real compiler, but generates a byte-code instead
;;; of native code.
;;;
;;; Written by William Lott
;;;

(in-package "C")

(intl:textdomain "cmucl")

(export '(disassem-byte-component
	  disassem-byte-fun
	  backend-byte-fasl-file-type
	  backend-byte-fasl-file-implementation
	  byte-fasl-file-version))

;;; ### Remaining work:
;;;

;;; - add more inline operations.

;;; - Breakpoints/debugging info.

;;;


;;;; Fasl file format:

;; The fasl file version should be a series of hex digits in the range
;; 0-9 followed by a single hex digit in the range a-f.  Then the
;; version looks like a decimal number followed by a minor release
;; letter of a to f.

(defconstant byte-fasl-file-version #x20d)

(let* ((version-string (format nil "~X" byte-fasl-file-version)))

  ;; Add :cmu<n> to *features*
  (sys:register-lisp-feature (intern (concatenate 'string "CMU" version-string)
				     :keyword))
  ;; Same as above, except drop the trailing a-f character.

  (sys:register-lisp-feature (intern (concatenate 'string "CMU"

						  (subseq version-string 0
							  (1- (length version-string))))

				     :keyword)))

(defun backend-byte-fasl-file-type (backend)
  (ecase (backend-byte-order backend)
    (:big-endian "bytef")
    (:little-endian "lbytef")))

(defun backend-byte-fasl-file-implementation (backend)

  (ecase (backend-byte-order backend)
    (:big-endian big-endian-fasl-file-implementation)

    (:little-endian little-endian-fasl-file-implementation)))


;;;; Stuff to emit noise.

;;; Note: we use the regular assembler, but we don't use any ``instructions''
;;; because there is no way to keep our byte-code instructions seperate from
;;; the instructions used by the native backend.  Besides, we don't want to do
;;; any scheduling or anything like that, anyway.

(declaim (inline output-byte))
(defun output-byte (segment byte)
  (declare (type new-assem:segment segment)
	   (type (unsigned-byte 8) byte))
  (new-assem:emit-byte segment byte))

;;; OUTPUT-EXTENDED-OPERAND  --  Internal
;;;
;;;    Output Operand as 1 or 4 bytes, using #xFF as the extend code.
;;;
(defun output-extended-operand (segment operand)
  (declare (type (unsigned-byte 24) operand))
  (cond ((<= operand 254)
	 (output-byte segment operand))
	(t
	 (output-byte segment #xFF)
	 (output-byte segment (ldb (byte 8 16) operand))
	 (output-byte segment (ldb (byte 8 8) operand))
	 (output-byte segment (ldb (byte 8 0) operand)))))

;;; OUTPUT-BYTE-WITH-OPERAND -- internal.
;;;
;;; Output a byte, logior'ing in a 4 bit immediate constant.  If that

;;; immediate won't fit, then emit it as the next 1-4 bytes.

;;; 
(defun output-byte-with-operand (segment byte operand)
  (declare (type new-assem:segment segment)
	   (type (unsigned-byte 8) byte)

	   (type (unsigned-byte 24) operand))

  (cond ((<= operand 14)
	 (output-byte segment (logior byte operand)))
	(t
	 (output-byte segment (logior byte 15))

	 (output-extended-operand segment operand)))

  (undefined-value))

;;; OUTPUT-LABEL -- internal.
;;;
(defun output-label (segment label)
  (declare (type new-assem:segment segment)
	   (type new-assem:label label))
  (new-assem:assemble (segment)
    (new-assem:emit-label label)))

;;; OUTPUT-REFERENCE -- internal.
;;;
;;; Output a reference to LABEL.  If RELATIVE is NIL, then this reference
;;; can never be relative.
;;;
(defun output-reference (segment label)
  (declare (type new-assem:segment segment)
	   (type new-assem:label label))
  (new-assem:emit-back-patch
   segment
   3
   #'(lambda (segment posn)
       (declare (type new-assem:segment segment)
		(ignore posn))
       (let ((target (new-assem:label-position label)))
	 (assert (<= 0 target (1- (ash 1 24))))
	 (output-byte segment (ldb (byte 8 16) target))
	 (output-byte segment (ldb (byte 8 8) target))
	 (output-byte segment (ldb (byte 8 0) target))))))

;;; OUTPUT-BRANCH -- internal.
;;;
;;; Output some branch byte-sequence.
;;; 
(defun output-branch (segment kind label)
  (declare (type new-assem:segment segment)
	   (type (unsigned-byte 8) kind)
	   (type new-assem:label label))
  (new-assem:emit-chooser
   segment 4 1
   #'(lambda (segment posn delta)
       (when (<= (- (ash 1 7))
		 (- (new-assem:label-position label posn delta) posn 2)
		 (1- (ash 1 7)))
	 (new-assem:emit-chooser
	  segment 2 1
	  #'(lambda (segment posn delta)
	      (declare (ignore segment) (type index posn delta))

	      (when (and (eql kind byte-branch-always)
			 (zerop (- (new-assem:label-position label posn delta)
				   posn 2)))

		;; Don't emit anything, because the branch is to the following

		;; instruction.  Only do this for unconditional branches,
		;; because the conditional ones pop the byte stack.

		t))
	  #'(lambda (segment posn)
	      ;; We know we fit in one byte.
	      (declare (type new-assem:segment segment)
		       (type index posn))
	      (output-byte segment (logior kind 1))
	      (output-byte segment
			   (ldb (byte 8 0)
				(- (new-assem:label-position label) posn 2)))))
	 t))
   #'(lambda (segment posn)
       (declare (type new-assem:segment segment)
		(ignore posn))
       (let ((target (new-assem:label-position label)))
	 (assert (<= 0 target (1- (ash 1 24))))
	 (output-byte segment kind)
	 (output-byte segment (ldb (byte 8 16) target))
	 (output-byte segment (ldb (byte 8 8) target))
	 (output-byte segment (ldb (byte 8 0) target))))))


;;;; System constants, Xops, and inline functions.

;;; If (%fdefinition-marker% . name), then the value is the fdefinition 
(defvar *system-constant-codes* (make-hash-table :test #'equal))

(eval-when (compile eval)
  (defmacro def-system-constant (index form)

    `(let ((val ,form))
       (setf (gethash val *system-constant-codes*) ,index))))

(def-system-constant 0 nil)
(def-system-constant 1 t)

(def-system-constant 2 :start)
(def-system-constant 3 :end)
(def-system-constant 4 :test)
(def-system-constant 5 :count)
(def-system-constant 6 :test-not)
(def-system-constant 7 :key)
(def-system-constant 8 :from-end)
(def-system-constant 9 :type)

(def-system-constant 10 '(%fdefinition-marker% . error))
(def-system-constant 11 '(%fdefinition-marker% . format))
(def-system-constant 12 '(%fdefinition-marker% . %typep))
(def-system-constant 13 '(%fdefinition-marker% . eql))
(def-system-constant 14 '(%fdefinition-marker% . %negate))

(def-system-constant 15 '(%fdefinition-marker% . %%defun))
(def-system-constant 16 '(%fdefinition-marker% . %%defmacro))
(def-system-constant 17 '(%fdefinition-marker% . %%defconstant))
(def-system-constant 18 '(%fdefinition-marker% . length))
(def-system-constant 19 '(%fdefinition-marker% . equal))
(def-system-constant 20 '(%fdefinition-marker% . append))
(def-system-constant 21 '(%fdefinition-marker% . reverse))
(def-system-constant 22 '(%fdefinition-marker% . nreverse))
(def-system-constant 23 '(%fdefinition-marker% . nconc))
(def-system-constant 24 '(%fdefinition-marker% . list))
(def-system-constant 25 '(%fdefinition-marker% . list*))

(def-system-constant 26 '(%fdefinition-marker% . %coerce-to-function))
(def-system-constant 27 '(%fdefinition-marker% . values-list))

(defparameter *xop-names*

  '(breakpoint; 0
    dup; 1
    type-check; 2
    fdefn-function-or-lose; 3
    default-unknown-values; 4

    push-n-under; 5

    xop6
    xop7

    merge-unknown-values

    make-closure

    throw
    catch
    breakup
    return-from
    tagbody
    go

    unwind-protect))

(defun xop-index-or-lose (name)
  (or (position name *xop-names* :test #'eq)

      (error (intl:gettext "Unknown XOP ~S") name)))

(defstruct inline-function-info

  ;;
  ;; Name of the function that we convert into calls to this.
  (function (required-argument) :type symbol)
  ;;
  ;; Name of function that the interpreter should call to implement this.  May
  ;; not be the same as above if extra safety checks are required.
  (interpreter-function (required-argument) :type symbol)
  ;;
  ;; Inline operation number.
  (number (required-argument) :type (mod 32))
  ;;
  ;; Type calls must statisfy.
  (type (required-argument) :type function-type)
  ;;
  ;; If true, arg type checking need not be done.
  (safe (required-argument) :type (member t nil)))

(defparameter *inline-functions* (make-array 32 :initial-element nil))
(defparameter *inline-function-table* (make-hash-table :test #'eq))
(let ((number 0))
  (dolist (stuff
	   '((+ (fixnum fixnum) fixnum)
	     (- (fixnum fixnum) fixnum)
	     (make-value-cell (t) t)
	     (value-cell-ref (t) t)
	     (value-cell-setf (t t) (values))
	     (symbol-value (symbol) t :interpreter-function %byte-symbol-value)
	     (setf-symbol-value (t symbol) (values))
	     (%byte-special-bind (t symbol) (values))
	     (%byte-special-unbind () (values))
	     (cons-unique-tag () t); obsolete...
	     (%negate (fixnum) fixnum)
	     (< (fixnum fixnum) t)
	     (> (fixnum fixnum) t)
	     (car (t) t :interpreter-function %byte-car :safe t)
	     (cdr (t) t :interpreter-function %byte-cdr :safe t)
	     (length (list) t)
	     (cons (t t) t)
	     (list (t t) t)

	     (list* (t t t) t)
	     (%instance-ref (t t) t)
	     (%setf-instance-ref (t t t) (values))))

    (destructuring-bind (name arg-types result-type
			      &key (interpreter-function name) alias safe)
			stuff
      (let ((info
	     (make-inline-function-info
	      :function name
	      :number number
	      :interpreter-function interpreter-function
	      :type (specifier-type `(function ,arg-types ,result-type))
	      :safe safe)))
	(setf (svref *inline-functions* number) info)
	(setf (gethash name *inline-function-table*) info))
      (unless alias (incf number)))))

(defun inline-function-number-or-lose (function)

  (let ((info (gethash function *inline-function-table*)))

    (if info
	(inline-function-info-number info)

	(error (intl:gettext "Unknown inline function: ~S") function))))


;;;; Byte-code specific transforms:

(deftransform eql ((x y) ((or fixnum character) (or fixnum character))
		   * :when :byte)
  '(eq x y))

(deftransform char= ((x y) * * :when :byte)
  '(eq x y))


;;;; Annotations hung off the IR1 while compiling.

(defstruct byte-component-info
  (constants (make-array 10 :adjustable t :fill-pointer 0)))


(defstruct byte-lambda-info
  (label nil :type (or null label))
  (stack-size 0 :type index)
  (interesting t :type (member t nil)))

(defun block-interesting (block)
  (byte-lambda-info-interesting (lambda-info (block-home-lambda block))))

(defstruct byte-lambda-var-info
  (argp nil :type (member t nil))
  (offset 0 :type index))

(defstruct byte-nlx-info
  (stack-slot nil :type (or null index))
  (label (new-assem:gen-label) :type new-assem:label)
  (duplicate nil :type (member t nil)))

(defstruct (byte-block-info
	    (:include block-annotation)
	    (:print-function %print-byte-block-info)
	    (:constructor make-byte-block-info
			  (block &key produces produces-sset consumes
			    total-consumes nlx-entries nlx-entry-p)))
  (label (new-assem:gen-label) :type new-assem:label)
  ;;

  ;; A list of the CONTINUATIONs describing values that this block pushes onto
  ;; the stack.  Note: PRODUCES and CONSUMES can contain the keyword :NLX-ENTRY
  ;; marking the place on the stack where a non-local-exit frame is added or
  ;; removed.  Since breaking up a NLX restores the stack, we don't have to
  ;; about (and in fact must not) discard values underneath a :NLX-ENTRY marker
  ;; evern though they appear to be dead (since they might not be.)

  (produces nil :type list)
  ;;

  ;; An SSET of the produces for faster set manipulations.  The elements are
  ;; the BYTE-CONTINUATION-INFO objects.  :NLX-ENTRY markers are not
  ;; represented.

  (produces-sset (make-sset) :type sset)
  ;;

  ;; A list of the continuations that this block pops from the stack.  See
  ;; PRODUCES.

  (consumes nil :type list)
  ;;
  ;; The transitive closure of what this block and all its successors
  ;; consume.  After stack-analysis, that is.
  (total-consumes (make-sset) :type sset)
  ;;
  ;; Set to T whenever the consumes lists of a successor changes and the
  ;; block is queued for re-analysis so we can easily avoid queueing the same
  ;; block several times.
  (already-queued nil :type (member t nil))
  ;;

  ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this
  ;; block starts.

  (start-stack :unknown :type (or (member :unknown) list))
  ;;

  ;; The continuations and :NLX-ENTRY markers on the stack (in order) when this
  ;; block ends.

  (end-stack nil :type list)
  ;;

  ;; List of ((nlx-info*) produces consumes) for each ENTRY in this block that
  ;; is a NLX target.

  (nlx-entries nil :type list)
  ;;
  ;; T if this is an %nlx-entry point, and we shouldn't just assume we know
  ;; what is going to be on the stack.
  (nlx-entry-p nil :type (member t nil)))

(defprinter byte-block-info
  block)

(defstruct (byte-continuation-info
	    (:include sset-element)
	    (:print-function %print-byte-continuation-info)

	    (:constructor make-byte-continuation-info
			  (continuation results placeholders)))

  (continuation (required-argument) :type continuation)
  (results (required-argument)

	   :type (or (member :fdefinition :eq-test :unknown) index))
  ;;
  ;; If the DEST is a local non-MV call, then we may need to push some number
  ;; of placeholder args corresponding to deleted (unreferenced) args.  If
  ;; PLACEHOLDERS /= 0, then RESULTS is PLACEHOLDERS + 1.
  (placeholders (required-argument) :type index))

(defprinter byte-continuation-info
  continuation

  results
  (placeholders :test (/= placeholders 0)))


;;;; Annotate the IR1

(defun annotate-continuation (cont results &optional (placeholders 0))

  ;; For some reason, do-nodes does the same return node multiple times,
  ;; which causes annotate-continuation to be called multiple times on the
  ;; same continuation.  So we can't assert that we haven't done it.
  #+nil
  (assert (null (continuation-info cont)))
  (setf (continuation-info cont)

	(make-byte-continuation-info cont results placeholders))

  (undefined-value))

(defun annotate-set (set)
  ;; Annotate the value for one value.
  (annotate-continuation (set-value set) 1))

;;; ANNOTATE-BASIC-COMBINATION-ARGS  --  Internal
;;; 
;;;    We do different stack magic for non-MV and MV calls to figure out how
;;; many values should be pushed during compilation of each arg.
;;;
;;; Since byte functions are directly caller by the interpreter (there is no
;;; XEP), and it doesn't know which args are actually used, byte functions must
;;; allow unused args to be passed.  But this creates a problem with local
;;; calls, because these unused args would not otherwise be pushed (since the
;;; continuation has been deleted.)  So, in this function, we count up
;;; placeholders for any unused args contiguously preceding this one.  These
;;; placeholders are inserted under the referenced arg by
;;; CHECKED-CANONICALIZE-VALUES. 
;;;
;;; With MV calls, we try to figure out how many values are actually generated.
;;; We allow initial args to supply a fixed number of values, but everything
;;; after the first :unknown arg must also be unknown.  This picks off most of
;;; the standard uses (i.e. calls to apply), but still is easy to implement.
;;;

(defun annotate-basic-combination-args (call)
  (declare (type basic-combination call))
  (etypecase call
    (combination

     (if (and (eq (basic-combination-kind call) :local)
	      (member (functional-kind (combination-lambda call))
		      '(nil :optional :cleanup)))
	 (let ((placeholders 0))
	   (declare (type index placeholders))
	   (dolist (arg (combination-args call))
	     (cond (arg
		    (annotate-continuation arg (1+ placeholders) placeholders)
		    (setq placeholders 0))
		   (t
		    (incf placeholders)))))
	 (dolist (arg (combination-args call))
	   (when arg
	     (annotate-continuation arg 1)))))

    (mv-combination
     (labels
	 ((allow-fixed (remaining)
	    (when remaining
	      (let* ((cont (car remaining))
		     (values (nth-value 1
					(values-types
					 (continuation-derived-type cont)))))
		(cond ((eq values :unknown)
		       (force-to-unknown remaining))
		      (t
		       (annotate-continuation cont values)
		       (allow-fixed (cdr remaining)))))))
	  (force-to-unknown (remaining)
	    (when remaining
	      (let ((cont (car remaining)))
		(when cont
		  (annotate-continuation cont :unknown)))
	      (force-to-unknown (cdr remaining)))))
       (allow-fixed (mv-combination-args call)))))
  (undefined-value))

(defun annotate-local-call (call)

  (cond ((mv-combination-p call)
	 (annotate-continuation
	  (first (basic-combination-args call))
	  (length (lambda-vars (combination-lambda call)))))
	(t
	 (annotate-basic-combination-args call)
	 (when (member (functional-kind (combination-lambda call))
		       '(nil :optional :cleanup))
	   (dolist (arg (basic-combination-args call))
	     (when arg
	       (setf (continuation-%type-check arg) nil))))))

  (annotate-continuation (basic-combination-fun call) 0)
  (when (node-tail-p call)
    (set-tail-local-call-successor call)))

;;; ANNOTATE-FULL-CALL  --  Internal
;;;
;;;    Annotate the values for any :full combination.  This includes inline

;;; functions, multiple value calls & throw.  If a real full call or a safe
;;; inline operation, then clear any type-check annotations.  When we are done,
;;; remove jump to return for tail calls.

;;;

;;; Also, we annotate slot accessors as inline if no type check is needed and
;;; (for setters) no value needs to be left on the stack.
;;;

(defun annotate-full-call (call)
  (let* ((fun (basic-combination-fun call))

	 (args (basic-combination-args call))

	 (name (continuation-function-name fun))

	 (info (gethash name *inline-function-table*)))

    (flet ((annotate-args ()
	     (annotate-basic-combination-args call)

	     ;;
	     ;; We cannot assume that we can delete type checks here.
	     ;; For instance, (GCD X) will be source-transformed to
	     ;; (ABS X), and GCD expects an integer argument while ABS
	     ;; expects a number only.

	     (dolist (arg args)

	       (when (and (continuation-type-check arg)
			  (policy call (< safety 3)))

		 (setf (continuation-%type-check arg) :deleted)))
	     (annotate-continuation
	      fun
	      (if (continuation-function-name fun) :fdefinition 1))))
      (cond ((mv-combination-p call)
	     (cond ((eq name '%throw)
		    (assert (= (length args) 2))
		    (annotate-continuation (first args) 1)
		    (annotate-continuation (second args) :unknown)
		    (setf (node-tail-p call) nil)
		    (annotate-continuation fun 0))
		   (t
		    (annotate-args))))
	    ((and info
		  (valid-function-use call (inline-function-info-type info)))
	     (annotate-basic-combination-args call)
	     (setf (node-tail-p call) nil)
	     (setf (basic-combination-info call) info)
	     (annotate-continuation fun 0)
	     (when (inline-function-info-safe info)
	       (dolist (arg args)
		 (when (continuation-type-check arg)
		   (setf (continuation-%type-check arg) :deleted)))))
	    ((and name 
		  (let ((leaf (ref-leaf (continuation-use fun))))
		    (and (slot-accessor-p leaf)
			 (or (policy call (zerop safety))
			     (not (find 't args
					:key #'continuation-type-check)))
			 (if (consp name)
			     (not (continuation-dest (node-cont call)))

			     t)
			 (= (length args) (if (consp name) 2 1)))))

	     (setf (basic-combination-info call)
		   (gethash (if (consp name) '%setf-instance-ref '%instance-ref)
			    *inline-function-table*))
	     (setf (node-tail-p call) nil)
	     (annotate-continuation fun 0)
	     (annotate-basic-combination-args call))
	    (t
	     (annotate-args)))))

  ;; If this is (still) a tail-call, then blow away the return.
  (when (node-tail-p call)
    (node-ends-block call)
    (let ((block (node-block call)))
      (unlink-blocks block (first (block-succ block)))
      (link-blocks block (component-tail (block-component block)))))

  (undefined-value))

(defun annotate-known-call (call)
  (annotate-basic-combination-args call)
  (setf (node-tail-p call) nil)
  (annotate-continuation (basic-combination-fun call) 0)
  t)

(defun annotate-basic-combination (call)
  ;; Annotate the function.
  (let ((kind (basic-combination-kind call)))
    (case kind
      (:local
       (annotate-local-call call))
      (:full
       (annotate-full-call call))

      (:error
       (setf (basic-combination-kind call) :full)
       (annotate-full-call call))

      (t
       (unless (and (function-info-byte-compile kind)
		    (funcall (or (function-info-byte-annotate kind)
				 #'annotate-known-call)
			     call))
	 (setf (basic-combination-kind call) :full)
	 (annotate-full-call call)))))

  (undefined-value))

(defun annotate-if (if)
  ;; Annotate the test.
  (let* ((cont (if-test if))
	 (use (continuation-use cont)))
    (annotate-continuation
     cont
     (if (and (combination-p use)
	      (eq (continuation-function-name (combination-fun use)) 'eq)
	      (= (length (combination-args use)) 2))
	 ;; If the test is a call to EQ, then we can use branch-if-eq
	 ;; so don't need to actually funcall the test.
	 :eq-test
	 ;; Otherwise, funcall the test for 1 value.
	 1))))

(defun annotate-return (return)
  (let ((cont (return-result return)))
    (annotate-continuation
     cont
     (nth-value 1 (values-types (continuation-derived-type cont))))))

(defun annotate-exit (exit)
  (let ((cont (exit-value exit)))
    (when cont
      (annotate-continuation cont :unknown))))

(defun annotate-block (block)
  (do-nodes (node cont block)
    (etypecase node
      (bind)
      (ref)
      (cset (annotate-set node))
      (basic-combination (annotate-basic-combination node))
      (cif (annotate-if node))
      (creturn (annotate-return node))
      (entry)
      (exit (annotate-exit node))))
  (undefined-value))

(defun annotate-ir1 (component)
  (do-blocks (block component)
    (when (block-interesting block)
      (annotate-block block)))
  (undefined-value))



;;;; Stack analysis.

(defvar *byte-continuation-counter*)

;;; COMPUTE-PRODUCES-AND-CONSUMES  --  Internal
;;;
;;;    Scan the nodes in Block and compute the information that we will need to
;;; do flow analysis and our stack simulation walk.  We simulate the stack
;;; within the block, reducing it to ordered lists representing the values we
;;; remove from the top of the stack and place on the stack (not considering
;;; values that are produced and consumed within the block.)  A NLX entry point
;;; is considered to push a :NLX-ENTRY marker (can be though of as the run-time
;;; catch frame.)
;;;

(defun compute-produces-and-consumes (block)
  (let ((stack nil)
	(consumes nil)
	(total-consumes (make-sset))
	(nlx-entries nil)

	(nlx-entry-p nil))

    (labels ((interesting (cont)
	       (and cont
		    (let ((info (continuation-info cont)))
		      (and info
			   (not (member (byte-continuation-info-results info)
					'(0 :eq-test)))))))
	     (consume (cont)

	       (cond ((not (or (eq cont :nlx-entry) (interesting cont))))

		     (stack
		      (assert (eq (car stack) cont))
		      (pop stack))
		     (t

		      (adjoin-cont cont total-consumes)
		      (push cont consumes))))
	     (adjoin-cont (cont sset)

	       (unless (eq cont :nlx-entry)
		 (let ((info (continuation-info cont)))
		   (unless (byte-continuation-info-number info)
		     (setf (byte-continuation-info-number info)
			   (incf *byte-continuation-counter*)))
		   (sset-adjoin info sset)))))

      (do-nodes (node cont block)
	(etypecase node
	  (bind)
	  (ref)
	  (cset
	   (consume (set-value node)))
	  (basic-combination
	   (dolist (arg (reverse (basic-combination-args node)))
	     (when arg
	       (consume arg)))
	   (consume (basic-combination-fun node))

	   (case (continuation-function-name (basic-combination-fun node))
	     (%nlx-entry
	      (let ((nlx-info (continuation-value
			       (first (basic-combination-args node)))))
		(ecase (cleanup-kind (nlx-info-cleanup nlx-info))
		  ((:catch :unwind-protect)
		   (consume :nlx-entry))
		  ;;
		  ;; If for a lexical exit, we will see a breakup later, so
		  ;; don't consume :NLX-ENTRY now.

		  ((:tagbody :dynamic-extent))

		  (:block
		   (let ((cont (nlx-info-continuation nlx-info)))
		     (when (interesting cont)
		       (push cont stack))))))
	      (setf nlx-entry-p t))

	     (%lexical-exit-breakup
	      (unless (byte-nlx-info-duplicate
		       (nlx-info-info
			(continuation-value
			 (first (basic-combination-args node)))))
		(consume :nlx-entry)))
	     ((%catch-breakup %unwind-protect-breakup)

	      (consume :nlx-entry))))

	  (cif
	   (consume (if-test node)))
	  (creturn
	   (consume (return-result node)))
	  (entry

	   (let* ((cup (entry-cleanup node))
		  (nlx-info (cleanup-nlx-info cup)))

	     (when nlx-info

	       (push :nlx-entry stack)

	       (push (list nlx-info stack (reverse consumes))

		     nlx-entries))))

	  (exit
	   (when (exit-value node)
	     (consume (exit-value node)))))
	(when (and (not (exit-p node)) (interesting cont))

	  (push cont stack)))
    

      (setf (block-info block)

	    (make-byte-block-info
	     block
	     :produces stack
	     :produces-sset (let ((res (make-sset)))
			      (dolist (product stack)
				(adjoin-cont product res))
			      res)
	     :consumes (reverse consumes)
	     :total-consumes total-consumes
	     :nlx-entries nlx-entries
	     :nlx-entry-p nlx-entry-p))))

  (undefined-value))

(defun walk-successors (block stack)
  (let ((tail (component-tail (block-component block))))
    (dolist (succ (block-succ block))
      (unless (or (eq succ tail)
		  (not (block-interesting succ))
		  (byte-block-info-nlx-entry-p (block-info succ)))
	(walk-block succ block stack)))))

;;; CONSUME-STUFF  --  Internal
;;;
;;;    Take a stack and a consumes list, and remove the appropriate stuff.
;;; When we consume a :NLX-ENTRY, we just remove the top marker, and leave any
;;; values on top intact.  This represents the desired effect of
;;; %CATCH-BREAKUP, etc., which don't affect any values on the stack.
;;;
(defun consume-stuff (stack stuff)
  (let ((new-stack stack))
    (dolist (cont stuff)
      (cond ((eq cont :nlx-entry)
	     (assert (find :nlx-entry new-stack))
	     (setq new-stack (remove :nlx-entry new-stack :count 1)))
	    (t
	     (assert (eq (car new-stack) cont))
	     (pop new-stack))))
    new-stack))

;;; WALK-NLX-ENTRY  --  Internal
;;;

;;; NLX-infos is the list of nlx-info structures for this ENTRY note.  Consume
;;; and Produce are the values from outside this block that were consumed and
;;; produced by this block before the ENTRY node.  Stack is the globally
;;; simulated stack at the start of this block.
;;;

(defun walk-nlx-entry (nlx-infos stack produce consume)

  (let ((stack (consume-stuff stack consume)))
    (dolist (nlx-info nlx-infos)
      (walk-block (nlx-info-target nlx-info) nil (append produce stack))))

  (undefined-value))

;;; WALK-BLOCK  --  Internal
;;;
;;;    Simulate the stack across block boundaries, discarding any values that
;;; are dead.  A :NLX-ENTRY marker prevents values live at a NLX entry point
;;; from being discarded prematurely.
;;;

(defun walk-block (block pred stack)
  ;; Pop everything off of stack that isn't live.
  (let* ((info (block-info block))
	 (live (byte-block-info-total-consumes info)))
    (collect ((pops))
      (let ((fixed 0))
	(flet ((flush-fixed ()
		 (unless (zerop fixed)
		   (pops `(%byte-pop-stack ,fixed))
		   (setf fixed 0))))
	  (loop
	    (unless stack
	      (return))

	    (let ((cont (car stack)))
	      (when (or (eq cont :nlx-entry)
			(sset-member (continuation-info cont) live))

		(return))
	      (pop stack)

	      (let ((results
		     (byte-continuation-info-results
		      (continuation-info cont))))

		(case results
		  (:unknown
		   (flush-fixed)
		   (pops `(%byte-pop-stack 0)))
		  (:fdefinition
		   (incf fixed))
		  (t
		   (incf fixed results))))))
	  (flush-fixed)))
      (when (pops)
	(assert pred)
	(let ((cleanup-block
	       (insert-cleanup-code pred block
				    (continuation-next (block-start block))
				    `(progn ,@(pops)))))
	  (annotate-block cleanup-block))))

    (cond ((eq (byte-block-info-start-stack info) :unknown)
	   ;; Record what the stack looked like at the start of this block.
	   (setf (byte-block-info-start-stack info) stack)
	   ;; Process any nlx entries that build off of our stack.
	   (dolist (stuff (byte-block-info-nlx-entries info))
	     (walk-nlx-entry (first stuff) stack (second stuff) (third stuff)))
	   ;; Remove whatever we consume.

	   (setq stack (consume-stuff stack (byte-block-info-consumes info)))

	   ;; Add whatever we produce.
	   (setf stack (append (byte-block-info-produces info) stack))
	   (setf (byte-block-info-end-stack info) stack)
	   ;; Pass that on to all our successors.
	   (walk-successors block stack))
	  (t
	   ;; We have already processed the successors of this block.  Just
	   ;; make sure we thing the stack is the same now as before.

	   ;;
	   ;; Comment out the assertion because it doesn't hold if there
	   ;; is an nlx-entry above.  I think.  --gerd 2003-10-09
	   #+nil 

	   (assert (equal (byte-block-info-start-stack info) stack)))))
  (undefined-value))

;;; BYTE-STACK-ANALYZE  --  Internal
;;;
;;;    Do lifetime flow analysis on values pushed on the stack, then call do
;;; the stack simulation walk to discard dead values.  In addition to
;;; considering the obvious inputs from a block's successors, we must also
;;; consider %NLX-ENTRY targets to be successors in order to ensure that any
;;; values only used in the NLX entry stay alive until we reach the mess-up
;;; node.  After then, we can keep the values from being discarded by placing a
;;; marker on the simulated stack.
;;;

(defun byte-stack-analyze (component)
  (let ((head nil))

    (let ((*byte-continuation-counter* 0))
      (do-blocks (block component)
	(when (block-interesting block)
	  (compute-produces-and-consumes block)
	  (push block head)
	  (setf (byte-block-info-already-queued (block-info block)) t))))

    (let ((tail (last head)))
      (labels ((maybe-enqueue (block)
		 (when (block-interesting block)
		   (let ((info (block-info block)))
		     (unless (byte-block-info-already-queued info)
		       (setf (byte-block-info-already-queued info) t)
		       (let ((new (list block)))
			 (if head
			     (setf (cdr tail) new)
			     (setf head new))
			 (setf tail new))))))
	       (maybe-enqueue-predecessors (block)