;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:10; Patch-file:T; Fonts:(CPTFONT CPTFONTB) -*-

;;; Reason: Fix a problem with unsharing of variables used in lexical closures at a branch 
;;; within an inline expansion.  [SPR 10680]

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 149149, M/S 2151             
;;;   AUSTIN, TEXAS 78714
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 10/17/89 16:05:27 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With SYSTEM 6.20, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1,
;;;  BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.4, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.4, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  Inconsistent COMPILER 6.13, TV 6.15, DATALINK 6.0, CHAOSNET 6.1, GC 6.3, MEMORY-AUX 6.0,
;;;  NVRAM 6.2, SYSLOG 6.2, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1,
;;;  ZWEI 6.7, DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.0, MAIL-DAEMON 6.3, MAIL-READER 6.5, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.3, PROFILE 6.2, VISIDOC 6.5, Inconsistent TI-CLOS 6.26, CLEH 6.5,
;;;  IP 3.54, Experimental CLX 6.5, CLUE 6.25, X11M 6.15, Experimental BUG 11.15,
;;;  Experimental DOCUMENTER 701.0,  microcode 430, Band Name: 6.0+Scribe,&c,u430 9/6


;;; BUG REPORT NUMBER:  10680
;;;
;;; PROBLEM:  The compiler enters the debugger with ">>Error: Compiler bug; 
;;;	can't UNSHARE variable ..." in certain cases where GO is used in a 
;;;	function that is expanded inline in a function within another function.  
;;;	For example:
#|
(defun k5 (values something)
  (LET ((results nil))
    #'(lambda ()
	(obscure #'(lambda () something))
	(let ((fn112 #'(LAMBDA (LIST other)
			 (prog ()
			    loop-back
			       (LET ()
				 (IF LIST
				     (PROGN
				       (push (pop LIST) results)
				       (GO loop-back)) ; errors here
				   (return other)))))))
	  (obscure 2)
	  (funcall fn112 values something)
	  results))))
|#
;;; DIAGNOSIS:  In pass 2, when compiling the GO, when function 
;;;	COMPILER::OUTBRET tries to invoke UNSHARE-STACK-CLOSURE-VARS, the value of 
;;;	special variable VARS at that time is not the same as when the GO was 
;;;	processed in pass 1.  Consequently, function (:PROPERTY 
;;;	UNSHARE-STACK-CLOSURE-VARS P2) gets confused because OVARS is not a tail 
;;;	of VARS as assumed.  This results from the way VARS is handled in 
;;;	P1-LET-FOR-P-I in order to compile inline function expansions in the 
;;;	proper lexical context -- the new vars list in the generated %LET form 
;;;	reflects the inline function argument bindings within the lexical context 
;;;	of the call, which is not the same as the value of VARS used to compile 
;;;	the body.  That value of VARS does not get passed to pass 2 unless there 
;;;	happens to be a LET within the body, which will bind VARS correctly for 
;;;	the LET body.  Otherwise, the free reference to VARS in OUTBRET and 
;;;	SIMPLEGOP does not necessarily see the correct value.
;;;
;;;	Furthermore, it would not be sufficient to record the right value in the 
;;;	%LET form to be bound in P2LETX because the %LET form could be eliminated 
;;;	by optimization.  Another possibility would be to wrap a 
;;;	PROGN-WITH-DECLARATIONS form around the body to cause VARS to be bound in 
;;;	pass 2, but that would get in the way of optimizations.
;;;
;;; SOLUTION:  Modify the handling of GO and RETURN-FROM, so that the pass 1 
;;;	handler includes the current value of VARS in the form passed to pass 2.  
;;;	The pass 2 handlers for GO and RETURN-FROM then bind VARS to this value 
;;;	for OUTBRET to use.  Similarly, SIMPLEGOP uses the value from the GO form 
;;;	instead of VARS.  The addition of an extra argument to the internal GO and 
;;;	RETURN-FORM forms also required updates to functions PROPAGATE-VALUES and 
;;;	P2BLOCK.  A minor modification to TAIL-RECURSION-ELIMINATION was also 
;;;	necessary in order for the generated GO to be compiled with an appropriate 
;;;	value for VARS.


#!C
; From file P1HAND.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(DEFUN P1GO (FORM)
  ;;  8/27/85 DNG - Avoid trapping on undefined tag (pass 2 will give warning). [SPR 501]
  ;;  7/08/86 DNG - Change handling of non-local GO.
  ;; 10/18/86 DNG - Put the gotag structure in the form for pass 2 instead of
  ;;		the original tag; give error message here instead of in pass 2.
1  ;; 10/17/89 DNG - Include VARS in the form for pass 2. [part of fix for SPR 10680]*
  (LET ((GOTAG (ASSOC (SECOND FORM) GOTAGS :TEST #'EQUAL)))
    (COND
      ((NULL GOTAG)			   ; undefined tag
       (WARN 'BAD-GO-TAG :IMPOSSIBLE
	     "There is a GO to tag ~S but no such tag exists." (SECOND FORM))
       `(FUNCALL #'GO ',(SECOND FORM)))	   ; arrange for run-time error
      ((ZEROP 1-IF-LIVE-CODE)		   ; dead code; skip bookkeeping
       FORM)
      (T (LET* (( PROGDESC (GOTAG-PROGDESC GOTAG) )
		( PARENT (PROGDESC-COMPILAND PROGDESC) ))
	   (INCF (GOTAG-USE-COUNT GOTAG))
	   (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET (PROGDESC-USED-BIT PROGDESC)))
	   (IF (EQ PARENT *CURRENT-COMPILAND*)  ; local GO
	       1(IF (OR (NULL INLINE-EXPANSIONS)*
		1       (ZEROP MAX-LEXICAL-CLOSURE-COUNT))*
		   `(GO ,GOTAG)
		1 ;; Record VARS here because P1-LET-FOR-P-I doesn't pass them to pass 2.*
		1 `(GO ,GOTAG ,VARS))*
	     ;; Else GO to TAGBODY in a higher-level function
	     (PROGN
	       (SETF (GOTAG-USED-IN-LEXICAL-CLOSURES-FLAG GOTAG) T)
	       (UNLESS (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC)
		 (SETF (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC)
		       (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))
			 ;; If consed in temp area, each function would copy it separately
			 ;; and then it would not be shared by the two functions.
			 (LIST 'TAGBODY
			       (SETF (COMPILAND-FUNCTION-NAME PARENT)
				     (SI:COPY-OBJECT-TREE (COMPILAND-FUNCTION-NAME PARENT) T))
			       (CADR FORM)))))
	       `(*THROW ',(PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC)
			',(CADR FORM))
	       )))))))

))

