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

;;; Reason: Fix a bug in optimization of SETQ and LET within complicated SETF expansions.

;;;                           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 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for REL6G version 6.3
;;; Written 04/25/89 14:15:45 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Experimental REL6G 6.2, Experimental SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0,
;;;  Experimental EH 6.0, Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0,
;;;  Experimental LOCAL-FILE 6.0, Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0,
;;;  Experimental BASIC-NAMESPACE 6.0, Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0,
;;;  Experimental DISK-LABEL 6.0, Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0,
;;;  Experimental NETWORK-PATHNAME 6.0, Experimental COMPILER 6.0, Experimental TV 6.0,
;;;  Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, Experimental MEMORY-AUX 6.0,
;;;  Experimental NVRAM 6.0, Experimental SYSLOG 6.0, Experimental STREAMER-TAPE 6.0,
;;;  Experimental CLEH 1.0, Experimental UCL 6.0, Experimental INPUT-EDITOR 6.0, Experimental METER 6.0,
;;;  Experimental ZWEI 6.0, Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0,
;;;  Experimental NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0,
;;;  Experimental SERIAL 6.0, Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0,
;;;  Experimental PRINTER-TYPES 6.0, Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0,
;;;  Experimental MAIL-DAEMON 6.0, Experimental MAIL-READER 6.0, Experimental TELNET 6.0,
;;;  Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, Experimental PROFILE 6.0,
;;;  VISIDOC 6.0, Experimental TI-CLOS 16.6, Experimental CLX 4.0, Experimental X11M 2.0,
;;;  Experimental CLUE 19.1, Experimental RPC 6.0, NFS 3.5, Experimental BUG 11.4,
;;;  IP 3.43, Experimental DOCUMENTER 617.0,  microcode 424, Band Name: REL6G,Scribe,
;;; &c u424 4/20

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#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.#"


