;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:10; Patch-file:T; Fonts:(CPTFONT CPTFONTB) -*- ;;; Reason: Fix a bug regarding reference to a non-local lexical variable that was ;;; initialized by a SETQ after the lexical environment for the closure was ;;; constructed. [SPR 10612 and 10658] ;;; 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. ;;; Patch file for COMPILER version 6.12 ;;; Written 09/27/89 15:56:38 by GRAY, ;;; while running on Kelvin from band LOD2 ;;; With SYSTEM 6.15, VIRTUAL-MEMORY 6.1, EH 6.4, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.2, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; Inconsistent COMPILER 6.11, TV 6.15, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0, ;;; NVRAM 6.1, SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ;;; ZWEI 6.5, DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.2, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.4, Inconsistent TI-CLOS 6.23, CLEH 6.5, ;;; IP 3.48, Experimental CLX 6.2, CLUE 6.10, X11M 6.13, Experimental BUG 11.15, ;;; Experimental DOCUMENTER 701.0, microcode 429, Band Name: 6.0+Scribe,&c,u430 9/6 ;;; BUG REPORT NUMBER: 10612 and 10658 ;;; ;;; PROBLEM: Incorrect code generated for situations like this: ;;; (LET (P (VAR 5)) ;;; (SETQ P #'(LAMBDA () VAR)) ;;; #'(LAMBDA () P)) ;;; In this example, the closure returned as the result of the LET closes over ;;; the initial value of P, NIL, instead of referencing the closure that was ;;; assigned to P by the SETQ. This is because the lexical environment was ;;; created with the copy-out bit set for both VAR and P, so the NIL is copied ;;; out and the later assignment is not seen. ;;; ;;; DIAGNOSIS: This problem is new in release 6; it results from the new ;;; optimization to propagate values of variables initialized by SETQ. ;;; Variable P in the example is flagged as not being altered after being ;;; initialized, so it meets the criteria used in function PASS2 for ;;; setting the copy-out bit [SI:%%LEXENV-DESC-VALUE] even though the ;;; initialization is not actually performed until after the value has been ;;; copied out. ;;; ;;; PASS2 could check to see if the variable uses FEF-INI-SETQ initialization, ;;; but it wouldn't be able to tell whether the SETQ came before or after the ;;; construction of the lexical environment. ;;; ;;; SOLUTION: In function SETQ-OPT [post-optimizer for SETQ], when a ;;; variable is changed to use FEF-INI-SETQ initialization, check to see ;;; whether it is in the COMPILAND-INITIAL-ENVIRONMENT-VARS list. If so, that ;;; means that creation of a lexical environment has occurred between the ;;; binding of the variable and the SETQ that initializes it. In that case, ;;; we simply leave the variable's bit on in ALTERED-VAR-SET so that it is not ;;; marked as unaltered. ;;; ;;; DEPENDENCIES: [none] ;;; ;;; CODEREAD: C.L.M. #!C ; From file P1OPT.LISP#> SYS6.COMPILER; Kelvin: #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 SETQ-OPT (FORM) ;; 3/03/89 DNG - Add optimization to convert SETQ to initialization. ;; Currently, this is done only for the cases needed for optimizing the ;; macro expansion of (SETF (SLOT-VALUE ...)...). ;; 3/10/89 DNG - Fix to not trap when source argument is a special variable. ;; 5/03/89 DNG - Generalized conversion of SETQ to initialization. ;; 5/07/89 DNG - Check SETQ-PROPAGATE-ENABLE . 1 ;; 9/27/89 DNG - When optimizing to use FEF-INI-SETQ, don't reset the ;;* 1variable's bit in ALTERED-VAR-SET if the variable is included in ;;* 1COMPILAND-INITIAL-ENVIRONMENT-VARS; this is so that PASS2 won't set its ;;* 1SI:%%LEXENV-DESC-VALUE bit. [SPR 10612 and 10658]* (WHEN (NULL (REST FORM)) ; (SETQ) ==> NIL (RETURN-FROM SETQ-OPT '(QUOTE NIL))) (DO ((PAIRS (REST FORM) (CDDR PAIRS))) ((NULL PAIRS) FORM) (WHEN (EQ (FIRST PAIRS) (SECOND PAIRS)) ; setting a variable to itself (LET ((NEWFORM (CONS (FIRST FORM) (SETQ-OPT-1 (REST FORM))))) ;; (SETQ ... a b x x y z ...) ==> (SETQ ... a b y z ...) (WHEN P1VALUE ;; if the value of the SETQ form is going to be used, ;; check whether the last assignment was deleted; ;; if so, construct a PROGN to hold the value. (LOOP WHILE (CDDR PAIRS) DO (SETQ PAIRS (CDDR PAIRS))) (WHEN (EQ (FIRST PAIRS) (SECOND PAIRS)) (SETQ NEWFORM (LIST 'PROGN (POST-OPTIMIZE NEWFORM) (FIRST PAIRS))))) (RETURN-FROM SETQ-OPT NEWFORM))) (WHEN (EQ (CAR-SAFE (FIRST PAIRS)) 'LOCAL-REF) ; assigning to a local variable (LET ((VAR (SECOND (FIRST PAIRS))) INIT-FORM) (IF (EQ (VAR-INIT-KIND VAR) 'FEF-INI-SETQ) (WHEN (AND (EQL (VAR-KIND VAR) 'FEF-ARG-DELETED) (NO-SIDE-EFFECTS-P (SECOND PAIRS)) (EQ PAIRS (CDR FORM))) (DISCARD (SECOND PAIRS)) (RETURN-FROM SETQ-OPT `(SETQ . ,(CDDR PAIRS)))) (WHEN (AND (EQL (VAR-USE-COUNT VAR) 1) ; not used before this assignment (EQ (VAR-KIND VAR) 'FEF-ARG-INTERNAL-AUX) ;; Make sure we aren't in conditionally executed code. (>= (CDDR (FIRST PAIRS)) *LOOP-VAR-BIT*) (EQ (VAR-TYPE VAR) 'FEF-LOCAL) (NO-SIDE-EFFECTS-P (SETQ INIT-FORM (VAR-INIT-FORM VAR))) (OR SETQ-PROPAGATE-ENABLE ; new optimization enabled ;; or simple case of gensym variables generated by SETQ (AND (NULL (SYMBOL-PACKAGE (VAR-NAME VAR))) (EQUAL INIT-FORM '(UNDEFINED-VALUE))))) ;; What we have here is a local variable whose first reference is as the ;; destination of an unconditional SETQ. This means that the initial ;; value in the binding will never be used and can be discarded, and that ;; we know what the initial value should be for purposes of value ;; propagation and type testing. (UNLESS (NULL INIT-FORM) (DISCARD INIT-FORM)) (SETF (VAR-INIT VAR) (LIST 'FEF-INI-SETQ (SECOND PAIRS))) (SETF (VAR-USE-COUNT VAR) 0) (WHEN (EQ PAIRS (CDR FORM)) ;; Don't do this for other than the first assignment in the SETQ ;; because otherwise PROPAGATE-VALUES could mistakenly try to ;; substitute the destination. 1(UNLESS (MEMBER VAR (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*)* 1 :TEST #'EQ)* 1;; If the above condition were true, it means that a lexical closure was * 1;; created between the binding of the variable and the SETQ that * 1;; initializes it. In such a case, leave the altered bit on so that PASS2 * 1;; won't think that the value of the variable can be copied out when the * 1;; lexical environment is built. [SPR 10612 and 10658]* (SETF ALTERED-VAR-SET (LOGDIF ALTERED-VAR-SET (CDDR (FIRST PAIRS))))1)* (MAYBE-PROPAGATE VAR)) (comment ;; This is probably not needed; may not even be desirable. ;; Leave it out to be safe. -- DNG 4/28/89 (WHEN (AND (EQ PAIRS (CDR FORM)) ; first assignment (INVULNERABLE-EXPRESSION-P (SECOND PAIRS))) ; safe to move ;; (LET ((g (UNDEFINED-VALUE))) ... (SETQ g x) ...) ==> ;; (LET ((g x)) ... ...) (SETF (VAR-INIT-KIND VAR) 'FEF-INI-COMP-C) (IF (CDDR PAIRS) (PROGN (SETF (VAR-USE-COUNT VAR) 0) (RETURN-FROM SETQ-OPT `(SETQ . ,(CDDR PAIRS)))) (RETURN-FROM SETQ-OPT (FIRST PAIRS)) )))))))) FORM) ))