#!C
; From file P2HAND.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P2HAND.#"


(DEFUN P2GO (ARGL IGNORE)
  ;;  2/12/86 CLM - Bind pdllvl to itself upon entry.
  ;; 10/18/86 DNG - Error checking is now done in pass 1.
1  ;; 10/17/89 DNG - Add binding of VARS. [part of fix for SPR 10680]*
  (LET ((PDLLVL PDLLVL))
1    (LET-IF (REST ARGL)*
	1    ((VARS (SECOND ARGL))) ; for use by OUTBRET*
      (OUTB1 (CAR ARGL))1)*))

))

#!C
; From file P2HAND.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P2HAND.#"


(DEFUN SIMPLEGOP (FORM)
  ;; Return T if given a (GO tag) which could be done with just a branch
  ;; (doesn't require popping anything off the pdl).
  ;;
  ;;  1/22/86 DNG - Fix to check for special bindings also.
  ;; 10/18/86 DNG - Use GOTAGS-SEARCH instead of ASSOC.
  ;; 11/17/86 CLM - Fix to check for lexical-closures.  May have to do an
  ;;                unshare, so don't return T.
  ;; 12/03/86 CLM - Fix to check for lexical closures. Faulty end-test was causing
  ;;                an infinite loop.
  ;;  2/04/87 DNG - When LEXICAL-CLOSURE-COUNT is 0, don't bother looking for variables needing to be unshared.
1  ;; 10/17/89 DNG - Take current variables from (THIRD FORM) instead of VARS.  [part of fix for SPR 10680]*
  (AND (NOT (ATOM FORM))
       (EQ (FIRST FORM) 'GO)
       (LET ((GOTAG (GOTAGS-SEARCH (SECOND FORM) T))
	     PD)
	 (AND GOTAG (= PDLLVL (GOTAG-PDL-LEVEL GOTAG))
	      (SETQ PD (GOTAG-PROGDESC GOTAG))
	      (DOLIST (PROGDESC PROGDESCS T)
		(IF (EQ PROGDESC PD)
		    (RETURN T)
		  (UNLESS (AND (MEMBER (PROGDESC-NBINDS PROGDESC) '(0 NIL) :TEST #'EQ)
			       (OR (ZEROP LEXICAL-CLOSURE-COUNT)
				   (DO ((VS 1(IF (CDDR FORM) (THIRD FORM)* VARS1)* (CDR VS))
					(OVARS (PROGDESC-VARS PROGDESC)))
				       ((OR (EQ VS OVARS)
					    (NULL VS)) T)
				     (LET ((V (CAR VS)))
				       (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)
						     :TEST #'EQ)
					 (RETURN NIL)))) ;DO
				   )
			        );and
		    (RETURN NIL))
		  ))))))

))

#!C
; From file P1HAND.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1HAND.#"