;;   1        2           3       4     5      6        7       8...
;; (LET   lambda-list outer-vars vars bindp e-lex-cnt lex-cnt . body)
(DEFUN LET-OPT (FORM &OPTIONAL DELETE-ALL)
 ;; 1/25/85 DNG - Call DISCARD on initial value of deleted variable.
 ;; 2/27/85 DNG - Fix for duplicated variable names.
 ;; 3/04/85 DNG - Move check for special variables referenced by the
 ;;               microcode from here to VARS-USED.
 ;; 1/09/86 DNG - Fix handling of doubly-defined variables. [SPR 1518]
 ;; 1/20/86 DNG - Another fix for handling of doubly-defined variables.
 ;; 9/16/86 DNG - Permit deleting variable initialized to (UNDEFINED-VALUE).
 ;; 9/25/86 DNG - Optimize out some variables which are used only once.
 ;;10/02/86 DNG - Don't call DISCARD on a value deleted by PROPAGATE-VALUES.
 ;;10/14/86 DNG - Optimize binding of *STANDARD-OUTPUT* around print functions.
 ;;10/18/86 DNG - Handle more cases of variables used once.
 ;;10/21/86 DNG - Fix for variable used once that depends on special variable bindings.
 ;; 7/02/87 DNG - When substituting the initial value of a variable into its
 ;;		only use in the first body form, check first that it is independent
 ;;		of the value forms of any following bindings.  [SPR 5926]
1 ;; 4/25/89 DNG - Fix initial value form to match the VAR-INIT-FORM when 
 ;;*		1SETQ-OPT has changed the latter.*
  (DECLARE (SPECIAL PROPAGATE-ENABLE))
  (UNLESS PROPAGATE-ENABLE
    (RETURN-FROM LET-OPT FORM))
  (LET ((VARS (FOURTH FORM))
	(VLIST (SECOND FORM))
	(CHANGED NIL)
	V
	USED
	(BODY (NTHCDR 7 FORM))
	(NNEWVARS 0)
	(NEW-PROPAGATE 0))
    (DO ((VS VARS)
	 (VL VLIST (CDR VL)))
	((NULL VL))
      (LOOP DO (SETQ V (FIRST VS)
		     VS (REST VS)
		     NNEWVARS (1+ NNEWVARS))
	    UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)))
    (FLET ((USES-SPECIAL-BINDINGS-P (V OLD-VARS)
	     ;; Does the initial value of this variable use any special variables
	     ;; which are bound in this same LET?
	     (VARS-USED (VAR-INIT-FORM V)
			(LET ((SPECIALS NIL))
			  (DO ((VS VARS (CDR VS)))
			      ((EQ VS OLD-VARS))
			    (WHEN (EQ (VAR-TYPE (CAR VS)) 'FEF-SPECIAL)
			      (PUSH (VAR-LAP-ADDRESS (CAR VS))
				    SPECIALS)))
			  SPECIALS)) ))
    ;; delete unused variables from the lambda list
    (SETQ VLIST
      (LOOP
	FOR VLIST-TAIL ON VLIST
	FOR VAR = (FIRST VLIST-TAIL) ; each variable in lambda list
	DO
	(LOOP DO (SETQ V (NTH (SETQ NNEWVARS (1- NNEWVARS)) VARS))
	      UNTIL (NEQ (VAR-KIND V) 'FEF-ARG-DELETED)
	      FINALLY (UNLESS (EQ (VAR-NAME V)
				  (IF (ATOM VAR) VAR (FIRST VAR)))
			(WARN 'LET-OPT :BUG "Bug in ~S on ~S" 'LET-OPT VAR)
			(RETURN-FROM LET-OPT FORM)))
	1(WHEN (AND (CONSP VAR)*
		1   (EQUAL (SECOND VAR) '(UNDEFINED-VALUE))*
		1   (EQ (FIRST (VAR-INIT V)) 'FEF-INI-COMP-C))*
	1  ;; Clean up change by SETQ-OPT.*
	1  (SETF (SECOND VAR) (VAR-INIT-FORM V)))*
	IF (OR (AND (OR (NULL (SETQ USED (VAR-USE-COUNT V)))   ; never referenced
			(ZEROP USED)	   ; value never used
			DELETE-ALL)	   ; called from DISCARD to throw all away
		    (MEMBER (VAR-KIND V)
			    '(FEF-ARG-INTERNAL-AUX FEF-ARG-FREE FEF-ARG-DELETED)
			    :TEST #'EQ)
		    (OR (EQ (VAR-TYPE V) 'FEF-LOCAL)
			DELETE-ALL
			(AND (OR (NEQ (FIRST FORM) 'LET*)
				 (NULL (REST VLIST-TAIL)))
			     (OR (NULL BODY)
				 (AND (NULL (REST BODY))
				      (OR 
					;; Check for references in the body form.
					(AND (< (OPT-SAFETY OPTIMIZE-SWITCH)
						(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
					     (NULL (VARS-USED (FIRST BODY)
							      (LIST (VAR-LAP-ADDRESS V)))))
					;; Can binding be replaced by an optional argument?
					(AND (EQ (VAR-NAME V) '*STANDARD-OUTPUT*)
					     (MEMBER (CAR-SAFE (FIRST BODY))
						     '( PRIN1 PRINT PPRINT PRINC
						       WRITE-CHAR WRITE-STRING WRITE-LINE
						       WRITE-BYTE))
					     (= (LENGTH (FIRST BODY)) 2)
					     (INDEPENDENT-EXPRESSIONS-P
					       (SECOND (FIRST BODY)) (VAR-INIT-FORM V))
					     (PROGN
					       ;; (LET ((*STANDARD-OUTPUT* x)) (PRINT a)) ==> (PRINT a x)
					       ;; [such forms are created by the FORMAT optimizer]
					       (SETF (CDDR (FIRST BODY))
						     (LIST (VAR-INIT-FORM V)))
					       (SETF VAR NIL)
					       T))
					)))))
		    (OR (ATOM VAR)
			DELETE-ALL
			(NO-SIDE-EFFECTS-P (SECOND VAR))))
	       (AND (EQL USED 1)
		    (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
		    (<= (OPT-SAFETY OPTIMIZE-SWITCH)
			(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
		    (NULL (REST BODY))
		    (CONSP (FIRST BODY))
		    (NOT (QUOTES-ANY-ARGS (FIRST (FIRST BODY))))
		    (MEMBER (VAR-LAP-ADDRESS V) (FIRST BODY) :TEST #'EQ)
		    (NOT (USES-SPECIAL-BINDINGS-P V (THIRD FORM)))
		    (LET ((INIT (VAR-INIT-FORM V)))
		      (AND (DOLIST (X (REST VLIST-TAIL) T)
			     (WHEN (AND (CONSP X)
					(NOT (INDEPENDENT-EXPRESSIONS-P INIT (SECOND X))))
			       (RETURN NIL)))
			   (DO ((ARGS (REST (FIRST BODY)) (REST ARGS)))
			       ((NULL ARGS) NIL)
			     (COND ((EQ (FIRST ARGS) (VAR-LAP-ADDRESS V))
				    ;; (LET ((x (foo a))) (bar x)) ==> (bar (foo a))
				    (SETF (FIRST ARGS) INIT)
				    (SETF VAR NIL)
				    (RETURN T))
				   ((INDEPENDENT-EXPRESSIONS-P INIT (FIRST ARGS)))
				   (T (RETURN NIL)))))))
	       )			   ; variable can be deleted
	DO (PROGN (DEBUG-ASSERT (OR (ATOM VAR)
				    (EQ (SECOND VAR) (VAR-INIT-FORM V))
				    (AND (EQUAL (SECOND VAR) '(UNDEFINED-VALUE))
					 (EQ (FIRST (VAR-INIT V)) 'FEF-INI-NONE))
				    (EQ (VAR-INIT-FORM V) 'DELETED-VALUE))
				NIL "init mismatch in LET-OPT for ~S" (VAR-NAME V))
		  ;; Now mark the variable deleted.
		  (SETF (VAR-KIND V) 'FEF-ARG-DELETED)
		  (UNLESS (OR (ATOM VAR)
			      (EQ (VAR-INIT-FORM V) 'DELETED-VALUE))
		    (DISCARD (SECOND VAR)))
		  (SETQ CHANGED T))
	ELSE COLLECT
	(PROGN
	  (WHEN (AND (EQL USED 1)
		     (MEMBER 'FEF-ARG-NOT-ALTERED (VAR-MISC V))
		     (<= (OPT-SAFETY OPTIMIZE-SWITCH)
			 (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
		     (OR ;;(ZEROP ALTERED-VAR-SET) ; include this when have time to debug it.
		       (INDEPENDENT-EXPRESSIONS-P
			 (VAR-INIT-FORM V)
			 (IF (AND (EQ (FIRST FORM) 'LET*)
				  (REST VLIST-TAIL))
			     FORM
			   (CONS 'VALUES BODY))))
		     (NOT (USES-SPECIAL-BINDINGS-P V (THIRD FORM))))
	    ;; Local variable used exactly once; try to replace the
	    ;; reference with the initial value expression.
	    (SETQ NEW-PROPAGATE
		  (LOGIOR NEW-PROPAGATE (CDDR (VAR-LAP-ADDRESS V)))))
	  VAR))))
    (IF (AND (NULL VLIST) ; empty lambda list
	     (NULL (FIFTH FORM))	   ;  no BIND
	     (= (SIXTH FORM) (SEVENTH FORM))	   ; no lexical closures
	     )
      (CONS 'PROGN BODY)	; (LET () body) ==> (PROGN body)
      (PROGN
	(WHEN CHANGED; some variables deleted
	 ;; change the form instead of creating a new list so that
	 ;;  POST-OPTIMIZE won't waste time calling LET-OPT again.
	  (SETF (SECOND FORM) VLIST))
	(IF (AND (NULL (REST VLIST))
		 (CONSP (FIRST VLIST))
		 (NULL (REST BODY))
		 (EQ (VAR-LAP-ADDRESS (SETQ V (LOOKUP-VAR (FIRST (FIRST VLIST))
							  VARS)))
		     (FIRST BODY))
		 (NULL (FIFTH FORM))	   ; no BIND
		 (= (SIXTH FORM) (SEVENTH FORM))   ; no lexical closures
		 )
	    ;;  (let ((a x)) a) ==> x
	    (PROGN (SETF (VAR-KIND V) 'FEF-ARG-DELETED)
		   (SECOND (FIRST VLIST)))
	  (IF (NOT (ZEROP (LOGDIF NEW-PROPAGATE PROPAGATE-VAR-SET)))
	      (LET* ((PROPAGATE-VAR-SET NEW-PROPAGATE)
		     (DONT-PROPAGATE-INTO-LOOP NEW-PROPAGATE)
		     (NEW-FORM (PROPAGATE-VALUES FORM)))
		(IF (EQ NEW-FORM FORM)
		    (LET-OPT FORM) ; remove variables whose use counts have now become 0
		  NEW-FORM))
	    FORM))))))

))