(DEFUN P1-RETURN-HANDLER ( FUNCT BLOCK-NAME VALUE-LIST )
  ;;  7/08/86 DNG - Changed handling of non-local returns.
  ;;  9/09/86 DNG - Changed handling of non-local returns again to fix SPR 505.
  ;;  9/24/86 DNG - Updated error message for SPR 1559.
  ;; 10/18/86 DNG - Use GOTAGS-SEARCH .
1  ;; 10/17/89 DNG - Include VARS in the form for pass 2. [part of fix for SPR 10680]*
  (LET ( PROGDESC ARG )
    (SETQ PROGDESC (COND ((AND (NULL BLOCK-NAME) RETPROGDESC))
			 ((ASSOC BLOCK-NAME PROGDESCS :TEST #'EQ))
			 ((EQ FUNCT 'RETURN)
			  (WARN 'BAD-PROG ':IMPOSSIBLE
			   "~S is not within a BLOCK named NIL or a PROG, DO, or LOOP."
			   (CONS FUNCT VALUE-LIST) )
			   NIL)
			 (T (WARN 'BAD-PROG ':IMPOSSIBLE
	   "There is a RETURN-FROM ~S not inside a BLOCK or PROG of that name."
			BLOCK-NAME )
			   NIL) ) )
    (SETQ ARG (COND ( (= (LENGTH VALUE-LIST) 1)
		     (LET (( P1VALUE (IF PROGDESC
			   ;; Use P1VALUE saved by P1BLOCK in order to
			   ;;  enable Tail Recursion Elimination.
					 (PROGDESC-IDEST PROGDESC)
				       T )))
			(P1 (FIRST VALUE-LIST)) ) )
		   ;; Common Lisp: (RETURN) ==> (RETURN NIL)
		   ;; Zetalisp:    (RETURN) ==> (RETURN (VALUES))
		   ( (AND (NULL VALUE-LIST) COMPILING-COMMON-LISP)
		     '(QUOTE NIL) )
		   ( T (P1EVARGS (CONS 'VALUES VALUE-LIST)) )) )
    (COND ((AND (CONSP ARG)
		(MEMBER (FIRST ARG) '( RETURN-FROM GO *THROW THROW) :TEST #'EQ))
	   ARG)	; (RETURN-FROM a (RETURN-FROM b x)) ==> (RETURN-FROM b x)
	  ((OR (NULL PROGDESC) ; undefined block
	       (ZEROP 1-IF-LIVE-CODE)) ; dead code
	   ;; skip bookkeeping
	   `(RETURN-FROM ,PROGDESC ,ARG 1,VARS*))
	  (T (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET (PROGDESC-USED-BIT PROGDESC)))
	     (COND ((NEQ (PROGDESC-COMPILAND PROGDESC) *CURRENT-COMPILAND*)
		    (PUSHNEW *CURRENT-COMPILAND*
			     (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC)
			     :TEST #'EQ)
		    `(*THROW ,(P1V (PROGDESC-CATCH-TAG PROGDESC))
			     ,ARG ))
		   (T (LET (( TAG (GOTAGS-SEARCH (PROGDESC-RETTAG PROGDESC) T GOTAGS)) )
			;; Increment use count for return tag so that BLOCK
			;;  optimization will know how many RETURNs there were.
			(INCF (GOTAG-USE-COUNT TAG)))
		      `(RETURN-FROM ,PROGDESC ,ARG1 ,VARS*) ))))))
))

#!C
; From file P2HAND.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P2HAND.#"


(DEFUN P2RETURN-FROM (ARGL IGNORE)
  ;;  1/30/86 CLM - For Rel.3, modified to handle cases where there is a
  ;;                return from within a CATCH or an UNWIND-PROTECT.
  ;;  2/05/86 CLM - An addendum to the above modification.  This handles
  ;;                returns from within the undo forms of unwind-protect's.
  ;;  2/12/86 CLM - Bind pdllvl to itself upon entry.
  ;;  2/12/86 DNG - Decrement PDLLVL and NPOPS by 4 for each %CLOSE-CATCH.
  ;;  2/14/86 DNG - Use OUTI instead of OUTF for NCONS.
  ;;  3/11/86 CLM - Added special handling for when mvtarget equals return.
  ;;  5/07/86 CLM - If mvtarget equals RETURN and a single value is being
  ;;                returned, push 1 on the stack to set up for a RETURN-N.
  ;;  7/16/86 CLM - Use the global variable CATCH-BLOCK-SIZE.
  ;;  8/28/86 CLM - Fix so that if RPDESC is null, just return from the function
  ;;  9/05/86 CLM - Changed to handle new RETURN-CATCH value for M-V-TARGET.
  ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol.
  ;; 11/17/86 CLM - Changed to handle new UNWIND-PROTECT's.
  ;; 11/24/86 CLM - Fix so that a return from a block generated within the undo forms is
  ;;                not treated as a return from the undo forms.
1  ;; 10/17/89 DNG - Add binding of VARS. [part of fix for SPR 10680]
  (debug-assert (cddr argl))*
  (LET ((RPDESC (FIRST ARGL))		   ; prog descriptor to return from. 
	(ARG (SECOND ARGL))		   ; value to be returned
	1(VARS (THIRD ARGL)) ; lexically visible variables for use by OUTBRET*
	IPROGDEST
	MVTARGET
	SINGLE-VALUE-RETURN
	NVALUES
	(PDLLVL PDLLVL)
	(CALL-BLOCK-PDL-LEVELS CALL-BLOCK-PDL-LEVELS))
    (IF (NULL RPDESC)
	;; Only get here in case of an error which has already
	;;  been reported in pass 1.  Just return from the function.
	(SETQ IPROGDEST 'D-RETURN)
      ;; Else get info for the referenced block.
      (PROGN
	(SETQ IPROGDEST (PROGDESC-IDEST RPDESC))
	(SETQ MVTARGET (PROGDESC-M-V-TARGET RPDESC))
	))
    ;; If going to throw values, things expect tag on top of stack.  So copy it to there.
    (WHEN (EQ MVTARGET 'THROW)
      (UNLESS (= PDLLVL (PROGDESC-PDL-LEVEL RPDESC))
	(P2PUSH-CONSTANT (- PDLLVL (PROGDESC-PDL-LEVEL RPDESC)))
	(OUTI '(MISC D-PDL PDL-WORD))
	(INCPDLLVL)))
    ;; Compile the arg with same destination and m-v-target
    ;; that the PROG we are returning from had.
    ;;If there is a return from within an unwind-protect or a catch,
    ;;handle it as follows.
    (COND ((OR (AND RPDESC
		    (EQ IPROGDEST 'D-RETURN)
		    (NOT (NULL CALL-BLOCK-PDL-LEVELS))
		    (<= (PROGDESC-PDL-LEVEL RPDESC)
			(IF (CONSP (CAR CALL-BLOCK-PDL-LEVELS))
			    (CAAR CALL-BLOCK-PDL-LEVELS)
			  (CAR CALL-BLOCK-PDL-LEVELS))))
	       (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ))
	  (LET ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS))))
	    ;;return-catch prevents P2LET-INTERNAL from trying to unbind
	    ;;special variables.
	    ;;
	    ;;new unwind-protect scheme - if within the undo forms must 
	    ;;do an unwind-protect-cleanup before the returned form is 
	    ;;compiled.  This requires cleaning off the stack so that
	    ;;the unwind-protect-cleanup works properly.
	    ;;UNDO-PDL-LEVEL is a list of all undo pdlplvl's processed so far.
	    (WHEN (AND (CONSP (CAR CALL-BLOCK-PDL-LEVELS))
		       (EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT)
		       (EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO)
		       UNDO-PDL-LEVEL)
		(OUT-AUX 'POP-PDL (- PDLLVL
				     (CAR UNDO-PDL-LEVEL)))
		(OUT-AUX '%UNWIND-PROTECT-CLEANUP)
		(POP CALL-BLOCK-PDL-LEVELS)
		(DECF PDLLVL (- PDLLVL (CAR UNDO-PDL-LEVEL)))
		(POP UNDO-PDL-LEVEL))
	    (SETQ SINGLE-VALUE-RETURN (P2MV ARG 'D-PDL
					    (IF (EQ MVTARGET 'RETURN)
						MVTARGET 'RETURN-CATCH)))
	    (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L)))
		((OR (NULL L)
		     (< (IF (CONSP (CAR L))
			    (CAAR L)
			    (CAR L))
			(PROGDESC-PDL-LEVEL RPDESC))))
	      ;;If within an unwind-protect,
	      ;;jump to the cleanup forms subr
	      ;;unless you're already in the cleanup forms.
	      ;;If you are returning completely out of the funtion,
	      ;;you don't have to worry about the stuff left on the
	      ;;stack by all the intervening %close-catch-unwind-protect's.
	      (IF (AND (CONSP (CAR L))
		       (EQ (CADAR L) 'UNWIND-PROTECT))
		  (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO)
		      (PROGN
			(OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)
			(SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))
			(OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L)))
			(OUT-AUX '%UNWIND-PROTECT-CONTINUE)
			))
		  (PROGN
		    (OUT-AUX '%CLOSE-CATCH)
		    (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))))
	      )
	    (IF (MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)
		(PROGN
		  (WHEN SINGLE-VALUE-RETURN	;set up for an ultimate return-n
			(P2PUSH-CONSTANT 1))
		  (OUTB `(BRANCH ALWAYS NIL NIL ,(GOTAG-PROG-TAG (PROGDESC-RETTAG RPDESC)))))
		(PROGN
			  (IF SINGLE-VALUE-RETURN
			      ;;a single value
			      (OUT-AUX '(RETURN 0 PDL-POP))
			      ;;multiple values
			      (OUT-AUX 'RETURN-N))
			  (SETQ DROPTHRU NIL)))) )
	  ;;This is specifically for a return from an undo.  As above we are
	  ;;not concerned with items left on the stack by previous unwind-protect
	  ;;closes.  This means they will be left on the stack, which may present 
	  ;;a problem.
	  ((AND (NOT (NULL CALL-BLOCK-PDL-LEVELS))
		(CONSP (CAR CALL-BLOCK-PDL-LEVELS))
		(EQ (CADAR CALL-BLOCK-PDL-LEVELS) 'UNWIND-PROTECT)
		(EQ (CAR (LAST (CAR CALL-BLOCK-PDL-LEVELS))) 'UNDO)
		(PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))
	   (LET* ((UNDO-PDL-LEVEL (PROGDESC-UNDO-PDL-LEVEL (FIRST PROGDESCS)))
		 (PDLLVL-DELTA (- PDLLVL (CAR UNDO-PDL-LEVEL))))
	     (IF (ZEROP PDLLVL-DELTA)
		 (OUT-AUX 'POP-PDL 1) ;haven't pushed anything on the stack but must pop the restart-macro-pc
	       (OUT-AUX 'POP-PDL PDLLVL-DELTA))
	     (OUT-AUX '%UNWIND-PROTECT-CLEANUP)
	     (DECF PDLLVL (IF (ZEROP PDLLVL-DELTA) 1 PDLLVL-DELTA))
	     
	     (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST
					     MVTARGET))

	     (POP CALL-BLOCK-PDL-LEVELS)   ;get rid of current one
	     
	     (DO ((L CALL-BLOCK-PDL-LEVELS (CDR L)))
		 ((OR (NULL L)
		      (< (IF (CONSP (CAR L))
			     (CAAR L)
			     (CAR L))
			 (PROGDESC-PDL-LEVEL RPDESC))))
	       ;;if within an unwind-protect,
	       ;;jump to the cleanup forms subr
	       ;;unless you're in the cleanup forms.
	       (IF (AND (CONSP (CAR L))
			(EQ (CADAR L) 'UNWIND-PROTECT))
		   (UNLESS (EQ (CAR (LAST (CAR L))) 'UNDO)
		     (PROGN
		       (OUT-AUX '%CLOSE-CATCH-UNWIND-PROTECT)
		       (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))
		       (OUTB `(BRANCH PUSHJ NIL NIL ,(CADDAR L)))
		       (OUT-AUX '%UNWIND-PROTECT-CONTINUE)
		       ))
		   (PROGN
		     (OUT-AUX '%CLOSE-CATCH)
		     (SETQ PDLLVL (- PDLLVL CATCH-BLOCK-SIZE))))
	       (POP CALL-BLOCK-PDL-LEVELS) )
	     )
	   )
	   
	  (T (SETQ SINGLE-VALUE-RETURN (P2MV ARG IPROGDEST MVTARGET))
 	     ) )

    ;; But, since a PROG has multiple returns, we can't simply
    ;; pass on to the PROG's caller whether this function did or did not
    ;; generate those multiple values if desired.
    ;; If the function failed to, we just have to compensate here.
    (AND SINGLE-VALUE-RETURN
	 (COND
	   ((NUMBERP MVTARGET)
	    ;; If we wanted N things on the stack, we have only 1, so push N-1 NILs.
	    (PUSH-NILS (- MVTARGET 1)))
	   ((EQ MVTARGET 'MULTIPLE-VALUE-LIST)
	    (OUTI '(MISC D-PDL NCONS)))))

    (SETQ NVALUES (COND
		    ((NUMBERP MVTARGET) MVTARGET)
		    ((EQ IPROGDEST 'D-PDL) 1)
		    (T 0)))
    ;; Note how many things we have pushed.
    (AND (EQ IPROGDEST 'D-PDL)
	 (MKPDLLVL (+ PDLLVL NVALUES)))

    ;; Jump to the prog's rettag, unless the prog is top-level (to d-return)
    ;; since in that case the code just compiled will not ever drop through.
    (OR (EQ IPROGDEST 'D-RETURN)
	(MEMBER MVTARGET '(RETURN RETURN-CATCH) :TEST #'EQ)
	(OUTBRET (PROGDESC-RETTAG RPDESC) RPDESC NVALUES))))
))

#!C
; From file P2HAND.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P2HAND.#"


(DEFUN P2BLOCK (ARGL DEST &OPTIONAL BIND-RETPROGDESC D-INDS-LOSES)
  ;;  7/03/86 DNG - Eliminate binding of RETPROGDESC since it is now handled in pass 1.
  ;; 10/18/86 DNG - RETTAG is now a structure instead of a symbol; don't need GOTAGS anymore.
1  ;; 10/17/89 DNG - Include (PROGDESC-VARS MYPROGDESC) in the args for P2RETURN-FROM.*
  (DECLARE (IGNORE BIND-RETPROGDESC)) ; no longer used
  (LET* ((MYGOTAGS (CAR ARGL))
	 (MYPROGDESC (CADR ARGL))
	 (BDY (CDDR ARGL))
	 (RETTAG (PROGDESC-RETTAG MYPROGDESC))
	 (PROGDESCS (CONS MYPROGDESC PROGDESCS))
	 )
    (PROG (IDEST NVALUES)
	  ;; Determine the immediate destination of returns in this prog.
	  (SETQ IDEST 'D-PDL)
	  (AND (MEMBER DEST '(D-IGNORE D-INDS D-RETURN) :TEST #'EQ)
	       (NOT (AND (EQ DEST 'D-INDS) D-INDS-LOSES))
	       (NULL M-V-TARGET)
	       (SETQ IDEST DEST))
	  ;; How many words are we supposed to leave on the stack?
	  (SETQ NVALUES (COND
			  ((NUMBERP M-V-TARGET) M-V-TARGET)
			  ((EQ IDEST 'D-PDL) 1)
			  (T 0)))
	  (SETF (PROGDESC-IDEST MYPROGDESC) IDEST)
	  (SETF (PROGDESC-M-V-TARGET MYPROGDESC) M-V-TARGET)
	  (SETF (PROGDESC-PDL-LEVEL MYPROGDESC) PDLLVL)
	  (SETF (PROGDESC-NBINDS MYPROGDESC) 0)
	  ;; Set the GOTAG-PDL-LEVEL of each the rettag.
	  ;; MYGOTAGS contains the RETTAG and nothing else.
	  (SETF (GOTAG-PROGDESC (CAR MYGOTAGS)) (CAR PROGDESCS))
	  (SETF (GOTAG-PDL-LEVEL (CAR MYGOTAGS)) (+ PDLLVL NVALUES))
	  ;; Generate code for the body.
	  (IF (NULL BDY)
	      (P2RETURN-FROM `(,MYPROGDESC (QUOTE NIL)1 ,(PROGDESC-VARS MYPROGDESC)*)
			     'D-IGNORE)
	    (DO ((TAIL BDY (CDR TAIL)))
		((NULL (CDR TAIL))
		 (P2RETURN-FROM (LIST MYPROGDESC (CAR TAIL) 1(PROGDESC-VARS MYPROGDESC)*)
				'D-IGNORE))
	      (P2 (CAR TAIL) 'D-IGNORE)))
	  ;; If this is a top-level BLOCK, we just went to D-RETURN,
	  ;; and nobody will use the RETTAG, so we are done.
	  (AND (EQ DEST 'D-RETURN)
	       (RETURN NIL))
	  ;; Otherwise, this is where RETURNs jump to.
	  (SETQ PDLLVL (GOTAG-PDL-LEVEL (CAR MYGOTAGS)))
	  (OUTTAG (GOTAG-PROG-TAG RETTAG))
	  ;; Store away the value if
	  ;; it is not supposed to be left on the stack.
	  (AND (NEQ DEST IDEST)
	       (NULL M-V-TARGET)
	       (MOVE-RESULT-FROM-PDL DEST))
	  ;; If we were supposed to produce multiple values, we did.
	  (SETQ M-V-TARGET NIL))))
))

#!C
; From file P1OPT.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1OPT.#"


(DEFUN PROPAGATE-VALUES (FORM)
  ;; FORM is an S-expression which has already been processed by P1.
  ;; Scans the expression looking for local variable references
  ;;  which can be replaced by the variable's initial value,
  ;;  making the substitution in place.  Also re-optimizes any
  ;;  forms whose arguments have been changed.
  ;; 1/25/85 - Original version.
  ;; 2/29/85 - Allow for some more special forms.
  ;; 3/04/85 - Do constant folding on *PLUS etc.
  ;; 3/23/85 - Fix replacement of initial value of variable.
  ;; 9/28/85 - Recognize special form VARIABLE-LOCATION.
  ;; 1/07/86 - Special handling for PROG1.
  ;; 5/05/86 - Check (CONSP NEW-FORM) before doing (FIRST NEW-FORM) [SPR 1827];
  ;;	       eliminate obsolete reference to P2NODEST.
  ;; 7/03/86 - Add handling for LEXICAL-CLOSURE.
  ;; 8/14/86 - No longer need special handling for *PLUS, etc.
  ;; 9/09/86 - Increment use count of propagated BREAKOFF-FUNCTION.
  ;; 9/19/86 - Allow propagating BREAKOFF-FUNCTION; add use of
  ;;		DONT-PROPAGATE-INTO-LOOP; mark compilands that have only one use.
  ;;10/18/86 - Don't need to bind GOTAGS anymore.
  ;;11/04/86 - Fix to handle MULTIPLE-VALUE-PUSH correctly.
  ;; 6/18/87 - Fix updating of PROPAGATE-VAR-SET for SPR 4977, and
  ;;		don't process arguments of UNSHARE-STACK-CLOSURE-VARS.
  ;; 4/24/89 - Add recognition of %LOAD-TIME-VALUE .
  ;; 4/26/89 - Add support for %LET and %LET*.
  ;; 5/03/89 - Be careful to not change the destination of a SETQ.
1  ;; 10/17/89 - Update handling of GO and RETURN-FROM to skip the new vars argument.*
  (DECLARE (VALUES NEW-FORM ANY-TOP-LEVEL-CHANGES?))
  (DECLARE (INLINE TRIVIAL-FORM-P))
  (IF (OR (ATOM FORM)
	  (NOT (DEBUG-ASSERT (SYMBOLP (FIRST FORM)))))
      (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))
    (LET ((CHANGED NIL))
      (IF (EQ (FIRST FORM) 'THE-EXPR)
	  (PROGN
	    (LET ((USED-VAR-SET (EXPR-USED FORM))
		  (ALTERED-VAR-SET (EXPR-ALTERED FORM))
		  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)
		  (OPTIMIZE-SWITCH (EXPR-OPTIMIZE FORM)))
	      (SETF (EXPR-FORM FORM) (PROPAGATE-VALUES (EXPR-FORM FORM)))
	      (SETF (EXPR-USED FORM) USED-VAR-SET))
	    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (EXPR-USED FORM)))
	    (SETQ CHANGED T))
	(LET (ARG-LIST
	      (CLAUSE-LIST NIL)
	      (P1VALUE P1VALUE)
	      (P1VALUE-FIRST T)
	      (P1VALUE-LAST T)
	      (P1VALUE-MIDDLE T)
	      (BIND-VARS NIL)
	      (BIND-VALS NIL))
	  (SETQ ARG-LIST
		(COND
		  ((MEMBER (FIRST FORM) '(%LET %LET*) :TEST #'EQ)
		   ;; (%LET ( bound-vars new-vars outer-vars bindp closuresp ) . body)
		   (LET ((VARS (SECOND (SECOND FORM))))
		     (SETQ BIND-VARS '(VARS)
			   BIND-VALS (LIST VARS))
		     (DOLIST (V (FIRST (SECOND FORM)))   ; each variable in lambda list
		       (LET ((LAPA (VAR-LAP-ADDRESS V)))
			 (UNLESS
			   (OR (WHEN (EQ (VAR-INIT-KIND V) 'FEF-INI-COMP-C)
				 (MULTIPLE-VALUE-BIND (NEW-INIT CHANGED-INIT)
				     (PROPAGATE-VALUES (VAR-INIT-FORM V))
				   (WHEN CHANGED-INIT
				     (SETF (VAR-INIT-FORM V) NEW-INIT)
				     (SETQ CHANGED T)
				     (WHEN (AND (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)
						(EQ (VAR-TYPE V) 'FEF-LOCAL)
						(CONSP NEW-INIT)
						(MEMBER (FIRST NEW-INIT)
							'(QUOTE LOCAL-REF FUNCTION BREAKOFF-FUNCTION)
							:TEST #'EQ)
						(NOT (LOGTEST (CDDR LAPA) ALTERED-VAR-SET))
						(NOT (AND (EQ (FIRST NEW-INIT) 'LOCAL-REF)
							  (LOGTEST (CDDR NEW-INIT)
								   ALTERED-VAR-SET))))
				       (SETQ PROPAGATE-VAR-SET
					     (LOGIOR PROPAGATE-VAR-SET (CDDR LAPA)))))))
			       (NOT (EQ (CAR-SAFE LAPA) 'LOCAL-REF))
			       (LOGTEST (CDDR LAPA) DONT-PROPAGATE-INTO-LOOP))
			   ;; Kludge for SPR 4977 - make sure that PROPAGATE-VAR-SET doesn't
			   ;; have the bit set for a different variable that happens to have
			   ;; the same bit mask.  This can happen when a LET is wrapped around
			   ;; a form that has already been processed by P1, as in
			   ;; FIX-FUNCALL-EVALUATION-ORDER for example.
			   (SETQ PROPAGATE-VAR-SET
				 (LOGDIF PROPAGATE-VAR-SET (CDDR LAPA)))
			   ))))
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE)
		   (NTHCDR 2 FORM))
		  ((ZEROP (LOGAND PROPAGATE-VAR-SET USED-VAR-SET))
		   ;; There aren't any variables eligible for substitution, so quit.
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((EQ (FIRST FORM) 'PROGN)
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE) (REST FORM))
		  ((MEMBER (FIRST FORM) '(BLOCK BLOCK-FOR-PROG
					   BLOCK-FOR-WITH-STACK-LIST)
			   :TEST #'EQ)
		   ;;(SETQ BIND-VARS '(GOTAGS)
		   ;;	   BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE) (CDDDR FORM))
		  ((EQ (FIRST FORM) 'MULTIPLE-VALUE-BIND)
		   (NTHCDR 4 FORM))
		  ((MEMBER (FIRST FORM)
			   '(PROGN-WITH-DECLARATIONS  MULTIPLE-VALUE
			     MULTIPLE-VALUE-PUSH MULTIPLE-VALUE-SETQ CLOSURE
			     SETQ INTERNAL-PSETQ)
			   :TEST #'EQ)
		   (CDDR FORM))
		  1((EQ (FIRST FORM) 'RETURN-FROM)*
		    1(SETQ P1VALUE-LAST 'SKIP)*
		    1(CDDR FORM))*
		  ((EQ (FIRST FORM) 'COND)
		   (SETQ CLAUSE-LIST (REST FORM))
		   (SETQ P1VALUE-FIRST 'D-INDS
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE) NIL)
		  ((MEMBER (FIRST FORM) '(AND OR) :TEST #'EQ)
		   (WHEN (OR (NULL P1VALUE) (EQ P1VALUE 'D-INDS))
		     (SETQ P1VALUE-FIRST 'D-INDS
			   P1VALUE-MIDDLE 'D-INDS))
		   (SETQ P1VALUE-LAST P1VALUE) (REST FORM))
		  ((EQ (FIRST FORM) 'TAGBODY)
		   ;;(SETQ BIND-VARS '(GOTAGS)
		   ;;      BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST NIL)
		   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET
						   DONT-PROPAGATE-INTO-LOOP))
		   (CDDR FORM))
		  ((EQ (FIRST FORM) '%DOLIST)
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST NIL)
		   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET
						   DONT-PROPAGATE-INTO-LOOP))
		   (CDDR FORM))
		  ((EQ (FIRST FORM) 'LOCAL-REF) (LIST FORM))
		  ((TRIVIAL-FORM-P FORM)
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((MEMBER (FIRST FORM) '( 1GO* VARIABLE-LOCATION UNSHARE-STACK-CLOSURE-VARS 
					  %LOAD-TIME-VALUE) :TEST #'EQ)
		   ;; special form with no evaluated arguments
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((MEMBER (FIRST FORM) '(PROG1 MULTIPLE-VALUE-PROG1)
			   :TEST #'EQ)
		   (SETQ P1VALUE-FIRST P1VALUE
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST NIL) (REST FORM))
		  ((EQ (FIRST FORM) 'LEXICAL-CLOSURE)
		   #|
		   (LET* ((COMPILAND (SECOND FORM))
			  (USED-VAR-SET (COMPILAND-USED-VAR-SET COMPILAND))
			  (ALTERED-VAR-SET (COMPILAND-ALTERED-VAR-SET COMPILAND))
			  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)
			  (OPTIMIZE-SWITCH (COMPILAND-OPTIMIZE COMPILAND)))
		     (SETF (COMPILAND-EXP2 COMPILAND)
			   (PROPAGATE-VALUES (COMPILAND-EXP2 COMPILAND)))
		     (SETF (COMPILAND-USED-VAR-SET COMPILAND) USED-VAR-SET))
		    |#
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((DEBUG-ASSERT
		     (OR (NOT (QUOTES-ANY-ARGS (FIRST FORM)))
			 (MEMBER (FIRST FORM)
				 '(SETQ INTERNAL-PSETQ SET-AR-1
					UNWIND-PROTECT *CATCH CATCH) :TEST #'EQ)))
		   (REST FORM))
		  (T (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))) ))
	  (PROGV BIND-VARS BIND-VALS
	    (DO ((FORM-LIST (OR ARG-LIST (POP CLAUSE-LIST)) (POP CLAUSE-LIST)))
		((AND (NULL FORM-LIST)
		      (NULL CLAUSE-LIST)))
	      (LOOP FOR ARGS ON FORM-LIST DO
		    (LET ((ARG (FIRST ARGS)))
		      (COND
			((ATOM ARG))
			((EQ (FIRST ARG) 'LOCAL-REF)
			 (WHEN (LOGTEST (CDDR ARG) PROPAGATE-VAR-SET)
			   (LET* ((V (SECOND ARG))
				  (NEW (OR (VAR-INIT-FORM V) '(QUOTE NIL))))
			     (SETQ CHANGED T)
			     (DECF (VAR-USE-COUNT V))
			     (DEBUG-ASSERT (>= (VAR-USE-COUNT V) 0)
					   ((VAR-USE-COUNT V) USED-VAR-SET)
					   "Negative var use count")
			     (WHEN (ZEROP (VAR-USE-COUNT V))	   ; no more uses
			       (SETQ USED-VAR-SET (LOGDIF USED-VAR-SET (CDDR ARG)))
			       (SETQ ALTERED-VAR-SET
				     (LOGDIF ALTERED-VAR-SET (CDDR ARG))))
			     (COND ((ATOM NEW))
				   ((EQ (CAR NEW) 'LOCAL-REF)
				    (INCF (VAR-USE-COUNT (SECOND NEW)))
				    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR NEW))))
				   ((MEMBER (CAR NEW) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))
				    (WHEN (AND (= (VAR-USE-COUNT V) 0)
					       (= (COMPILAND-USE-COUNT (SECOND NEW)) 1))
				      ;; flag for PROCEDURE-INTEGRATION
				      (SETF (GETF (COMPILAND-PLIST (SECOND NEW))
						  'USED-ONLY-ONCE)
					    T))
				    (INCF (COMPILAND-USE-COUNT (SECOND NEW))))
				   ((TRIVIAL-FORM-P NEW))
				   ((DEBUG-ASSERT (ZEROP (VAR-USE-COUNT V)))
				    ;; rather than scanning the expression incrementing
				    ;; the use counts for everything it references, just
				    ;; delete the original expression.
				    (SETF (VAR-INIT-FORM V) 'DELETED-VALUE)))
			     (IF (EQ ARG FORM)
				 (RETURN-FROM PROPAGATE-VALUES (VALUES NEW T))
			       (SETF (FIRST ARGS) NEW)))))
			((TRIVIAL-FORM-P ARG))
			(T
			 (SETQ P1VALUE
			       (COND ((NULL (REST ARGS)) P1VALUE-LAST)
				     ((EQ ARGS FORM-LIST) P1VALUE-FIRST)
				     (T P1VALUE-MIDDLE)))
			 1(UNLESS (EQ P1VALUE 'SKIP)*
			    (MULTIPLE-VALUE-BIND (NEW-ARG WAS-CHANGED)
				(PROPAGATE-VALUES ARG)
			      (WHEN WAS-CHANGED
				(SETF (FIRST ARGS) NEW-ARG)
				(SETQ CHANGED T)))1)*))))	 ; end of LOOP
	      )	   ; end of DO
	    )	   ; end of PROGV
	  )	   ; end of LET on ARG-LIST and P1VALUE
	)	   ; end of IF THE-EXPR
      (IF CHANGED
	  (LET ((NEW-FORM (POST-OPTIMIZE FORM)))
	    (RETURN-FROM PROPAGATE-VALUES (VALUES NEW-FORM (NEQ NEW-FORM FORM))))
	(RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
      )	; end of LET CHANGED
    )	; end of IF ATOM
  )
))

#!C
; From file P1FUNS.LISP#> COMPILER; Hotel:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; P1FUNS.#"


(DEFUN TAIL-RECURSION-ELIMINATION ( FORM AGAIN-TAG ARGLIST OUTER-VARS )
;; Performs tail recursion elimination by replacing function call FORM
;; with a PSETQ to assign the argument variables in ARGLIST and a
;; GO to AGAIN-TAG.
;; Returns the expression to substitute for FORM, or NIL if unsuccessful.
  ;;  2/22/86 DNG - Unshare variables used in lexical closures before looping back.
  ;;  8/28/86 CLM - Add arg to call to match-args-with-values to indicate that args
  ;;                have already been processed - i.e., quoted args have been quoted
  ;; 12/16/86 DNG - Fix for unsharing arguments that are closed over.
  ;; 11/18/87 CLM - Fix so that DECLAREd IGNORE arguments do not get values assigned
  ;;                to them unless there are possible side-effects.  This prevents
  ;;                the compiler from issuing warnings about ignored variables
  ;;                being referenced [SPR 6783].
  ;;  2/10/88 DNG - Fix to not try to unshare non-local variables by using new 
  ;;		argument OUTER-VARS. [SPR 7113 and 7205]
1  ;; 10/17/89 DNG - Move the call to P1 for the generated GO inside the 
  ;;*		1binding of VARS because P1GO now records it.*
 (LET ( ARGVARS TEMP )
    (COND ( (SETQ TEMP (ASSOC AGAIN-TAG GOTAGS :TEST #'EQ)) ; tag is defined
	    (SETQ ARGVARS (PROGDESC-VARS (GOTAG-PROGDESC TEMP))) )
	       ; ARGVARS is the value of VARS saved just after the arguments were
	       ;     entered; this is used to bypass any shadowing of the argument names.
	  ( (SETQ TEMP (ASSOC (FIRST FORM) INLINE-EXPANSIONS :TEST #'EQUAL))
	      ; within an inline expansion; throw back to function
	      ;  PROCEDURE-INTEGRATION to tell it we need a tag to
	      ;  loop back to.
	    (THROW (SECOND TEMP) 'TAIL-RECURSION-ELIMINATION) )
	  ( T (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL) ) )
   (MULTIPLE-VALUE-BIND ( PSETQVARS ; list of variable names for PSETQ of args
			  PSETQVALS ; list of value expressions for PSETQ
			  SETQVARS  ; list of defaulted variables for SETQ
			  SETQVALS  ; list of default values for SETQ
			  ERROR NIL )
	  (MATCH-ARGS-WITH-VALUES ARGLIST (REST FORM) t)
    (WHEN ERROR (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL))
    ;; Now build the replacement form, being careful to apply P1 in the
    ;; correct order and in the correct lexical context.
    (LET ( (SETQ-FORM NIL) PSETQ-FORM 1RETURN-FORM* )
      (LET (( VARS ARGVARS ))
      (LABELS (( BUILD-PSETQ ( NAMES VALS )
		(IF (NULL NAMES)
		    NIL
		    (LET ((VAR (LOOKUP-VAR (FIRST NAMES)))) 
		      ;;check for IGNORE'd variables
		      (IF (AND (MEMBER 'IGNORE (VAR-DECLARATIONS VAR) :TEST #'EQ)
			       (OR (NULL (VAR-USE-COUNT VAR))
				   (ZEROP (VAR-USE-COUNT VAR)))
			       (NO-SIDE-EFFECTS-P (FIRST VALS))
			       )
			  (LIST* 
			   (BUILD-PSETQ (REST NAMES) (REST VALS)))
			  (LIST* (P1SETVAR (FIRST NAMES))
			   (FIRST VALS)
			   (BUILD-PSETQ (REST NAMES) (REST VALS))
			   )) )
		    )))
	(SETQ PSETQ-FORM
	      (POST-OPTIMIZE (CONS 'INTERNAL-PSETQ
				   (BUILD-PSETQ (NREVERSE PSETQVARS)
						(NREVERSE PSETQVALS))))) )
      (WHEN SETQVARS
	(SETQ SETQ-FORM
	      (LET ((SETQLIST NIL))
		(LOOP WHILE SETQVARS
		      DO (LET ((VAR (LOOKUP-VAR (CAR SETQVARS)))) ;PROGN
			   ;;check for IGNORE'd variables
			   (IF (AND (MEMBER 'IGNORE (VAR-DECLARATIONS VAR) :TEST #'EQ)
				    (OR (NULL (VAR-USE-COUNT VAR))
					(ZEROP (VAR-USE-COUNT VAR)))
				    (NO-SIDE-EFFECTS-P (CAR SETQVALS))
				    )
			       (PROGN
				 (POP SETQVALS)
				 (POP SETQVARS))
			       (PROGN
			        (PUSH (P1V (POP SETQVALS)) SETQLIST)
				(PUSH (P1SETVAR (POP SETQVARS)) SETQLIST)) )))
		(CONS 'SETQ SETQLIST) ) ) )
      1(SETQ* RETURN-FORM (LIST (P1 `(GO ,AGAIN-TAG)))1 )*
      ) ; LET VARS
      (LET ()
	(UNLESS (NULL (COMPILAND-CHILDREN *CURRENT-COMPILAND*))
	  (LET ((ARGS-USED-IN-CLOSURES NIL))
	    (DOLIST (V ARGVARS)
	      (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ)
		(PUSH (VAR-LAP-ADDRESS V) ARGS-USED-IN-CLOSURES)))
	    (WHEN ARGS-USED-IN-CLOSURES
	      (IF (VARS-USED (CONS 'PROGN (CDR FORM))
			     ARGS-USED-IN-CLOSURES)
		  (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL)
		;; Unshare the argument variables.
		(SETQ PSETQ-FORM `(PROGN (UNSHARE-STACK-CLOSURE-VARS ,ARGVARS ,OUTER-VARS)
					 ,PSETQ-FORM)) )))
	  (WITH-STACK-LIST* (VARS-LISTS VARS HIDDEN-ACTIVE-VARS)
	     ;; Unshare any local variables bound within the loop being created.
	    (DOLIST ( HV VARS-LISTS )
	      (LET ((TAIL (AND (TAILP ARGVARS HV)
				  ARGVARS)))
		 (PUSH `(UNSHARE-STACK-CLOSURE-VARS ,HV ,TAIL)
		       RETURN-FORM)
		 (WHEN TAIL (RETURN)) ))))
	#+compiler:debug
	(when compiler-verbose
	  (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))	;Stream may cons
	    (format t "~%Tail Recursion Elimination performed on ~S" (FIRST FORM))))
	`(PROGN ,PSETQ-FORM
		,SETQ-FORM
		. ,RETURN-FORM) )
      ))))
))