;; -*- Mode:Common-Lisp; Package:Compiler; Base:10 -*- ;;; 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 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved. ;;; Copyright (C) 1980, Massachusetts Institute of Technology ;;;; *-----------------------------------------------------------* ;;;; | -- TI Explorer Lisp Compiler -- | ;;;; | This file contains the top level of the compiler for | ;;;; | compiling each function. [Higher level routines for | ;;;; | compiling files and streams are in "COMPILER;FILE".] | ;;;; *-----------------------------------------------------------* ;;; 5/01/85 DNG - Last change for Explorer release 1.0. ;;; 6/26/85 DNG - Minor modifications to improve speed of compilation. ;;; 7/11/85 DNG - Allow re-using the stack space of lexical closures. ;;; 7/13/85 DNG - For release 3, this file separated out of QCP1. ;;; 11/16/85 DNG - Generate new debug-info structure for release 3. ;;; 12/19/85 DNG - Fix :INTERNAL-FEF-OFFSETS in rel 3 debug info. ;;; 4/05/86 DNG - Converted from Zetalisp to Common Lisp. ;;; 8/08/86 DNG - Major redesign. ;;; 9/30/86 DNG - Change CLI:NAMED-LAMBDA to NAMED-LAMBDA because it needs to ;;; be in the TICL package instead of LISP. ;;; 10/01/86 DNG - COMPILAND-BREAKOFF-COUNT replaced by COMPILAND-CHILDREN. ;;; 10/18/86 DNG - Allow functions with more than 64 local variables. ;;; 12/22/86 DNG - Updates to EXTEND-LOCAL-VARIABLES and BREAKOFF . ;;; 12/30/86 DNG - Fix UNCOMPILE. ;;; 2/16/87 DNG - Set COMPILAND-INITIAL-ENVIRONMENT-VARS in BREAKOFF. ;;; 2/18/87 DNG - Fix BUILD-DEBUG-INFO for the *SUPPRESS-DEBUG-INFO* option. ;;; 3/07/87 DNG - Clear QCMP-OUTPUT array to facilitate GC. ;;; 3/17/87 DNG - Fix BREAKOFF for ephemeral lexical closure criteria. ;;; 4/09/87 DNG - Fix QCOMPILE2 for SPR 4751. ;;;------------------ The following done after Explorer release 3.0 ------ ;;; 6/17/87 DNG - Fix BUILD-DEBUG-INFO for SPR 5237. ;;; 6/23/87 DNG - Fix COMPILE-1 for SPR 5575. ;;; 6/29/87 DNG - Fix EXTEND-LOCAL-VARIABLES for SPR 5719. ;;; 7/22/87 DNG - Eliminate use of *LAST-ADDRESS-READ* from QC-TRANSLATE-FUNCTION. ;;; 7/30/87 DNG - Update binding of MACRO-CONS-AREA in QC-TRANSLATE-FUNCTION . ;;; 7/31/87 DNG - Fix BREAKOFF for SPR 6128. ;;;------------------ The following done after Explorer release 3.1 ------ ;;; 9/23/87 DNG - Fix BREAKOFF for SPR 6548. ;;;------------------ The following done after Explorer release 3.2 ------ ;;; 2/10/88 DNG - Modify QCOMPILE1 as part of fix for SPR 7113 and 7205. ;;; Delete some obsolete source code not used in release 3. ;;;------------------ The following done for Explorer release 5.0 ------ ;;; 8/19/88 clm - Modified QC-TRANSLATE-FUNCTION and BUILD-DEBUG-INFO to ;;; use the new data structure FILE-LOCAL-DECLARATIONS-DEF-ALIST. ;;; 8/22/88 DNG - Fix PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED for SPR 6850. ;;; 9/19/88 DNG - Fix BREAKOFF for SPR 8756 ;;;------------------ The following done for Explorer release 6.0 ------ ;;; 3/16/89 DNG - Include support for CLOS. ;;; 4/03/89 DNG - Fix PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED for SPR 9112. ;;; 4/04/89 DNG - Update COMPILE for SPR 9578. ;;; 4/05/89 DNG - Eliminated obsolete code for not (COMPILING-FOR-V2). ;Initialize all global variables and compiler switches, and make sure ;that some built in variables are known to be special ;(logically, the cold load would contain SPECIAL properties for them, ;but this function is how they actually get put on). ;; 08/15/84 DNG - change value of SPECIAL property from T to the ;; name of this function for documentation purposes. ;; 09/12/84 DNG - re-do properties if currently T so that P1 can distinguish ;; machine-dependent constants from DEFCONSTANT constants. ;; This is a temporary measure until the general problem ;; of cross-compilation is resolved. ;; 02/08/85 DNG - Removed initialization of SPECIAL and SYSTEM-CONSTANT ;; properties for system variables -- this is now done ;; by function INIT-SYSTEM-VAR-PROPERTIES in file QCDEFS. ;; 09/23/85 DNG - Commented out initialization of some undefined variables. ;; 05/28/86 DNG - Remove obsolete variable FUNCTION-BEING-PROCESSED. (DEFUN QC-PROCESS-INITIALIZE NIL (SETQ HOLDPROG T) (COMMENT "These don't seem to be used anymore" (SETQ MC-HOLDPROG T) (SETQ ULAP-DEBUG NIL) (SETQ LAP-DEBUG NIL) (SETQ MS-HOLDPROG T) (SETQ MSLAP-DEBUG NIL) ) (SETQ OPEN-CODE-MAP-SWITCH T) (SETQ ALLOW-VARIABLES-IN-FUNCTION-POSITION-SWITCH NIL) (SETQ ALL-SPECIAL-SWITCH NIL) (SETQ OBSOLETE-FUNCTION-WARNING-SWITCH T) (SETQ RUN-IN-MACLISP-SWITCH NIL) (SETQ INHIBIT-STYLE-WARNINGS-SWITCH NIL) ) ;; Compile a function which already has an interpreted definition, ;; or define it to a newly supplied definition's compilation. ;; If the definition is one which is legal but cannot meaningfully ;; be compiled, we just leave it unchanged. (DEFUN COMPILE (NAME &OPTIONAL LAMBDA-EXP #+compiler:debug target #+compiler:debug (mode 'compile-to-core)) "Compile the definition of NAME, or its previous interpreted definition if it is already compiled. If LAMBDA-EXP is supplied, it is compiled and made the definition of NAME. If NAME is NIL, LAMBDA-EXP is compiled and the result is just returned." ;; 07/09/85 DNG - When passing a NAMED-LAMBDA to COMPILE-LAMBDA, ;; use the name of the NAMED-LAMBDA as the FEF name. ;; 11/02/85 DNG - Simplify by using FDEFINITION-SAFE and INTERPRETED-DEF. ;; 3/31/86 DNG - Bind TARGET-PROCESSOR for PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED. ;; 7/26/88 JHO - Added FILE-LOCAL-DECLARATIONS-DEF-ALIST to LET ;; 3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore. ;; 4/04/89 DNG - Accept a method object as the argument. [SPR 9578] (DECLARE (VALUES NAME ERROR-STATUS)) (IF (NULL NAME) (COMPILE-LAMBDA LAMBDA-EXP (MULTIPLE-VALUE-BIND ( LAMBDA-NAME NAMEDP ) (FUNCTION-NAME LAMBDA-EXP) (IF NAMEDP LAMBDA-NAME (GENSYM)) ) ) (LET (( *RETURN-STATUS* OK )) (LOCKING-RESOURCES-NO-QFASL (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE) ;; need to bind TARGET-PROCESSOR here for PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED. (let-unless-constant ( #+compiler:debug ( target-processor (validate-target target) )) #+compiler:debug target (COMPILER-WARNINGS-CONTEXT-BIND (LET (TEM FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST FILE-LOCAL-DECLARATIONS) (DECLARE (NOTINLINE TICLOS:METHOD-FUNCTION)) (QC-PROCESS-INITIALIZE) (COND (LAMBDA-EXP) ((AND (SETQ TEM (SI:FDEFINITION-SAFE NAME T)) (SETQ TEM (INTERPRETED-DEF TEM))) (SETQ LAMBDA-EXP TEM) ) ((AND (TYPEP-STRUCTURE-OR-FLAVOR NAME 'TICLOS:METHOD) (CONSP (SETQ TEM (TICLOS:METHOD-FUNCTION NAME))) (EQ TEM (FDEFINITION-SAFE (FUNCTION-NAME TEM) T))) ;; This in case someone types (DEFMETHOD ...) followed by (COMPILE *). (SETQ LAMBDA-EXP TEM) (SETQ NAME (FUNCTION-NAME LAMBDA-EXP))) (T (FERROR NIL "Can't find LAMBDA expression for ~S" NAME))) (LET ((INHIBIT-FDEFINE-WARNINGS T)) #-compiler:debug (COMPILE-1 NAME LAMBDA-EXP) #+compiler:debug (COMPILE-1 NAME LAMBDA-EXP 'MACRO-COMPILE NAME target-processor mode) )))))) (VALUES NAME *RETURN-STATUS*)))) (DEFUN COMPILE-1 (NAME LAMBDA-EXP &OPTIONAL (PROCESSING-MODE 'MACRO-COMPILE) (NAME-FOR-FUNCTION NAME) #+compiler:debug (TARGET HOST-PROCESSOR) #-compiler:debug &AUX (LAP-MODE 'COMPILE-TO-CORE)) "Compile LAMBDA-EXP and define NAME, while already inside the compiler environment. NAME-FOR-FUNCTION is recorded as the name of the compiled function (the default is NAME). PROCESSING-MODE is how to compiler: COMPILER:MACRO-COMPILE or COMPILER:MICRO-COMPILE." ;; 6/23/87 DNG - Bind QC-FILE-IN-PROGRESS to NIL. [SPR 5575] ;; 10/25/88 DNG - Add binding for *LOCAL-ENVIRONMENT*. ;; 10/31/88 DNG - Add binding for *COMPILE-FILE-ENVIRONMENT*. ;; 4/13/89 DNG - Bind FILE-IN-COLD-LOAD to NIL to avoid spurious warnings ;; while compiling combined methods during compiling or loading. (DECLARE (UNSPECIAL LAP-MODE)) (SETQ LAMBDA-EXP (LAMBDA-MACRO-EXPAND LAMBDA-EXP)) (COND ((ATOM LAMBDA-EXP) (FDEFINE NAME LAMBDA-EXP T)) ((OR (MEMBER (CAR LAMBDA-EXP) '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA GLOBAL:SUBST GLOBAL:NAMED-SUBST CLI:LAMBDA NAMED-LAMBDA CLI:SUBST NAMED-SUBST) :TEST #'EQ) (AND (EQ (CAR LAMBDA-EXP) 'MACRO) (CONSP (CDR LAMBDA-EXP)) (MEMBER (CADR LAMBDA-EXP) '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA CLI:LAMBDA NAMED-LAMBDA) :TEST #'EQ))) (LET-UNLESS-CONSTANT (( TARGET-PROCESSOR HOST-PROCESSOR ) #+compiler:debug ( HOLDPROG T ) ( QC-FILE-IN-PROGRESS NIL ) ( FILE-IN-COLD-LOAD NIL ) ( FILE-CONSTANTS-LIST NIL ) ( *COMPILE-FILE-ENVIRONMENT* NIL ) ( *LOCAL-ENVIRONMENT* NIL )) #+compiler:debug target #+compiler:debug (when-supporting-cross-compilation (unless (eq target host-processor) (setq target-processor target) (when (eq lap-mode 'compile-to-core) (setq holdprog nil)))) (record-individual-time 'qc-translate-function (QC-TRANSLATE-FUNCTION NAME LAMBDA-EXP PROCESSING-MODE LAP-MODE NAME-FOR-FUNCTION) ) )) (T (FDEFINE NAME LAMBDA-EXP T)))) ;; 07/26/88 JHO - Added FILE-LOCAL-DECLARATIONS-DEF-ALIST to LET (DEFUN COMPILE-LAMBDA (LAMBDA-EXP &OPTIONAL NAME (PROCESSING-MODE 'MACRO-COMPILE)) "Compile the function LAMBDA-EXP and return a compiled-function object. That compiled function will record NAME as its name, but we do not actually define NAME." ;; 11/17/86 DNG - Suppress "while compiling end of data" message. ;; 3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore. (DECLARE (ARGLIST LAMBDA-EXP &OPTIONAL NAME)) (DECLARE (VALUES COMPILED-FUNCTION ERROR-STATUS)) (LET ( TEM (*RETURN-STATUS* OK) ) (LOCKING-RESOURCES-NO-QFASL (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE) (COMPILER-WARNINGS-CONTEXT-BIND (LET (FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST FILE-LOCAL-DECLARATIONS (INHIBIT-FDEFINE-WARNINGS T)) (QC-PROCESS-INITIALIZE) (COMPILE-1 `(:LOCATION ,(LOCF TEM)) LAMBDA-EXP PROCESSING-MODE NAME) ) ;; "end of data" messages are not meaningful here, so suppress them. (SETQ SI:PREMATURE-WARNINGS NIL)))) (VALUES TEM *RETURN-STATUS*))) ;; Restore the saved old interpreted definition of a function on which ;; COMPILE was used. (DEFUN UNCOMPILE (FUNCTION-SPEC &OPTIONAL DONT-UNENCAPSULATE) "Replaces compiled definition of FUNCTION-SPEC with interpreted definition. If the interpreted function which was compiled is known, installs that as the definition in place of the compiled one." ;; 11/02/85 DNG - Use function INTERPRETED-DEF instead of looking at ;; debug-info directly. ;; 12/30/86 DNG - Rewritten using COMPILEDP instead of INTERPRETED-DEF in ;; order to avoid calling FDEFINE when the function was not ;; compiled to begin with. [SPR 2905] (LET ((COMPILED (COMPILEDP FUNCTION-SPEC DONT-UNENCAPSULATE))) (COND ((CONSP COMPILED) (FDEFINE FUNCTION-SPEC COMPILED (NOT DONT-UNENCAPSULATE) T)) ((NULL COMPILED) "Not compiled") (T "No interpreted definition recorded")))) (EVAL-WHEN ( EVAL LISP:COMPILE LOAD ) (COMPILATION-DEFINE 'MICRO-COMPILE)) ; suppress "undefined function" warning on call below (DEFUN QC-TRANSLATE-FUNCTION (FUNCTION-SPEC EXP QC-TF-PROCESSING-MODE QC-TF-OUTPUT-MODE &OPTIONAL (NAME-FOR-FUNCTION FUNCTION-SPEC) PASS-1-ONLY) "Compile one function. All styles of the compiler come through here. QC-TF-PROCESSING-MODE should be MACRO-COMPILE or MICRO-COMPILE. QC-TF-OUTPUT-MODE is used by LAP to determine where to put the compiled code. It is COMPILE-TO-CORE for making an actual FEF; QFASL, REL, or QFASL-NO-FDEFINE to simply dump a FEF without trying to define a function. EXP is the lambda-expression. NAME-FOR-FUNCTION is what the fef's name field should say; if omitted, FUNCTION-SPEC is used for that too. In MACRO-COMPILE mode, the return value is the value of QLAPP for the first function." ;; 7/15/85 - Don't call PEEP when HOLDPROG is NIL. ;; 2/01/86 - Moved binding of some special variables from QCOMPILE0 to around its call. ;; 3/13/86 - Bind *BARF-DEFAULTS* to NIL. ;; 4/25/86 - Set *LAST-ADDRESS-READ* if not already set by COMPILE-STREAM. ;; 5/06/86 - Fix to allow EXP in DEBUG-INFO-AREA. ;; 5/24/86 DNG - Split out CHECK-FOR-UNUSED-VARIABLES as a separate function. ;; 5/28/86 DNG - Use a lexical closure instead of a dynamic closure for ERROR-MESSAGE-HOOK. ;; 6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS. ;; 7/10/86 DNG - Revised to use COMPILAND structure instead of COMPILER-QUEUE-ENTRY. ;; 7/30/86 DNG - New argument PASS-1-ONLY. ;; 9/24/86 DNG - Modify "give up" handling to skip the rest of the queue. ;; 9/25/86 DNG - Removed the second call to OBJECT-OPERATION-WITH-WARNINGS because it was ;; masking warnings recorded by the call in BREAKOFF. ;; 11/14/86 DNG - Watch out for write-protected area SOURCE-CODE-AREA. ;; 2/07/87 DNG - Use new function WRITE-PROTECTED-AREA-P . ;; 3/07/87 DNG - Clear QCMP-OUTPUT array to facilitate GC. ;; 7/22/87 DNG - Eliminate use of *LAST-ADDRESS-READ*. ;; 7/30/87 DNG - For in-memory compile, bind MACRO-CONS-AREA to QCOMPILE-TEMPORARY-AREA ;; instead of BACKGROUND-CONS-AREA. ;; 7/26/88 JHO - Added FILE-LOCAL-DECLARATIONS-DEF-ALIST to LET ;; 8/16/88 clm - Use only FILE-LOCAL-DECLARATIONS-DEF-ALIST to keep track of DEFinitions ;; (no longer keep same info in FILE-LOCAL-DECLARATIONS). ;; 10/25/88 DNG - Remove binding of *LOCAL-ENVIRONMENT*. ;; 3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore. ;; 4/06/89 DNG - Add binding of *LOCAL-ENVIRONMENT*. ;; 4/26/89 DNG - Add binding of *LOOP-VAR-BIT*. (OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION) (LET* ((DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA) (ERROR-MESSAGE-HOOK ;; Note: this function cannot reference special variables because ;; it will be executed by the error handler in a different stack group. ;; Construct a lexical closure over the function name. (AND NAME-FOR-FUNCTION #'(LAMBDA () (FORMAT T "Error occurred while compiling ~S" NAME-FOR-FUNCTION)))) COMPILER-QUEUE (WARN-CATCHER NIL) (COMPILING-COMMON-LISP (COMMON-LISP-ON-P)) (VAL NIL) (THIS-FUNCTION-BARF-SPECIAL-LIST NIL) (GIVE-UP-NAME NAME-FOR-FUNCTION) ( *BARF-DEFAULTS* NIL )) (IF (ARRAYP EXP) (SETQ COMPILER-QUEUE (CONS EXP NIL)) (PROGN (SETQ COMPILER-QUEUE (CONS (MAKE-COMPILAND :FUNCTION-SPEC FUNCTION-SPEC :FUNCTION-NAME NAME-FOR-FUNCTION :DEFINITION EXP :DECLARATIONS LOCAL-DECLARATIONS) NIL)) )) (LOOP ; for each FEF to be generated (WHEN (NULL COMPILER-QUEUE) (RETURN)) (LET* ((CURRENT (FIRST COMPILER-QUEUE)) (*CURRENT-COMPILAND* CURRENT) (OPTIMIZE-SWITCH (COMPILAND-OPTIMIZE CURRENT)) ) (SETQ NAME-FOR-FUNCTION (COMPILAND-FUNCTION-NAME CURRENT)) (UNLESS (EQ (CAR-SAFE NAME-FOR-FUNCTION) ':INTERNAL) (SETQ GIVE-UP-NAME NAME-FOR-FUNCTION)) (progn ;OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION) (MULTIPLE-VALUE-BIND ( NIL ERROR-CAUGHT ) (CATCH-ERROR-RESTART (ERROR "Give up on compiling ~S" GIVE-UP-NAME) ;; ;; Pass 1 ;; (WHEN (OR (COMPILAND-EXP2 CURRENT) ; pass 1 already done (LET (( VARS NIL ) ( VAR-BIT (ASH (MAX SPECIAL-VAR-BIT DATA-ALTERATION-BIT) 1) ) ( *LOOP-VAR-BIT* 0 ) ( ALTERED-VAR-SET 0 ) ( USED-VAR-SET 0 ) ( PROPAGATE-VAR-SET 0 ) ( SUBST-VAR-SET 0 ) ( LOCAL-FUNCTIONS NIL ) ( PROGDESCS NIL ) ( RETPROGDESC NIL ) ( GOTAGS NIL ) ( 1-IF-LIVE-CODE 1 ) ( FILE-LOCAL-DECLARATIONS FILE-LOCAL-DECLARATIONS ) ( MACRO-CONS-AREA (IF (AND (EQ QC-TF-OUTPUT-MODE 'COMPILE-TO-CORE) (SI:AREA-TEMPORARY-P DEFAULT-CONS-AREA)) BACKGROUND-CONS-AREA DEFAULT-CONS-AREA) ) ; for PRE-OPTIMIZE ( *LOCAL-ENVIRONMENT* ;; Bind this so that the SETF of FILE-LOCAL-DEF below will be temporary. (LIST* (ENV-VARS *LOCAL-ENVIRONMENT*) (CONS NIL (ENV-FUNCTIONS *LOCAL-ENVIRONMENT*)) (CDDR *LOCAL-ENVIRONMENT*))) ) (UNLESS (LISTP (COMPILAND-FUNCTION-SPEC CURRENT)) ; non-NIL symbol (LET ((*COMPILE-FILE-ENVIRONMENT* *LOCAL-ENVIRONMENT*)) (setf (file-local-def (COMPILAND-FUNCTION-SPEC CURRENT)) (COMPILAND-DEFINITION CURRENT))) ) (LET ((RESULT (QCOMPILE1 CURRENT))) ; do pass 1 on top-level function (SETF (COMPILAND-USED-VAR-SET CURRENT) USED-VAR-SET) (SETF (COMPILAND-ALTERED-VAR-SET CURRENT) ALTERED-VAR-SET) (IF PASS-1-ONLY ; return partially compiled result (PROGN (SETQ VAL CURRENT) (SETQ PASS-1-ONLY NIL) ; only applies to first queue entry NIL) ; don't do pass 2 yet RESULT) ))) ;; pass 1 succeded; continue. ;; ;; Pass 2 ;; (QCOMPILE2 CURRENT) ; pass 2 on sub-function (WHEN HOLDPROG ;; ;; Peephole optimizer ;; (WHEN (AND PEEP-ENABLE (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)) (NEQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE)) (record-individual-time 'peep (PEEP QCMP-OUTPUT (COMPILAND-FUNCTION-SPEC CURRENT)))) ;; ;; QLAPP ;; (COND ((EQ QC-TF-PROCESSING-MODE 'MACRO-COMPILE) (LET* ((LAP-CODE (G-L-P QCMP-OUTPUT)) (LAP-RESULT (record-individual-time 'qlapp (IF (EQ QC-TF-OUTPUT-MODE 'BOTH) (PROGN (QLAPP LAP-CODE 'QFASL) (QLAPP LAP-CODE 'COMPILE-TO-CORE)) (QLAPP LAP-CODE QC-TF-OUTPUT-MODE))))) (UNLESS VAL (SETQ VAL LAP-RESULT)))) ((EQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (MICRO-COMPILE (G-L-P QCMP-OUTPUT) QC-TF-OUTPUT-MODE))) #+compiler:debug (T (BARF QC-TF-PROCESSING-MODE "invalid compile mode" 'BARF)) ) ) ; end HOLDPROG (UNLESS (SI:AREA-TEMPORARY-P DEFAULT-CONS-AREA) ;; When TGC is in use, clear out the active portion of this ;; array as soon as we are finished with it so that the ;; contents can be garbage-collected. (ARRAY-INITIALIZE QCMP-OUTPUT NIL) (SETF (FILL-POINTER QCMP-OUTPUT) 0)) NIL)) (WHEN ERROR-CAUGHT (WHEN (< *RETURN-STATUS* FATAL) (SETQ *RETURN-STATUS* FATAL)) ;; If compilation of a function is aborted, then can't meaningfully ;; continue compiling its children, so return out of the loop. (RETURN) ) ))) (POP COMPILER-QUEUE)) ; end of LOOP VAL))) (DEFUN COMPILE-NOW-OR-LATER (NAME LAMBDA-EXP) "Compile LAMBDA-EXP and define NAME, either now or on exit from the compiler. If not within the compiler, it is done now. Otherwise, it is done as soon as it is safe." ;; The only currently known use of this is in the SETF file. ;; 6/26/86 DNG - Revised to use COMPILAND structure instead of COMPILER-QUEUE-ENTRY. ;; 8/09/86 DNG - Test COMPILER-QUEUE instead of INSIDE-QC-TRANSLATE-FUNCTION. (IF COMPILER-QUEUE (PUSH-END (MAKE-COMPILAND :FUNCTION-SPEC NAME :FUNCTION-NAME NAME :DEFINITION LAMBDA-EXP) COMPILER-QUEUE) (COMPILE NAME LAMBDA-EXP))) ;We expect that DEFAULT-CONS-AREA has been bound to QCOMPILE-TEMPORARY-AREA. ;The compiler does ALL consing in that temporary area unless it specifies otherwise. (DEFUN QCOMPILE1 (COMPILAND) ;; 7/09/86 DNG - Function QCOMPILE0 split into QCOMPILE1 and QCOMPILE2 and ;; re-designed around COMPILAND structure. ;; 7/29/86 DNG - Given (LAMBDA (...) (BLOCK ...)) use as the FEF name. ;; 8/20/86 DNG - Fix setting of COMPILING-COMMON-LISP. ;; 8/27/86 DNG - Re-set TOP-LEVEL-DECLARATIONS after P1AUX. ;; 9/02/86 DNG - Change for NAMED-LAMBDA debug info to be a plist instead of alist. ;; 9/16/86 DNG - Deleted use of CHECK-FOR-UNUSED-VARIABLES [now handled by VARIABLE-WRAPUP]. ;;10/18/86 DNG - Permit tail recursion elimination of local functions. ;;11/18/86 DNG - Use EXTRACT-DECLARATIONS-RECORD-MACROS instead of EXTRACT-DECLARATIONS. ;; 2/10/88 DNG - Add inherited VARS to the P1VALUE list for use by ;; TAIL-RECURSION-ELIMINATION. ;; 4/10/89 DNG - Deleted binding of SELF-FLAVOR-MAPPED-VARIABLES . (DECLARE (OPTIMIZE (SPACE 2) (SPEED 1))) (LET ((EXP1 (COMPILAND-DEFINITION COMPILAND)) BODY (FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC COMPILAND)) (NAME-TO-GIVE-FUNCTION (COMPILAND-FUNCTION-NAME COMPILAND)) ALLGOTAGS (ALLVARS NIL) (FREEVARS NIL) ;;(DEAD-CODE-SKIPPED NIL) LL ; lambda list AGAIN-TAG ; tag for Tail Recursion Elimination to loop back to TRE-ARGS ; argument list for Tail Recursion Elimination (without &AUX vars). DOCUMENTATION EXPR-DEBUG-INFO ( MAX-LEXICAL-CLOSURE-COUNT 0 ) ;; List of all macros found in this function, for the debugging info. (MACROS-EXPANDED NIL) (SELF-FLAVOR-DECLARATION (COMPILAND-FLAVOR COMPILAND)) ;; Set to T during pass 1 if any SELF-REFs are present in the function. (SELF-REFERENCES-PRESENT NIL) (EXPRESSION-SIZE 0) INHIBIT-SPECIAL-WARNINGS TOP-LEVEL-DECLARATIONS (LOCAL-DECLARATIONS LOCAL-DECLARATIONS) (INLINE-DECLARATIONS INLINE-DECLARATIONS) (COMPILING-COMMON-LISP COMPILING-COMMON-LISP) ) (DECLARE (UNSPECIAL NAME-TO-GIVE-FUNCTION FUNCTION-TO-BE-DEFINED)) (WHEN (AND (CONSP FUNCTION-TO-BE-DEFINED) (EQ (FIRST FUNCTION-TO-BE-DEFINED) ':PROPERTY) (EQ (THIRD FUNCTION-TO-BE-DEFINED) ':NAMED-STRUCTURE-INVOKE)) (WARN 'OBSOLETE-PROPERTY ':IMPLAUSIBLE "NAMED-STRUCTURE-INVOKE, the property name, should not have a colon.")) ;; If compiling a macro, compile its expansion function ;; and direct lap to construct a macro later. (WHEN (EQ (CAR EXP1) 'MACRO) (SETF (COMPILAND-MACRO-FLAG COMPILAND) T) (SETQ EXP1 (CDR EXP1))) (UNLESS (MEMBER (CAR EXP1) '(GLOBAL:LAMBDA GLOBAL:SUBST CLI:LAMBDA CLI:SUBST NAMED-SUBST GLOBAL:NAMED-LAMBDA GLOBAL:NAMED-SUBST NAMED-LAMBDA) :TEST #'EQ) (WARN 'FUNCTION-NOT-VALID ':FATAL "The definition is not a function at all.") (RETURN-FROM QCOMPILE1 NIL)) (WHEN (MEMBER (CAR EXP1) '(GLOBAL:SUBST GLOBAL:NAMED-SUBST CLI:SUBST NAMED-SUBST) :TEST #'EQ) (SETF (COMPILAND-SUBST-FLAG COMPILAND) T INHIBIT-SPECIAL-WARNINGS T)) (WHEN (NULL (COMPILAND-PARENT COMPILAND)) ;; Process any raw declarations that were placed on the LOCAL-DECLARATIONS ;; list before the compiler was invoked. (MULTIPLE-VALUE-SETQ ( LOCAL-DECLARATIONS EXPR-DEBUG-INFO ) (PROCESS-PERVASIVE-DECLARATIONS LOCAL-DECLARATIONS NIL NIL T))) ;; If a NAMED-LAMBDA, discard the name and save debug-info in special place. (WHEN (MEMBER (CAR EXP1) '(GLOBAL:NAMED-LAMBDA NAMED-LAMBDA GLOBAL:NAMED-SUBST NAMED-SUBST) :TEST #'EQ) (SETQ COMPILING-COMMON-LISP (NOT (EQ (SYMBOL-PACKAGE (CAR EXP1)) ZETALISP-PACKAGE))) (WHEN (NULL NAME-TO-GIVE-FUNCTION) (SETF NAME-TO-GIVE-FUNCTION (FUNCTION-NAME EXP1)) (SETF (COMPILAND-FUNCTION-NAME COMPILAND) NAME-TO-GIVE-FUNCTION)) (UNLESS (ATOM (SECOND EXP1)) (DO ((PLIST (SECOND (SECOND EXP1)) (CDDR PLIST))) ((NULL PLIST)) (PUSH (CONS (FIRST PLIST) (SECOND PLIST)) EXPR-DEBUG-INFO))) (SETQ EXP1 (CDR EXP1)) ) ;;; ;;; Process the argument list and declarations ;;; (SETQ LL (CADR EXP1)) ;lambda list. (SETQ BODY (CDDR EXP1)) ;; Extract documentation string and declarations from the front of the body. (MULTIPLE-VALUE-SETQ (BODY TOP-LEVEL-DECLARATIONS DOCUMENTATION) (EXTRACT-DECLARATIONS-RECORD-MACROS BODY NIL T)) (SETF (COMPILAND-DOCUMENTATION COMPILAND) DOCUMENTATION) ;; unnamed LAMBDA can assume the name of a BLOCK that surrounds the body. (WHEN (AND (NULL NAME-TO-GIVE-FUNCTION) (CONSP (FIRST BODY)) (NULL (REST BODY)) (EQ (FIRST (FIRST BODY)) 'BLOCK)) (LET (( NAME (SECOND (FIRST BODY)) )) (WHEN (AND (SYMBOLP NAME) (NOT (MEMBER NAME '(NIL T)))) (SETF NAME-TO-GIVE-FUNCTION NAME) (SETF (COMPILAND-FUNCTION-NAME COMPILAND) NAME) ))) ;; Now that we are finally sure what the name of the function is... (WHEN (AND COMPILER-VERBOSE (OR FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION) (NOT (EQ (CAR-SAFE NAME-TO-GIVE-FUNCTION) ':INTERNAL))) (FORMAT T "~&Compiling ~S" NAME-TO-GIVE-FUNCTION)) ;; Separate debug-info from other declarations. (MULTIPLE-VALUE-SETQ ( LOCAL-DECLARATIONS EXPR-DEBUG-INFO ) (PROCESS-PERVASIVE-DECLARATIONS TOP-LEVEL-DECLARATIONS LOCAL-DECLARATIONS EXPR-DEBUG-INFO)) (SETF (COMPILAND-OPTIMIZE COMPILAND) OPTIMIZE-SWITCH) ; save for subsequent passes ;; Put arglist together with body again. (LET ((LAMEXP `(LAMBDA ,LL (DECLARE . ,TOP-LEVEL-DECLARATIONS) . ,BODY))) (WHEN (AND TRE-ENABLE (OR (NOT (LISTP FUNCTION-TO-BE-DEFINED)) LOCAL-FUNCTIONS)) ; might be a recursive LABELS function (SETQ AGAIN-TAG (GENSYM)) ) ;; Now turn any &AUX variables in the LAMBDA into a LET* in the body. (SETQ LAMEXP (P1AUX LAMEXP AGAIN-TAG)) (SETQ TRE-ARGS (SECOND LAMEXP)) (SETF (COMPILAND-ARGLIST COMPILAND) TRE-ARGS) ;; If there are keyword arguments, expand them. (WHEN (AND (CONSP LL) (MEMBER '&KEY LL :TEST #'EQ) ) (SETQ LAMEXP (EXPAND-KEYED-LAMBDA LAMEXP)) ;; handle new &AUX variables created by EXPAND-KEYED-LAMBDA (SETQ LAMEXP (P1AUX LAMEXP NIL)) ) ;; Separate lambda list and body again. (SETQ LL (CADR LAMEXP) BODY (CDDR LAMEXP))) (IF (AND (CONSP (CAR BODY)) (EQ (CAAR BODY) 'DECLARE)) (SETQ TOP-LEVEL-DECLARATIONS (CDAR BODY) BODY (CDR BODY)) (SETQ TOP-LEVEL-DECLARATIONS NIL)) (SETF (COMPILAND-INHERITED-VARS COMPILAND) VARS) ; after PROCESS-PERVASIVE-DECLARATIONS but before P1SBIND. (SETF (COMPILAND-DEBUG-INFO COMPILAND) EXPR-DEBUG-INFO) ;;; ;;; Pass 1 ;;; (record-individual-time 'p1 (MULTIPLE-VALUE-BIND ( LL2 EXP2 ) (PASS1 LL BODY (LIST (LIST FUNCTION-TO-BE-DEFINED AGAIN-TAG TRE-ARGS NIL VARS)) TOP-LEVEL-DECLARATIONS) (SETF (COMPILAND-EXP2 COMPILAND) EXP2 (COMPILAND-LL2 COMPILAND) LL2 (COMPILAND-ARG-VARS COMPILAND) VARS) )) (SETF (COMPILAND-EXPRESSION-SIZE COMPILAND) EXPRESSION-SIZE) (SETF (COMPILAND-FLAVOR COMPILAND) SELF-FLAVOR-DECLARATION) (SETF (COMPILAND-MACROS-EXPANDED COMPILAND) MACROS-EXPANDED) (UNLESS (NULL (COMPILAND-CHILDREN COMPILAND)) (SETF (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND) (LOOP FOR HOME IN ALLVARS WHEN (AND (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC HOME)) (NOT (EQ (VAR-KIND HOME) 'FEF-ARG-DELETED))) COLLECT (VAR-LAP-ADDRESS HOME)))) (WHEN (OR SELF-REFERENCES-PRESENT (AND SELF-FLAVOR-DECLARATION (MEMBER 'SELF-MAPPING-TABLE FREEVARS))) (SETF (COMPILAND-SELF-MAP-NEEDED COMPILAND) T)) (SETF (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND) MAX-LEXICAL-CLOSURE-COUNT) (SETF (COMPILAND-ALLVARS COMPILAND) ALLVARS) (SETF (COMPILAND-FREEVARS COMPILAND) FREEVARS) ) COMPILAND) ;Compile an internal lambda into a separate function, returning the form for addressing it. (DEFUN BREAKOFF (LAMBDA-EXPRESSION EPHEMERAL) ;; 07/09/85 DNG - Modify choice of FNAME-TO-GIVE. ;; 07/12/85 DNG - Update LOCAL-FUNCTION-MAP. ;; 12/11/85 DNG - Use function name instead of offset number in ;; :INTERNAL function specs. ;; 12/23/85 DNG - Increment use count for variables holding local functions. ;; 2/01/86 DNG - New queue slot VISIBLE-VARS. [for SPR 958 and 1073] ;; 2/21/86 DNG - Add support for MAKE-EPHEMERAL-LEXICAL-CLOSURE; ;; no longer disable Tail Recursion Elimination. ;; 4/28/86 DNG - Cold load warning no longer needed for VM2. ;; 5/01/86 DNG - Make sure PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG does not ;; point to a function spec in the temporary area since it is used ;; as a CATCH tag and hence becomes a constant in the FEF. ;; 6/09/86 DNG - Cons the name in background-cons-area when compiling in memory. ;; 6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS. ;; 7/12/86 DNG - Major re-design to use recursive invocation of pass 1 ;; instead of CW-TOP-LEVEL-LAMBDA-EXPRESSION. ;; 8/12/86 DNG - Reset ephemeral flag for closures used by a non-ephemeral closure. ;; 9/25/86 DNG - Added call to OBJECT-OPERATION-WITH-WARNINGS . ;; 10/18/86 DNG - Adjustments for use by EXTEND-LOCAL-VARIABLES . ;; 11/24/86 DNG - Add warning for a DEFSUBST that is a lexical closure; fix ;; handling of a macro expander that is a lexical closure. ;; 12/22/86 DNG - More adjustments for use by EXTEND-LOCAL-VARIABLES . ;; 2/16/87 DNG - Set COMPILAND-INITIAL-ENVIRONMENT-VARS . ;; 3/17/87 DNG - Fix so lexical closure is not ephemeral if it has any ;; children that are non-ephemeral lexical closures. ;; 7/31/87 DNG - Fix to preserve non-symbol function name. [SPR 6128] ;; 9/23/87 DNG - Use new function NOT-EPHEMERAL. ;; 11/11/87 DNG - Add FEF-ARG-ALTERED-IN-LEXICAL-CLOSURES flag to VAR-MISC to fix SPR 6881. ;; 9/19/88 DNG - Add binding of *OVERLAP-CANDIDATES* to fix SPR 8756. ;; 11/11/88 DNG - Fix for a NAMED-LAMBDA with a name of NIL. ;; 11/15/88 DNG - Don't push a non-symbol name on COMPILAND-LOCAL-FUNCTION-MAP. ;; 11/17/88 DNG - Don't use lambda name that is a gensym. ;; 4/27/89 DNG - Add binding of *LOOP-VAR-BIT*. ;; 4/29/89 DNG - Move the binding of *LOOP-VAR-BIT* to include the call to UPDATE-PROPAGATE-VAR-SET. (WHEN INLINE-EXPANSIONS ; kick back to function PROCEDURE-INTEGRATION (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'BREAKOFF) ) (LET* ((LEXICAL NIL) FNAME FNAME-TO-GIVE CHILD (PARENT *CURRENT-COMPILAND*) (FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC PARENT)) (NAME-TO-GIVE-FUNCTION (COMPILAND-FUNCTION-NAME PARENT))) (DECLARE (UNSPECIAL FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION)) (MULTIPLE-VALUE-BIND ( LAMBDA-NAME NAMEDP ) (FUNCTION-NAME LAMBDA-EXPRESSION) (LET ((LAMBDA-ID (IF (AND NAMEDP (SYMBOLP LAMBDA-NAME) (NOT (NULL LAMBDA-NAME)) (NOT (NULL (SYMBOL-PACKAGE LAMBDA-NAME))) (NOT (MEMBER LAMBDA-NAME (COMPILAND-LOCAL-FUNCTION-MAP PARENT) :TEST #'EQ))) ;; When the function has a unique name, use it. LAMBDA-NAME ;; Else, identify it with a number. (LENGTH (COMPILAND-CHILDREN PARENT))) ) ( DEFAULT-CONS-AREA (IF (AND QC-FILE-IN-PROGRESS (NOT QC-FILE-LOAD-FLAG)) DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) )) (SETQ FNAME-TO-GIVE `(:INTERNAL ,NAME-TO-GIVE-FUNCTION ,LAMBDA-ID) FNAME (IF (EQUAL FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION) FNAME-TO-GIVE `(:INTERNAL ,FUNCTION-TO-BE-DEFINED ,LAMBDA-ID))) (WHEN (AND (EQ FUNCTION-TO-BE-DEFINED NIL) NAMEDP (OR (EQ LAMBDA-ID LAMBDA-NAME) (NOT (SYMBOLP LAMBDA-NAME)))) (SETQ FNAME-TO-GIVE LAMBDA-NAME) )) (SETF CHILD (MAKE-COMPILAND :FUNCTION-SPEC FNAME :FUNCTION-NAME FNAME-TO-GIVE :DEFINITION LAMBDA-EXPRESSION :PARENT PARENT :FLAVOR SELF-FLAVOR-DECLARATION :NESTING-LEVEL (1+ (COMPILAND-NESTING-LEVEL PARENT)) :USE-COUNT 1-IF-LIVE-CODE ;; The following fields are only used by procedure integration. :INHERITED-VARS VARS :DECLARATIONS LOCAL-DECLARATIONS :INHERITED-GOTAGS GOTAGS :INHERITED-PROGDESCS PROGDESCS :INHERITED-RETPROGDESC RETPROGDESC :INHERITED-LOCAL-FUNCTIONS LOCAL-FUNCTIONS :INHERITED-LOCAL-MACROS *LOCAL-ENVIRONMENT* )) (UNLESS (ZEROP 1-IF-LIVE-CODE) (PUSH (AND NAMEDP (SYMBOLP LAMBDA-NAME) LAMBDA-NAME) (COMPILAND-LOCAL-FUNCTION-MAP PARENT)) (PUSH CHILD (COMPILAND-CHILDREN PARENT)))) (LET* (( MASK (- VAR-BIT 1)) ( *VAR-LEVEL-COUNTS* (MAKE-LIST (COMPILAND-NESTING-LEVEL CHILD) :INITIAL-ELEMENT '0) ) (*LOOP-VAR-BIT* VAR-BIT) ( FORM (PROG1 (LET ((PROPAGATE-VAR-SET 0) (SUBST-VAR-SET 0) (VARS VARS) (*CURRENT-COMPILAND* CHILD) (*LOOP-LEVEL* 0) (*OVERLAP-CANDIDATES* T)) ;; perform pass 1 of compilation. (IF (AND COMPILER-WARNINGS-CONTEXT (NULL SI:OBJECT-WARNINGS-OBJECT-NAME) (SYMBOLP FNAME-TO-GIVE)) (OBJECT-OPERATION-WITH-WARNINGS (FNAME-TO-GIVE) (P1-WITH-ANNOTATION CHILD #'QCOMPILE1)) (P1-WITH-ANNOTATION CHILD #'QCOMPILE1))) (UPDATE-PROPAGATE-VAR-SET)) ) ;; lexical entities referenced by the function but defined outside of it: ( USED (LOGAND (EXPR-USED FORM) MASK) ) ( ALTERED (LOGAND (EXPR-ALTERED FORM) MASK) ) ( LEXICAL-VAR-REF-SET (LOGDIF (LOGIOR USED ALTERED) SPECIAL-VAR-BIT) ) ) (UNLESS (OR (ZEROP LEXICAL-VAR-REF-SET) (ZEROP 1-IF-LIVE-CODE)) ;; At this point we know that the function contained non-local lexical ;; references, but they could be to variables, BLOCK names, or GO tags. ;; Only variable references require making a lexical closure. (DOLIST ( V VARS ) (WHEN (EQ (VAR-TYPE V) 'FEF-LOCAL) (LET (( THIS-VAR-BIT (CDDR (VAR-LAP-ADDRESS V)))) (WHEN (IF THIS-VAR-BIT ; could be nil when called from EXTEND-LOCAL-VARIABLES . (LOGTEST LEXICAL-VAR-REF-SET THIS-VAR-BIT) (VAR-USE-COUNT V)) ;; This is one of the referenced variables (SETF LEXICAL T) ; making a lexical closure (WHEN (AND THIS-VAR-BIT (LOGTEST ALTERED THIS-VAR-BIT)) (PUSHNEW 'FEF-ARG-ALTERED-IN-LEXICAL-CLOSURES ; tested in VAR-COMPUTE-INIT (VAR-MISC V))) (PUSHNEW 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)) (UNLESS EPHEMERAL ;; If this closure is not ephemeral, then any that it uses can't be either. (LET ((INIT (VAR-INIT V))) (WHEN (AND (CONSP INIT) (EQ (CAR-SAFE (SECOND INIT)) 'LEXICAL-CLOSURE)) (NOT-EPHEMERAL (SECOND INIT))))) (SETF (VAR-OVERLAP-VAR V) NIL) (WHEN (AND THIS-VAR-BIT (ZEROP (SETF LEXICAL-VAR-REF-SET (LOGDIF LEXICAL-VAR-REF-SET THIS-VAR-BIT)))) ;; Found all that we were looking for. (RETURN)) )))) (WHEN LEXICAL (INCF LEXICAL-CLOSURE-COUNT) (WHEN (> LEXICAL-CLOSURE-COUNT MAX-LEXICAL-CLOSURE-COUNT) (IF (ZEROP MAX-LEXICAL-CLOSURE-COUNT) ; the first time (SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT) VARS) (DO ((IVARS (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT) (REST IVARS))) ((OR (NULL IVARS) (MEMBER (FIRST IVARS) VARS :TEST #'EQ)) (SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT) IVARS)))) (SETQ MAX-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)) (SETF (GETF (COMPILAND-PLIST CHILD) 'VAR-LEVEL-COUNTS) (NREVERSE *VAR-LEVEL-COUNTS*)) (WHEN (COMPILAND-SUBST-FLAG CHILD) ;; not meaningful for a DEFSUBST to be a closure. (WARN 'COMPILAND-SUBST-FLAG ':IMPLAUSIBLE "DEFSUBST ~S references non-local lexical variables so cannot be expanded inline." FNAME-TO-GIVE)) ) ) (SETF (COMPILAND-USED-VAR-SET CHILD) USED) (SETF (COMPILAND-ALTERED-VAR-SET CHILD) ALTERED) ) (IF LEXICAL (LET ((DEF `(LEXICAL-CLOSURE ,CHILD ,(AND (OR EPHEMERAL ;; from PROCESS-PERVASIVE-DECLARATIONS: (GETF (COMPILAND-PLIST CHILD) 'SI:DOWNWARD-FUNCTION)) (DOLIST (GRANDCHILD (COMPILAND-CHILDREN CHILD) T) (LET ((X (COMPILAND-LEXICAL-CLOSURE-FLAG GRANDCHILD))) (WHEN (AND (CONSP X) (NOT (THIRD X))) ;; current closure can't be ephemeral if it has ;; any children that are not. (RETURN NIL)))) )))) (SETF (COMPILAND-LEXICAL-CLOSURE-FLAG CHILD) DEF) (INCF EXPRESSION-SIZE 2) (IF (COMPILAND-MACRO-FLAG CHILD) ;; need to cons on the macro flag here instead of in QLAPP. (PROGN (SETF (COMPILAND-MACRO-FLAG CHILD) NIL) (INCF EXPRESSION-SIZE 2) `(CONS 'MACRO ,DEF)) DEF)) `(BREAKOFF-FUNCTION ,CHILD)))) (DEFUN QCOMPILE2 (COMPILAND) ;; 7/09/86 DNG - Function QCOMPILE0 split into QCOMPILE1 and QCOMPILE2 and ;; re-designed around COMPILAND structure. ;; 7/29/86 DNG - Set *LEXICAL-REGISTER-LEVELS*. ;;10/11/86 DNG - LEX-A reg must always point to parent if lexical closures are created. ;;10/18/86 DNG - Add support for phantom variables. ;; 4/09/87 DNG - Disable re-loading the LEX-A register because it is needed by ;; LOAD-FROM-HIGHER-CONTEXT. [SPR 4751] (DECLARE (OPTIMIZE (SPACE 2) (SPEED 1))) ;; ;; Assign addresses of local variables ;; (LET ( VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES ( *LEXICAL-REGISTER-LEVELS* NIL )) (WHEN (OR (> (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND) 0) (COMPILAND-LEXICAL-CLOSURE-FLAG COMPILAND)) ;; Function that either makes lexical closures or is a lexical closure. (SETQ *LEXICAL-REGISTER-LEVELS* '(0)) (LET* ((COUNT-LIST (GETF (COMPILAND-PLIST COMPILAND) 'VAR-LEVEL-COUNTS)) MAX-COUNT B-LEVEL) (DECLARE (LIST COUNT-LIST)) ;; Decide which lexical levels should be addressed by the LEX-A and LEX-B ;; addressing modes. (WHEN (REST COUNT-LIST) (SETQ MAX-COUNT (APPLY #'MAX (REST COUNT-LIST))) (WHEN (> MAX-COUNT (LOOP-WEIGHTED-INCREMENT 0)) (SETQ B-LEVEL (1+ (POSITION MAX-COUNT (REST COUNT-LIST) :TEST #'EQ))) (SETQ COUNT-LIST (COPY-LIST COUNT-LIST)) (SETF (NTH B-LEVEL COUNT-LIST) 0) (SETQ MAX-COUNT (APPLY #'MAX COUNT-LIST)) (SETQ *LEXICAL-REGISTER-LEVELS* (LIST (IF (AND NIL ; This feature disabled for now. Before re-instating it, ;; we need to also be sure no more than 32 vars per level so ;; that a LOAD-FROM-HIGHER-CONTEXT or STORE-IN-HIGHER-CONTEXT ;; will never be needed since they use the A register also. (> MAX-COUNT (LOOP-WEIGHTED-INCREMENT 0)) ; enough uses to be worthwhile (= (COUNT-IF-NOT #'ZEROP COUNT-LIST) 1) ; no other levels referenced (ZEROP (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND))) (POSITION MAX-COUNT COUNT-LIST :TEST #'EQ) 0) ; else LEX-A is the immediate parent level B-LEVEL)) (UNLESS (EQUAL *LEXICAL-REGISTER-LEVELS* '(0 1)) (PUSH (CONS 'LEXICAL-REGISTER-LEVELS *LEXICAL-REGISTER-LEVELS*) (COMPILAND-DEBUG-INFO COMPILAND))) )))) (LET (( LVCNT (ASSIGN-LAP-ADDRESSES COMPILAND) )) (SETF VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)) (SETF (COMPILAND-LLOCBLOCK COMPILAND) LVCNT)) ;; Eliminate overlapped variables after ASSIGN-LAP-ADDRESSES (SETF (COMPILAND-ALLVARS COMPILAND) (ELIMINATE-DUPLICATES-AND-REVERSE (COMPILAND-ALLVARS COMPILAND))) ;; convert list of addresses to list of homes. (SETF (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND) (LOOP FOR A IN VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES COLLECT (SECOND A))) ;; ;; construct the DEBUG-INFO structure ;; (BUILD-DEBUG-INFO COMPILAND) ;; ;; Begin writing LAP output ;; (SETF (FILL-POINTER QCMP-OUTPUT) 0) (OUTF `(DEBUG-INFO . ,(COMPILAND-DEBUG-INFO COMPILAND))) ;; output FEF header information (OUTF (LIST 'MFEF (COMPILAND-FUNCTION-SPEC COMPILAND) (COMPILAND-SPECIAL-FLAG COMPILAND) (COMPILAND-ALLVARS COMPILAND) (COMPILAND-FREEVARS COMPILAND) (COMPILAND-FUNCTION-NAME COMPILAND) (COMPILAND-SUBST-FLAG COMPILAND) (COMPILAND-ARGLIST COMPILAND))) (WHEN (COMPILAND-MACRO-FLAG COMPILAND) (OUTF '(CONSTRUCT-MACRO))) (OUTF `(PARAM LLOCBLOCK ,(COMPILAND-LLOCBLOCK COMPILAND))) (WHEN (COMPILAND-SELF-MAP-NEEDED COMPILAND) ;; Flavor name, if any, follows the FEF header (OUTF `(SELF-FLAVOR . ,(COMPILAND-FLAVOR COMPILAND)))) (OUTF '(QTAG S-V-BASE)) (OUTF '(S-V-BLOCK)) ; special variable pointers output here by LAP. (OUTF '(QTAG QUOTE-BASE)) (OUTF '(ENDLIST)) ;Lap will insert quote vector here ;;; ;;; Pass 2 ;;; (record-individual-time 'p2 (LET ((VARS (COMPILAND-ARG-VARS COMPILAND)) (PROGDESCS NIL ) (GOTAGS NIL)) (PASS2 (COMPILAND-LL2 COMPILAND) (COMPILAND-EXP2 COMPILAND) (COMPILAND-INHERITED-VARS COMPILAND) ))) (LET (( COUNT 0 ) ( LEVEL (COMPILAND-NESTING-LEVEL COMPILAND) )) ;; Change (LOCAL-REF home) to (LEXICAL-REF level count) for lower-level functions. (DOLIST (A VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES) (LET ((V (SECOND A))) (SETF (CAR A) 'LEXICAL-REF (CDR A) (LIST LEVEL COUNT)) (SETF (VAR-LAP-ADDRESS V) A)) (INCF COUNT) ) (DOLIST (V (GETF (COMPILAND-PLIST COMPILAND) 'PHANTOM-VARS)) (LET ((A (VAR-LAP-ADDRESS V))) (SETF (CAR A) 'LEXICAL-REF (CDR A) (LIST LEVEL COUNT))) (INCF COUNT) ) )) COMPILAND) (DEFCONSTANT MAX-LOCAL-SLOTS (EXPT 2 (BYTE-SIZE %%QMI-OFFSET))) ; max number of args or locals ;; After the end of pass 1, assign lap addresses to the variables. ;; Returns the total number of local variable slots allocated. (DEFUN ASSIGN-LAP-ADDRESSES (COMPILAND) ;; 7/11/85 - Don't share slots used in lexical closures. ;; 9/25/85 - Make ARG-MAP and LOCAL-MAP entries be a symbol instead of a list. ;; 12/07/85 - Delete use of CLOBBER-NONSPECIAL-VARS-LISTS since it was always NIL. ;; 12/16/85 - Fix to not share storage with a deleted variable; remove FEF-REMOTE. ;; 1/10/86 - Reserve local slots for VM2 lexical closure implementation. ;; 7/08/86 - Revised to use COMPILAND structure. ;; 10/18/86 - Call EXTEND-LOCAL-VARIABLES if more than 64 local slots are needed. ;; 5/04/88 DNG - Remove ARG-MAP, which is not used anymore. Add support ;; for CLOS mapping tables and improve reservation for lexical closures. ;; 5/12/88 DNG - Fix to reserve LEX-ALL-VECTORS-REG. ;; 11/08/88 DNG - Omit the local map if none of the local slots are ;; referenced. (Saves space for trivial methods.) ;; 12/22/88 DNG - Fix error reporting for too many &KEY args. (DECLARE (VALUES LVCNT)) ;Count rest arg, auxes, and internal-auxes if they are not special. (LET* ((ARGN 0) ;Next arg number to allocate. (FIRST-UNUSED-LOCAL 0) ; the lowest number local slot not yet allocated. (LOCALS-END 0) ; slot number after the last one used. (EMPTY 0) ; unallocated slot marker (LOCAL-SLOTS (MAKE-ARRAY MAX-LOCAL-SLOTS :INITIAL-ELEMENT EMPTY)) (LOCALS-USED NIL) ) (DECLARE (FIXNUM ARGN FIRST-UNUSED-LOCAL LOCALS-END)) (FLET ((ALLOCATE-LOCAL (NUMBER NAME) (debug-assert (let ((old (aref local-slots number))) (or (eq old empty) (eq old name)))) (SETF (AREF LOCAL-SLOTS NUMBER) NAME) (WHEN (>= NUMBER LOCALS-END) (SETQ LOCALS-END (1+ NUMBER))) NUMBER) ) (FLET ((DEDICATE-LOCAL (NAME) (ALLOCATE-LOCAL (SYMBOL-VALUE NAME) NAME) )) ;; Reserve registers needed by microcode when dealing with lexical closures. (WHEN (> (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND) 0) ;; current function makes lexical closures (DEDICATE-LOCAL 'LEX-PARENT-ENV-REG) (DEDICATE-LOCAL 'LEX-CURRENT-VECTOR-REG) (WHEN (OR T ; Temporarily need to always reserve this slot until <====<<< ??? ;; (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) is updated to not issue ;; UNSHARE instructions when all closures are ephemeral. -- DNG 5/12/88 (DOLIST (CHILD (COMPILAND-CHILDREN COMPILAND) NIL) (LET ((X (COMPILAND-LEXICAL-CLOSURE-FLAG CHILD))) (WHEN (AND (CONSP X) (NOT (THIRD X))) ;; makes a non-ephemeral lexical closure (RETURN T))))) (DEDICATE-LOCAL 'LEX-ALL-VECTORS-REG)) ) (WHEN (NOT (NULL *LEXICAL-REGISTER-LEVELS*)) ;; current function is a lexical closure. (DEDICATE-LOCAL 'LEX-PARENT-ENV-REG) (WHEN (SECOND *LEXICAL-REGISTER-LEVELS*) ;; current function is a lexical closure referencing more than one level. (DEDICATE-LOCAL 'LEX-ENV-B-REG))) ) (DOLIST (V (REVERSE (COMPILAND-ALLVARS COMPILAND))) ;; Cons up the expression for Lap to use to refer to this variable. (LET* ((TYPE (VAR-TYPE V)) (KIND (VAR-KIND V)) (NAME (VAR-NAME V)) (OVERLAPS NIL) ;; If the name is in the temporary area or is uninterned, don't put it in the ;; arg/local map. This is partly to avoid putting all these stupid gensyms ;; into the object file, but the real reason is to avoid the dreaded scourge ;; of temporary area lossage in the error handler. (PERMANENT-NAME (UNLESS (= (%AREA-NUMBER NAME) QCOMPILE-TEMPORARY-AREA) (WHEN (SYMBOL-PACKAGE NAME) NAME))) ) (SETF (VAR-LAP-ADDRESS V) (COND ((EQ KIND 'FEF-ARG-DELETED) `(FEF-ARG-DELETED ,NAME)) ; dummy entry, shouldn't be referenced ((EQ TYPE 'FEF-SPECIAL) `(SPECIAL ,NAME)) ((MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT) :TEST #'EQ) (PROG1 `(ARG ,ARGN) (WHEN (= ARGN MAX-LOCAL-SLOTS) (WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT "More than ~D arguments accepted by one function." MAX-LOCAL-SLOTS)) (INCF ARGN))) ((PROGN (UNLESS (MEMBER (VAR-USE-COUNT V) '(0 NIL)) (SETQ LOCALS-USED T)) NIL)) ((EQ KIND 'FEF-ARG-REST) (ALLOCATE-LOCAL 0 PERMANENT-NAME) `(LOCBLOCK 0) ) (T (SETQ OVERLAPS (VAR-OVERLAP-VAR V)) (WHEN (AND OVERLAPS (OR (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)) (NEQ KIND (VAR-KIND OVERLAPS)) ; make sure it wasn't deleted )) ;; can't really share storage after all. (SETF (VAR-OVERLAP-VAR V) NIL) (SETF OVERLAPS NIL) ) (COND (OVERLAPS (UNLESS (NULL PERMANENT-NAME) (LET* ((NUMBER (SECOND (VAR-LAP-ADDRESS OVERLAPS))) (OLD (AREF LOCAL-SLOTS NUMBER))) (IF (LISTP OLD) (UNLESS (MEMBER PERMANENT-NAME OLD :TEST #'EQ) (SETF (AREF LOCAL-SLOTS NUMBER) (CONS PERMANENT-NAME OLD))) (UNLESS (EQ PERMANENT-NAME OLD) (SETF (AREF LOCAL-SLOTS NUMBER) (LIST PERMANENT-NAME OLD)) )))) (VAR-LAP-ADDRESS OVERLAPS)) ((EQ NAME 'SI:.DAEMON-MAPPING-TABLE.) ;; This magic variable used in combined flavor methods must ;; always be LOCAL|1 because the microcode expects to ;; find it there when doing a %SET-SELF-MAPPING-TABLE . `(LOCBLOCK ,(ALLOCATE-LOCAL SYS:LOCAL-FOR-FIRST-MAPPING-TABLE PERMANENT-NAME))) ((AND (EQ KIND 'FEF-ARG-KEY) (EQ (VAR-INIT-KIND V) 'FEF-INI-MAP)) ;; A CLOS mapping table or continuation that must go in a particular slot. `(LOCBLOCK ,(ALLOCATE-LOCAL (VAR-INIT-FORM V) PERMANENT-NAME))) (T (LOOP UNTIL (OR (= FIRST-UNUSED-LOCAL LOCALS-END) (EQ (AREF LOCAL-SLOTS FIRST-UNUSED-LOCAL) EMPTY)) DO (INCF FIRST-UNUSED-LOCAL)) (WHEN (>= FIRST-UNUSED-LOCAL MAX-LOCAL-SLOTS) (IF (EXTEND-LOCAL-VARIABLES COMPILAND) (RETURN-FROM ASSIGN-LAP-ADDRESSES (ASSIGN-LAP-ADDRESSES COMPILAND)) (WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT (IF (EQ KIND 'FEF-ARG-KEY) "More than ~D keyword arguments used." "More than ~D local variable slots required by one function.") MAX-LOCAL-SLOTS))) `(LOCBLOCK ,(ALLOCATE-LOCAL (IF (AND (EQ KIND 'FEF-ARG-KEY) (< FIRST-UNUSED-LOCAL LOCALS-END)) ;; &key args must be contiguous (IF (< LOCALS-END MAX-LOCAL-SLOTS) LOCALS-END (PROGN (WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT "More than ~D keyword arguments used." #.(- MAX-LOCAL-SLOTS SYS:LOCALS-FOR-MAPPING-TABLE-BASE)) FIRST-UNUSED-LOCAL)) (PROG1 FIRST-UNUSED-LOCAL (INCF FIRST-UNUSED-LOCAL))) PERMANENT-NAME))))))) )) (LET ((LOCAL-MAP '())) (DECLARE (UNSPECIAL LOCAL-MAP) (LIST LOCAL-MAP)) (WHEN LOCALS-USED (DO ((I (- LOCALS-END 1) (- I 1))) ((< I 0)) (LET ((NAME (AREF LOCAL-SLOTS I))) (WHEN (EQ NAME EMPTY) (SETQ NAME NIL)) (UNLESS (AND (NULL NAME) (NULL LOCAL-MAP)) (PUSH NAME LOCAL-MAP))))) (SETF (COMPILAND-LOCAL-MAP COMPILAND) (COPY-LIST LOCAL-MAP))) LOCALS-END))) ;There can be duplicates of local vars on allvars because of the variable overlaping hack. ;Dont disturb special vars. (DEFUN ELIMINATE-DUPLICATES-AND-REVERSE (VAR-LIST) (PROG (ANS) L (COND ((NULL VAR-LIST) (RETURN ANS)) ((EQ (VAR-KIND (CAR VAR-LIST)) 'FEF-ARG-DELETED)) ((NULL (DOLIST (V ANS) (IF (AND (EQ (VAR-NAME V) (VAR-NAME (CAR VAR-LIST))) (NOT (EQ (CAR (VAR-LAP-ADDRESS V)) 'SPECIAL)) (EQUAL (VAR-LAP-ADDRESS V) (VAR-LAP-ADDRESS (CAR VAR-LIST)))) (RETURN T)))) ;this a local duplicate, flush (SETQ ANS (CONS (CAR VAR-LIST) ANS)))) (SETQ VAR-LIST (CDR VAR-LIST)) (GO L))) (DEFUN EXTEND-LOCAL-VARIABLES (PARENT) ;; When ASSIGN-LAP-ADDRESSES finds that there are more local variables than ;; can be handled; it calls this function which splits the compiland into two ;; FEFs and puts the excess variables in the lexical environment. These are ;; called "phantom variables" because they exist only in the lexical environment ;; and are not part of any stack frame. ;; ;; 10/18/86 DNG - Original. ;; 12/22/86 DNG - Fix for when the function already creates lexical closures. ;; 6/29/87 DNG - Local variables that might need to be unshared need to go in ;; CHILD-ALLVARS instead of PHANTOM-VARS. [SPR 5719] (LET ((PARENT-ALLVARS NIL) (CHILD-ALLVARS NIL) (OVERLAPPED-ALLVARS NIL) (PHANTOM-VARS NIL) (SPECIAL-VARS NIL) (UNSHARE-VARS NIL)) (DOLIST (V (COMPILAND-ALLVARS PARENT)) (LET ((KIND (VAR-KIND V))) (COND ((EQ KIND 'FEF-ARG-DELETED)) ((EQ (VAR-TYPE V) 'FEF-SPECIAL) (PUSH V SPECIAL-VARS)) ((EQ KIND 'FEF-ARG-INTERNAL-AUX) (LET ((USE-COUNT (VAR-USE-COUNT V)) (OVERLAPS (VAR-OVERLAP-VAR V))) (IF (NULL OVERLAPS) (IF (NULL USE-COUNT) (PUSH V PHANTOM-VARS) (IF (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ) (PUSH V UNSHARE-VARS) ; used in closure, might need to unshare (PUSH V CHILD-ALLVARS))) (LET (( COUNT (VAR-USE-COUNT OVERLAPS) )) (WHEN (NULL COUNT) (SETQ COUNT 0)) (SETF (VAR-USE-COUNT OVERLAPS) (+ COUNT USE-COUNT)) (PUSH V OVERLAPPED-ALLVARS))))) (T (PUSH V PARENT-ALLVARS) (UNLESS (OR (NULL (VAR-USE-COUNT V)) (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V))) (PUSH 'FEF-ARG-NO-UNSHARE (VAR-MISC V)) (PUSH 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)) ))))) (UNLESS (OR CHILD-ALLVARS PHANTOM-VARS UNSHARE-VARS) (RETURN-FROM EXTEND-LOCAL-VARIABLES NIL)) ; indicate failure ;; Allocate the local slots to the variables that are used the most. (SETF CHILD-ALLVARS (NCONC (NREVERSE UNSHARE-VARS) ; last defined most likely to need unsharing (SORT CHILD-ALLVARS #'> :KEY #'VAR-USE-COUNT))) (LET ((CUT (NTHCDR 56. CHILD-ALLVARS))) ; 64 slots minus up to 6 reserved slots = 58 (UNLESS (NULL CUT) (SETF PHANTOM-VARS (NCONC (CDR CUT) PHANTOM-VARS )) (SETF (CDR CUT) NIL))) (DOLIST (V PHANTOM-VARS) (LET ((MISC (VAR-MISC V))) (UNLESS (OR (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES MISC) (MEMBER 'FEF-ARG-NO-UNSHARE MISC)) ;; Tell (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P2) to not try to ;; generate an UNSHARE instruction for this since it won't be in ;; the VARIABLES-USED-IN-LEXICAL-CLOSURES list. (SETF (VAR-MISC V) (CONS 'FEF-ARG-NO-UNSHARE MISC)) ))) (LET (CHILD BREAKOFF (OPTIONALS NIL) (SIBLINGS (COMPILAND-CHILDREN PARENT)) (LOCAL-FUNCTION-NAMES (COMPILAND-LOCAL-FUNCTION-MAP PARENT)) (SAVED-CLOSURE-COUNT (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT PARENT)) ) (LET ((VARS (APPEND PARENT-ALLVARS PHANTOM-VARS)) (GOTAGS NIL) (PROGDESCS NIL) (RETPROGDESC NIL) (LOCAL-FUNCTIONS NIL) (VAR-BIT 0) (USED-VAR-SET -1 ) ;(COMPILAND-USED-VAR-SET PARENT)) (ALTERED-VAR-SET -1) ;(COMPILAND-ALTERED-VAR-SET PARENT)) (SUBST-VAR-SET 0) (PROPAGATE-VAR-SET 0) (MACRO-CONS-AREA DEFAULT-CONS-AREA) (LEXICAL-CLOSURE-COUNT 0) (MAX-LEXICAL-CLOSURE-COUNT 0) (EXPRESSION-SIZE 0) (P1VALUE T) BODY) (SETQ BODY (LET ((ALLVARS NIL)) (MARK-P1-DONE (COMPILAND-EXP2 PARENT)))) (SETF (COMPILAND-CHILDREN PARENT) NIL) (SETF (COMPILAND-LOCAL-FUNCTION-MAP PARENT) NIL) (SETQ BREAKOFF (BREAKOFF (IF (DOLIST (ARG (COMPILAND-ARGLIST PARENT) NIL) (COND ((CONSP ARG) (SETQ OPTIONALS T) (RETURN T)) ((MEMBER ARG '(&KEY &REST &AUX)) (RETURN NIL)))) ;; some optional args with default values `(NAMED-LAMBDA :BODY (N-OPT-SUPPLIED) (%PUSH N-OPT-SUPPLIED) ,BODY) `(NAMED-LAMBDA :BODY () ,BODY)) T)) (SETF (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT PARENT) MAX-LEXICAL-CLOSURE-COUNT)) (SETQ CHILD (SECOND BREAKOFF)) (SETF (COMPILAND-CHILDREN CHILD) SIBLINGS) (SETF (COMPILAND-LOCAL-FUNCTION-MAP CHILD) LOCAL-FUNCTION-NAMES) (SETF (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT CHILD) SAVED-CLOSURE-COUNT) ;; the following is to prevent the interpreted definition from being saved (SETF (COMPILAND-EXPRESSION-SIZE CHILD) (COMPILAND-EXPRESSION-SIZE PARENT)) (LABELS ((INCREMENT-NESTING-LEVEL (COMPILAND) (INCF (COMPILAND-NESTING-LEVEL COMPILAND)) ;;(PUSH-END (1+ (LOOP-WEIGHTED-INCREMENT 0)) ;; (GETF (COMPILAND-PLIST COMPILAND) 'VAR-LEVEL-COUNTS)) (MAPC #'INCREMENT-NESTING-LEVEL (COMPILAND-CHILDREN COMPILAND)) NIL)) (DOLIST (C SIBLINGS) (SETF (SECOND (COMPILAND-FUNCTION-SPEC C)) (COMPILAND-FUNCTION-SPEC CHILD)) (SETF (COMPILAND-PARENT C) CHILD) (INCREMENT-NESTING-LEVEL C))) (DOLIST (V CHILD-ALLVARS) (SETF (VAR-COMPILAND V) CHILD) (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)) (PUSHNEW `(LOCAL-REF ,V) (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES CHILD) :TEST #'EQ :KEY #'SECOND))) (LET ((USED-IN-LEX NIL)) (DOLIST (V (PROG1 PARENT-ALLVARS (SETQ PARENT-ALLVARS NIL))) (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V)) (PUSHNEW `(LOCAL-REF ,V) USED-IN-LEX :TEST #'EQ :KEY #'SECOND)) (PUSH V PARENT-ALLVARS)) (SETF (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES PARENT) USED-IN-LEX)) (DOLIST (V OVERLAPPED-ALLVARS) (LET ((OVERLAPS (VAR-OVERLAP-VAR V))) (IF (EQ (VAR-COMPILAND OVERLAPS) CHILD) (PUSH V CHILD-ALLVARS) (IF (MEMBER OVERLAPS PHANTOM-VARS :TEST #'EQ) (SETF (VAR-LAP-ADDRESS V) (VAR-LAP-ADDRESS OVERLAPS)) (PUSH V PARENT-ALLVARS))))) (SETF (COMPILAND-FREEVARS CHILD) (COMPILAND-FREEVARS PARENT)) (SETF (COMPILAND-ALLVARS CHILD) (NCONC CHILD-ALLVARS SPECIAL-VARS (COMPILAND-ALLVARS CHILD))) (SETF (COMPILAND-EXP2 PARENT) (IF OPTIONALS `(FUNCALL ,BREAKOFF (%POP)) `(FUNCALL ,BREAKOFF))) (SETF (COMPILAND-ALLVARS PARENT) PARENT-ALLVARS) (SETF (GETF (COMPILAND-PLIST PARENT) 'PHANTOM-VARS) PHANTOM-VARS) (SETF (COMPILAND-DEFINITION CHILD) (COMPILAND-DEFINITION PARENT)) )) T) ; indicate success (DEFUN COPY-TO-PROPER-AREA (OBJECT) ;; If the object is in a temporary area which is not the current ;; DEFAULT-CONS-AREA, then copy it. ;; 5/08/86 DNG - Original. (IF (OR (SYMBOLP OBJECT) (EQ DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA)) OBJECT (SI:COPY-OBJECT-TREE OBJECT T))) (DEFUN BUILD-DEBUG-INFO (COMPILAND) ;; Set up the debug info from the local declarations and other things. ;; Note that the most frequently used information should be pushed last ;; so it will be at the front of the list. ;; ;; 12/27/84 DNG - Save DEFUN-METHOD definitions on FILE-LOCAL-DECLARATIONS. ;; 2/15/85 DNG - Remember function which redefines a macro or subst. ;; 3/07/85 DNG - Don't push COMPILER-ARGLIST when redundant. ;; 3/29/85 DNG - Fix to not mark all DEFSUBSTs with '(:NO-SIMPLE-SUBSTITUTION T). ;; 4/09/85 DNG - Fix for EXPANSION which is an atom. ;; 4/23/85 DNG - Save interpreted definition of small functions in the ;; GLOBAL package to allow later inline expansion. ;; 7/12/85 DNG - Include LOCAL-FUNCTION-MAP in the debug info. ;; 10/03/85 DNG - Fix to remember method definitions in COMPILE-FILE for ;; integration later in the file. ;; 10/21/85 DNG - Don't record debug info when *SUPPRESS-DEBUG-INFO* is true. ;; 11/16/85 DNG - Generate new debug-info structure for release 3. ;; 1/09/86 DNG - New field :VARIABLES-USED-IN-LEXICAL-CLOSURES. ;; 2/01/86 DNG - Record debug info lexical parent function; ;; don't suppress documentation of external functions. ;; 3/18/86 DNG - Use new function CHECK-USED-BEFORE-DEFINED to warn about ;; macros etc. used before defined. ;; 3/21/86 DNG - Always use new debug info structure when compiling for VM2. ;; 4/24/86 DNG - On VM2, use ARGS-DESC instead of ARGS-INFO. ;; 5/08/86 DNG - Use new function COPY-TO-PROPER-AREA on debug info lists; ;; bind FUNCTION-PROPERTY-AREA around call to MAKE-DEBUG-INFO-STRUCT. ;; 5/22/86 DNG - Don't save interpreted defn. for symbols with QLVAL property. ;; 6/09/86 DNG - Make sure the function name is in the proper area; remove ;; binding of FUNCTION-PROPERTY-AREA which is no longer needed. ;; 6/16/86 DNG - Temporary special handling of COMBINED-METHOD-DERIVATION and ;; WRAPPER-SXHASHES debug info when cross-compiling. ;; 6/18/86 DNG - Modify handling of EXPR-DEBUG-INFO. ;; 7/08/86 DNG - New function BUILD-DEBUG-INFO replaces SET-UP-DEBUG-INFO. ;; 7/22/86 DNG - Don't suppress :ARGLIST when it contains "E. ;; 7/31/86 DNG - Macro definitions are now saved on FILE-LOCAL-DECLARATIONS ;; here instead of in the special forms DEFMACRO and DEFSUBST. ;; 8/04/86 DNG - Avoid using QC-TF-OUTPUT-MODE here. ;; 8/12/86 DNG - Don't push macro definition on FILE-LOCAL-DECLATIONS when already done. ;; 10/08/86 DNG - Don't save interpreted definition of fasload-combined methods. ;; 10/11/86 DNG - Record hash code for DEFSUBSTs and inline functions as well as macros. ;; 10/17/86 DNG - Use new function EQUIVALENT-FORMS-P . ;; 10/19/86 DNG - Add support for phantom variables. ;; 11/15/86 DNG - Fix reference to EXPRESSION-SIZE. ;; 11/21/86 DNG - Test OPCODE property instead of QLVAL or TWO-ARGUMENT-FUNCTION. ;; 1/06/87 DNG - Fix to not put temporary area gensyms in the :VARIABLES-USED-IN-LEXICAL-CLOSURES list. ;; 2/18/87 DNG - Fix several problems with the *SUPPRESS-DEBUG-INFO* option. ;; 6/17/87 DNG - Fix to not save the interpreted definition for possible inline ;; expansion in any of the following cases: ;; * The name is NIL [SPR 5237] or an uninterned symbol. ;; * The name is an :INTERNAL or :LOCATIVE function spec. ;; * The function is a lexical closure. ;; Also make *SUPPRESS-DEBUG-INFO* prevent saving the interpreted definition ;; just because the compilation is done in memory ;; 5/23/88 CLM - New field :CONTINUATION-SLOT for CLOS, store the local offset of the ;; continuation if there is one. ;; 7/26/88 JHO - Added update of FILE-LOCAL-DECLARATIONS-DEF-ALIST. ;; 8/16/88 clm - Use only FILE-LOCAL-DECLARATIONS-DEF-ALIST to keep track of DEFinitions ;; (no longer keep same info in FILE-LOCAL-DECLARATIONS). ;; 10/20/88 DNG - Omit declared ARGLIST that is same as real arglist. ;; 11/15/88 DNG - Don't save interpreted definition of generic functions or ;; methods. Strip trailing nulls from the :INTERNAL-FEF-NAMES list. ;; 11/17/88 DNG - Don't keep NOTINLINE information from PROCEDURE-INTEGRATION. ;; 12/29/88 DNG - Do save interpreted definition for encapsulations. ;; 2/10/89 DNG - Record specializer names in debug info if not included in the name. ;; 4/07/89 DNG - Add use of FUNCTION-FOR-TARGET. ;; 4/25/89 DNG - Add use of COMPILAND-CONSTANTS-EXPANDED for SPR 6501. (LET* (( SUPPRESS-DEBUG *SUPPRESS-DEBUG-INFO* ) ( SUPPRESS-ARGS SUPPRESS-DEBUG ) ( FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC COMPILAND)) ( EXPR-DEBUG-INFO (COMPILAND-DEBUG-INFO COMPILAND) ) ( TRE-ARGS (COMPILAND-ARGLIST COMPILAND) ) ( MACROFLAG (COMPILAND-MACRO-FLAG COMPILAND) ) ( EXP (COMPILAND-DEFINITION COMPILAND) ) ( SUBST-FLAG (COMPILAND-SUBST-FLAG COMPILAND) ) ( DOCUMENTATION (COMPILAND-DOCUMENTATION COMPILAND) ) ( MACROS-EXPANDED (COMPILAND-MACROS-EXPANDED COMPILAND) ) ( CONSTANTS-EXPANDED (COMPILAND-CONSTANTS-EXPANDED COMPILAND) ) ( QUOTED-ARG (MEMBER '"E TRE-ARGS :TEST #'EQ) )) (DECLARE (UNSPECIAL FUNCTION-TO-BE-DEFINED MACROS-EXPANDED)) (WHEN SUPPRESS-ARGS (IF (AND FUNCTION-TO-BE-DEFINED (EXTERNAL-SYMBOL-P FUNCTION-TO-BE-DEFINED)) ;; always provide arglist and doc string for externally defined functions (SETQ SUPPRESS-ARGS NIL) (SETQ DOCUMENTATION NIL)) (IF (MEMBER SUPPRESS-DEBUG '( :DOCUMENTATION DOCUMENTATION )) ;; suppress doc string only (SETQ SUPPRESS-ARGS NIL SUPPRESS-DEBUG NIL) (WHEN (AND SUPPRESS-ARGS (NOT (COMPILING-FOR-V2)) ; temporary until the implications can be considered (NOT SUBST-FLAG) (NOT MACROFLAG) (NOT (AND QUOTED-ARG (COMPILING-FOR-V2))) (NULL (COMPILAND-CHILDREN COMPILAND)) (NOT (EQ (CAR-SAFE FUNCTION-TO-BE-DEFINED) :METHOD)) (NULL (INLINE-DECL FUNCTION-TO-BE-DEFINED))) (RETURN-FROM BUILD-DEBUG-INFO (SETF (COMPILAND-DEBUG-INFO COMPILAND) '#,(SI:MAKE-DEBUG-INFO-STRUCT :NAME NIL)))))) (WHEN (AND (NULL FUNCTION-TO-BE-DEFINED) (NULL (ASSOC 'SYS:FUNCTION-PARENT EXPR-DEBUG-INFO))) (LET ((PARENT (COMPILAND-PARENT COMPILAND))) (UNLESS (NULL PARENT) (LET ((DCL (ASSOC 'SYS:FUNCTION-PARENT (COMPILAND-DEBUG-INFO PARENT)))) (UNLESS (NULL DCL) (PUSH DCL EXPR-DEBUG-INFO)))))) ;; ;; -- Debug info structure for release 3 -- ;; (LET ( DBI ( DEFAULT-CONS-AREA (IF (AND QC-FILE-IN-PROGRESS (NOT QC-FILE-LOAD-FLAG)) DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) )) (IF (LISTP EXPR-DEBUG-INFO) (PROGN (SETQ DBI (SI:MAKE-DEBUG-INFO-STRUCT :NAME (COPY-TO-PROPER-AREA (COMPILAND-FUNCTION-NAME COMPILAND)))) (DOLIST (DCL EXPR-DEBUG-INFO) (LET (( DT (OR (CDR (ASSOC (CAR DCL) SI:*DEBUG-STRUCT-LOCAL-DECLARATION-TYPES* :TEST #'EQ)) (CAR DCL)) )) (UNLESS (OR (SI:GET-DEBUG-INFO-FIELD DBI DT) ;; Suppress redundant FUNCTION-PARENT declaration. (AND (EQ DT ':FUNCTION-PARENT) (EQUAL (SECOND DCL) (COMPILAND-FUNCTION-NAME COMPILAND)) ) ;; Suppress declared ARGLIST that is same as real arglist. (AND (EQ DT ':DESCRIPTIVE-ARGLIST) (EQUAL (CDR DCL) TRE-ARGS)) (EQ DT 'NOTINLINE) ; used internally by PROCEDURE-INTEGRATION ) (SI:PUT-DEBUG-INFO-FIELD DBI DT (COPY-TO-PROPER-AREA (CDR DCL)) ))))) (SETQ DBI EXPR-DEBUG-INFO) ) (UNLESS (NULL DOCUMENTATION) (SI:PUT-DEBUG-INFO-FIELD DBI :DOCUMENTATION (COPY-TO-PROPER-AREA DOCUMENTATION)) ) (UNLESS SUPPRESS-DEBUG ;; If we aren't going to mark this function as requiring a mapping ;; table, provide anyway some info that the user declared it wanted one. (WHEN (AND (COMPILAND-FLAVOR COMPILAND) (NOT (COMPILAND-SELF-MAP-NEEDED COMPILAND))) (SI:PUT-DEBUG-INFO-FIELD DBI :SELF-FLAVOR (CAR (COMPILAND-FLAVOR COMPILAND))) ) (WHEN (AND (COMPILAND-PARENT COMPILAND) (COMPILAND-LEXICAL-CLOSURE-FLAG COMPILAND)) (SI:PUT-DEBUG-INFO-FIELD DBI :LEXICAL-PARENT-DEBUG-INFO (COMPILAND-DEBUG-INFO (COMPILAND-PARENT COMPILAND)))) (LET ((LEXVARS (GETF (COMPILAND-PLIST COMPILAND) 'PHANTOM-VARS))) ;; phantom variables are created by EXTEND-LOCAL-VARIABLES (IF (NULL LEXVARS) (SETQ LEXVARS (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)) (SETQ LEXVARS (APPEND (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND) LEXVARS))) (UNLESS (NULL LEXVARS) (SI:PUT-DEBUG-INFO-FIELD DBI :VARIABLES-USED-IN-LEXICAL-CLOSURES (LOOP FOR HOME IN LEXVARS COLLECT (LET ((NAME (VAR-NAME HOME))) (IF (AND (SYMBOLP NAME) (NULL (SYMBOL-PACKAGE NAME))) ;; Intern gensyms so the symbol won't be in the temporary area. ;; Needed for the variables created by P1BLOCK to hold the BLOCK exit throw tag. (INTERN (SYMBOL-NAME NAME)) NAME)) ) ))) ) (WHEN (COMPILAND-CHILDREN COMPILAND) ;; strip trailing nulls from this list (DO ((DT (COMPILAND-LOCAL-FUNCTION-MAP COMPILAND) (CDR DT))) ((OR (NULL DT) (NOT (NULL (CAR DT)))) (UNLESS (NULL DT) (SI:PUT-DEBUG-INFO-FIELD DBI :INTERNAL-FEF-NAMES (REVERSE DT)) ))) (SI:PUT-DEBUG-INFO-FIELD DBI :INTERNAL-FEF-OFFSETS (MAKE-LIST (LENGTH (COMPILAND-CHILDREN COMPILAND)))) ) ;;store the offset of the continuation, if there was one (let ((var (lookup-var '.next-method-list. (compiland-allvars compiland)))) (when (and var (eq (var-kind var) 'fef-arg-key)) (si:put-debug-info-field dbi :continuation-slot (cadr (var-lap-address var))))) (UNLESS SUPPRESS-DEBUG (LET ((SPECIALIZERS (GETF (COMPILAND-PLIST COMPILAND) 'TICLOS::SPECIALIZERS))) (UNLESS (OR (NULL SPECIALIZERS) (EQ (CAR-SAFE (COMPILAND-FUNCTION-NAME COMPILAND)) 'TICLOS:METHOD)) ;; Save for use by the disassembler -- function FUNCTION-SPECIALIZERS (PUT-DEBUG-INFO-FIELD DBI 'ARG-CLASSES (MAPCAR #'TICLOS:TYPE-NAME SPECIALIZERS)))) ;; Include the local variable map. It was built by ASSIGN-LAP-ADDRESSES. (LET (( LOCAL-MAP (COMPILAND-LOCAL-MAP COMPILAND) )) (DECLARE (UNSPECIAL LOCAL-MAP)(LIST LOCAL-MAP)) (UNLESS (OR (NULL LOCAL-MAP) (EVERY #'NULL LOCAL-MAP)) (SI:PUT-DEBUG-INFO-FIELD DBI :LOCAL-MAP (COPY-TO-PROPER-AREA LOCAL-MAP)) ))) (WHEN (OR (NOT SUPPRESS-ARGS) QUOTED-ARG SUBST-FLAG) (SI:PUT-DEBUG-INFO-FIELD DBI :ARGLIST (COPY-TO-PROPER-AREA TRE-ARGS))) (UNLESS SUPPRESS-DEBUG ;; Include list of DEFCONSTANTs used, if any. (UNLESS (NULL CONSTANTS-EXPANDED) (SI:PUT-DEBUG-INFO-FIELD DBI :CONSTANTS-OPEN-CODED (LOOP FOR TAIL ON CONSTANTS-EXPANDED BY #'CDDR COLLECT (CONS (FIRST TAIL) (SECOND TAIL))))) ;; Include list of macros used, if any. (UNLESS (NULL MACROS-EXPANDED) (SI:PUT-DEBUG-INFO-FIELD DBI :MACROS-EXPANDED (MACROS-EXPANDED-DEBUG-INFO MACROS-EXPANDED)))) (LET* (( IND (INLINE-DECL FUNCTION-TO-BE-DEFINED) ) ( TRY-INLINE ; is this a candidate for inline expansion? (OR (EQ IND 'compiler:INLINE) (EQ IND 'compiler:TRY-INLINE) (AND (NEQ IND 'compiler:NOTINLINE) (< (COMPILAND-EXPRESSION-SIZE COMPILAND) 20.) (OR (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH)) (AND (SYMBOLP FUNCTION-TO-BE-DEFINED) (EQ (SYMBOL-PACKAGE FUNCTION-TO-BE-DEFINED) SI:PKG-LISP-PACKAGE) (EXTERNAL-SYMBOL-P FUNCTION-TO-BE-DEFINED))) (NOT MACROFLAG) (TYPECASE FUNCTION-TO-BE-DEFINED (NULL NIL) (SYMBOL (AND (SYMBOL-PACKAGE FUNCTION-TO-BE-DEFINED) (NOT (GETL FUNCTION-TO-BE-DEFINED '(P1 P2 OPCODE))))) (CONS (AND (EQ (FIRST FUNCTION-TO-BE-DEFINED) ':METHOD) (NEQ (THIRD FUNCTION-TO-BE-DEFINED) 'SI:FASLOAD-COMBINED))) (T NIL)) (NOT (COMPILAND-LEXICAL-CLOSURE-FLAG COMPILAND)) ) ) ) OLD-DEF ) (WHEN (AND QC-FILE-IN-PROGRESS (NOT QC-FILE-LOAD-FLAG) FUNCTION-TO-BE-DEFINED (OR TRY-INLINE QUOTED-ARG MACROFLAG SUBST-FLAG (IF (CONSP FUNCTION-TO-BE-DEFINED) (AND (EQ (FIRST FUNCTION-TO-BE-DEFINED) :METHOD) (NTHCDR 3 FUNCTION-TO-BE-DEFINED) ) (AND (COMPILAND-FLAVOR COMPILAND) (COMPILAND-SELF-MAP-NEEDED COMPILAND)) ) (AND (SYMBOLP FUNCTION-TO-BE-DEFINED) (FBOUNDP FUNCTION-TO-BE-DEFINED) (SETQ OLD-DEF (SYMBOL-FUNCTION FUNCTION-TO-BE-DEFINED)) ;; When a name that used to be a macro or subst is redefined ;; as a function, need to remember the new definition in order ;; to shadow the old one that is still in the global environment. (OR (EQ (CAR-SAFE OLD-DEF) 'MACRO) (MEMBER (FIRST (INTERPRETED-DEF OLD-DEF)) '(GLOBAL:SUBST GLOBAL:NAMED-SUBST CLI:SUBST NAMED-SUBST) :TEST #'EQ) (NOT (EQUAL (ARGLIST OLD-DEF 'LISP:COMPILE) TRE-ARGS)) ) ) ) ;; Was definition already saved by an (EVAL-WHEN (COMPILE)...)? (not (equal (file-local-def function-to-be-defined) exp)) ) ;; Save definition for MACROEXPAND, MAYBE-INTEGRATE, P1ARGC, ;; CHECK-NUMBER-OF-ARGS, or EVAL-FOR-TARGET to use later in the file. (setf (file-local-def function-to-be-defined) ;; close over the compile-time environment (FUNCTION-FOR-TARGET exp *COMPILE-FILE-ENVIRONMENT*) )) (WHEN (OR SUBST-FLAG TRY-INLINE SAVE-INTERP-DEF (AND (NOT (AND QC-FILE-IN-PROGRESS (NOT QC-FILE-LOAD-FLAG))) (NOT SUPPRESS-DEBUG) ;; Don't save definition of generic functions or methods. (NOT (LISTP FUNCTION-TO-BE-DEFINED)) (NOT (SI:GET-DEBUG-INFO-FIELD DBI :GENERIC-FUNCTION)) ) ;; Encapsulations must retain their interpreted definition to be able ;; to un-encapsulate later. (SI:GET-DEBUG-INFO-FIELD DBI 'SYS:ENCAPSULATED-DEFINITION) ) (SI:PUT-DEBUG-INFO-FIELD DBI :INTERPRETED-DEFINITION (COPY-TO-PROPER-AREA EXP)) ) (WHEN UNDO-DECLARATIONS-FLAG (LET (( KIND (COND (MACROFLAG "macro") (QUOTED-ARG "special form") (SUBST-FLAG 'DEFSUBST) ((EQ IND 'compiler:INLINE) "inline function") (T NIL)) )) (UNLESS (NULL KIND) (CHECK-USED-BEFORE-DEFINED FUNCTION-TO-BE-DEFINED KIND)))) (WHEN SUBST-FLAG (LET* (( DUMMY-FORM (MULTIPLE-VALUE-BIND ( MIN MAX REST ) (SI:ARGS-DESC EXP) (DECLARE (IGNORE MIN)) (CONS 'FOO (MAKE-LIST (+ MAX (IF REST 1 0)) :INITIAL-ELEMENT '(GENSYM))))) ( EXPANSION (SI:SUBST-EXPAND EXP DUMMY-FORM NIL)) ) ; hard way (UNLESS (EQUIVALENT-FORMS-P EXPANSION (SI:SUBST-EXPAND EXP DUMMY-FORM T)) ; easy way ;; If simple and thoughtful substitution give the same result ;; even with the most intractable arguments, ;; we need not use thoughtful substitution for this defsubst. ;; Otherwise, mark it as requiring thoughtful substitution. (SI:PUT-DEBUG-INFO-FIELD DBI :NO-SIMPLE-SUBSTITUTION T) ))) ;; Compute the sxhash now, after all displacing macros have been displaced (WHEN (AND (OR MACROFLAG SUBST-FLAG (EQ IND 'compiler:INLINE)) ;; allow hash code to be over-ridden by a DECLARE (NULL (SI:GET-DEBUG-INFO-FIELD DBI :EXPR-SXHASH))) (SI:PUT-DEBUG-INFO-FIELD DBI :EXPR-SXHASH (FUNCTION-EXPR-SXHASH (IF MACROFLAG (CDR EXP) EXP))) )) (SETF (COMPILAND-DEBUG-INFO COMPILAND) DBI) ) )) (DEFUN EXTERNAL-SYMBOL-P (OBJECT) (AND (SYMBOLP OBJECT) (NOT (NULL (SYMBOL-PACKAGE OBJECT))) (MULTIPLE-VALUE-BIND ( SYMBOL CLASS ) (FIND-SYMBOL (SYMBOL-NAME OBJECT) (SYMBOL-PACKAGE OBJECT)) (DECLARE (IGNORE SYMBOL)) (EQ CLASS :EXTERNAL) ))) (DEFUN EQUIVALENT-FORMS-P (A B &OPTIONAL CDR-FLAG) ;; Compare two source forms like EQUAL except disregarding redundant PROGNs. (DECLARE (ARGLIST A B)(OPTIMIZE (SPEED 2)(SAFETY 0))) (COND ((EQL A B) T) ((AND (ATOM A) (ATOM B)) NIL) ((AND (EQ (CAR-SAFE A) 'PROGN) (NULL (CDDR A)) (NOT CDR-FLAG)) (EQUIVALENT-FORMS-P (SECOND A) B)) ((AND (EQ (CAR-SAFE B) 'PROGN) (NULL (CDDR B)) (NOT CDR-FLAG)) (EQUIVALENT-FORMS-P A (SECOND B))) ((OR (ATOM A) (ATOM B)) NIL) ((EQUIVALENT-FORMS-P (CAR A) (CAR B)) (IF (AND (EQ (CAR A) 'QUOTE) (NOT CDR-FLAG)) (EQUAL (CDR A) (CDR B)) (EQUIVALENT-FORMS-P (CDR A) (CDR B) T))) (T NIL))) (DEFUN MACROS-EXPANDED-DEBUG-INFO (MACROS-EXPANDED) ;; Given the list of macros expanded in the current function, return the value ;; for the :MACROS-EXPANDED entry in the debug info. ;; 8/08/86 DNG - Original. ;; 8/28/86 DNG - Don't record hash codes when cross-compiling since the ;; hashing algorithm is different between releases 2 and 3. ;; 10/09/86 DNG - In QC-FILE, macro names which are lists must be enclosed in ;; a list in the debug info. (DECLARE (UNSPECIAL MACROS-EXPANDED)) (WHEN MACROS-EXPANDED (LET ((MACROS-AND-SXHASHES (MAPCAR #'(LAMBDA (MACRONAME) (LET ((HASH (EXPR-SXHASH MACRONAME))) (IF (OR HASH (CONSP MACRONAME)) (LIST MACRONAME HASH) MACRONAME))) MACROS-EXPANDED))) (IF QC-FILE-RECORD-MACROS-EXPANDED (PROGN ;; If in QC-FILE, put just macro names in the function ;; but put the names and sxhashes into the file's list. (DOLIST (M MACROS-AND-SXHASHES) (UNLESS (MEMBER M QC-FILE-MACROS-EXPANDED :TEST #'EQUAL) (PUSH M QC-FILE-MACROS-EXPANDED))) (MAPCAR #'(LAMBDA (MACRONAME) (IF (CONSP MACRONAME) (LIST MACRONAME) MACRONAME)) MACROS-EXPANDED) ) MACROS-AND-SXHASHES) ))) (DEFUN CHECK-USED-BEFORE-DEFINED ( NAME KIND ) ;; 3/18/86 DNG - Original. (Previously part of SETUP-DEBUG-INFO, MACRO, etc. (UNLESS (NULL KIND) (LET (( REF (ASSOC NAME FUNCTIONS-REFERENCED :TEST #'EQUAL) )) (UNLESS (NULL REF) (IF (NULL (CDDR REF)) (WARN 'MACRO-USED-BEFORE-DEFINED ':IMPLAUSIBLE "The ~A ~S was used by ~S before it was defined." KIND NAME (CADR REF) ) (PROGN (WARN 'MACRO-USED-BEFORE-DEFINED ':IMPLAUSIBLE "The ~A ~S was used before it was defined." KIND NAME ) (FORMAT T "~&Referenced by:") (DOLIST ( F (CDR REF) ) (WRITE-CHAR #\SPACE) (PRIN1 F) ) )))))) (DEFUN PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED () "Record and print warnings about any functions referenced in compilation but not defined." ;; 10/25/85 DNG - Improve wording of warning message. ;; 6/04/86 DNG - Use FORMAT with ~{ instead of FORMAT:PRINT-LIST; ;; clean up the programming style. ;; 9/25/86 DNG - Add local function POSSIBLY. ;; 11/19/86 DNG - Show possible names in TICL package. ;; 8/11/88 DNG - Bind *PACKAGE* to match first file where referenced. [SPR 6850] ;; 8/15/88 DNG - Add use of FILE-OPERATION-WITH-WARNINGS so that warnings ;; are recorded correctly at the end of MAKE-SYSTEM. ;; 8/22/88 DNG - Fix above two changes to not error in GET-SOURCE-FILE-NAME. ;; 3/17/89 DNG - Show possible names in the CLOS and TICLOS packages. ;; 4/03/89 DNG - Fix for package attribute which is a list. [SPR 9112] ;; 4/05/89 DNG - Added test (NEQ SYM F). ;; 5/01/89 DNG - Add CONDITIONS, COMMON-LISP, and CLUE to the package search list. ;; Discard any functions that have since become defined. (SETQ FUNCTIONS-REFERENCED (DELETE-IF #'(LAMBDA (X) (COMPILATION-DEFINEDP (CAR X))) (THE LIST FUNCTIONS-REFERENCED)) ) ;; Record warnings about the callers, saying that they called an undefined function. (DOLIST (FREF FUNCTIONS-REFERENCED) (DOLIST (CALLER (CDR FREF)) (IF (NULL SI:FILE-WARNINGS-PATHNAME) ; when called from MAKE-SYSTEM (FILE-OPERATION-WITH-WARNINGS ((OR (AND (SYMBOLP CALLER) (GET-FOR-TARGET CALLER ':COMPILATION-DEFINED)) (IGNORE-ERRORS (GET-SOURCE-FILE-NAME CALLER 'DEFUN))) ':COMPILE NIL) (OBJECT-OPERATION-WITH-WARNINGS (CALLER NIL T) (RECORD-WARNING 'UNDEFINED-FUNCTION-USED ':PROBABLE-ERROR NIL "The undefined function ~S was called." (CAR FREF)))) (OBJECT-OPERATION-WITH-WARNINGS (CALLER NIL T) (RECORD-WARNING 'UNDEFINED-FUNCTION-USED ':PROBABLE-ERROR NIL "The undefined function ~S was called." (CAR FREF)))))) (UNLESS (NULL FUNCTIONS-REFERENCED) ;; Now print messages describing the undefined functions used. (FORMAT T "~&The following functions were referenced but do not seem to be defined:") (WHEN (< *RETURN-STATUS* WARNINGS) (SETQ *RETURN-STATUS* WARNINGS) ) (FLET ((POSSIBLY (F BY) ;; Help the user out if they reference a function that used to ;; be in the GLOBAL package but is now in ZLC or SYS instead. (WHEN (SYMBOLP F) (LET* ((NAME (SYMBOL-NAME F))) ;; Look it up first in the Compiler package because it inherits ;; from all the right places: LISP, TICL, ZLC, and SYS. (DOLIST (P '("COMPILER" "CLOS" "CONDITIONS" "COMMON-LISP" "W" "FS" "TICLOS" "TIME" "CLUE" ; includes XLIB and CLUEI )) (LET ((PKG (FIND-PACKAGE P))) (UNLESS (NULL PKG) (LET ((SYM (FIND-SYMBOL NAME PKG))) (WHEN (AND SYM (EXTERNAL-SYMBOL-P SYM) (OR (FBOUNDP SYM) (GETL SYM '(P1 P2 OPCODE))) (NEQ SYM F)) (LET* ((BY-FILE (OR (AND (SYMBOLP BY) (GET-FOR-TARGET BY ':COMPILATION-DEFINED)) (IGNORE-ERRORS (GET-SOURCE-FILE-NAME BY 'DEFUN)))) (*PACKAGE* (IF (INSTANCEP BY-FILE) (FIND-PACKAGE (LET ((A (SEND BY-FILE :GET :PACKAGE *PACKAGE*))) (IF (CONSP A) (CAR A) A))) *PACKAGE*)) (NEW (OR (GET SYM 'SUPERSEDED) (GET SYM 'SUPERSEDED-BY)))) (FORMAT T "~&~8TPerhaps you want ~S ?" (IF (AND NEW (SYMBOLP NEW)) NEW SYM))) (RETURN) ; from DOLIST ))) )))))) (IF (SEND *STANDARD-OUTPUT* :OPERATION-HANDLED-P :ITEM) (DOLIST (X FUNCTIONS-REFERENCED) (FORMAT T "~& ~S referenced by " (CAR X)) (DO ((L (CDR X) (CDR L)) (LINEL (OR (SEND *STANDARD-OUTPUT* :SEND-IF-HANDLES :SIZE-IN-CHARACTERS) 95.))) ((NULL L)) (WHEN (> (+ (SEND *STANDARD-OUTPUT* :READ-CURSORPOS :CHARACTER) (FLATSIZE (CAR L)) 3) LINEL) (FORMAT T "~% ")) (SEND *STANDARD-OUTPUT* :ITEM 'FUNCTION-NAME (CAR L) "~S" (CAR L)) (WHEN (CDR L) (PRINC ", "))) (POSSIBLY (CAR X) (CADR X)) (FORMAT T "~&")) (DOLIST (X FUNCTIONS-REFERENCED) (FORMAT T "~& ~S referenced by ~{~S~^, ~}~&" (CAR X) (CDR X)) (POSSIBLY (CAR X) (CADR X)) ))))) ;BARF is how the compiler prints an error message. ;SEVERITY should be WARN for a warning (no break), ;DATA for something certainly very wrong in the user's input ;(something which can't be recovered from), ;BARF for an inconsistency in the compiler's data structures (not the user's fault). (DEFUN BARF (EXP REASON SEVERITY) "This is the old way to record a compiler warning. Use COMPILER:WARN now. EXP is a piece of data to include in the message, REASON is a string, and SEVERITY is either WARN, DATA or BARF. BARF means a bug in the compiler, and DATA means a severe error in input. Both BARF and DATA enter the error handler." ;; 1/15/86 - Set *RETURN-STATUS*. ;; 5/28/86 - Delete obsolete use of FUNCTION-BEING-PROCESSED. (COND ((EQ SEVERITY 'WARN) (WARN NIL NIL "~S ~A." EXP REASON)) (T (WHEN (< *RETURN-STATUS* FATAL) (SETQ *RETURN-STATUS* FATAL) ) ; in case debugger used to contine (FERROR NIL "~S ~A" EXP REASON)))) ;This is the modern way for the compiler to issue a warning. (DEFUN WARN (TYPE SEVERITY FORMAT-STRING &REST ARGS) "Record and print a compiler warning. TYPE describes the particular kind of problem, such as FUNCTION-NOT-VALID. SEVERITY is a symbol in the keyword package giving a broader classification; see the source for a list of possible severities. FORMAT-STRING and ARGS are used to print the warning." ;; 3/13/86 DNG - Bind TARGET-PROCESSOR to HOST-PROCESSOR to prevent recursive ;; invocation from difficulties in EVAL-FOR-TARGET. (IF WARN-CATCHER (THROW WARN-CATCHER 'WARN)) (LET (( STATUS (COND ((MEMBER SEVERITY '(:IMPLAUSIBLE :MISSING-DECLARATION :PROBABLE-ERROR :OBSOLETE :MACLISP :IGNORABLE-MISTAKE) :TEST #'EQ) WARNINGS) ((EQ SEVERITY ':FATAL) FATAL) (T ERRORS) ) )) (WHEN (< *RETURN-STATUS* STATUS) (SETQ *RETURN-STATUS* STATUS)) ) (LET-UNLESS-CONSTANT (( *PRINT-CASE* ':UPCASE ) ( TARGET-PROCESSOR HOST-PROCESSOR )) (APPLY 'SI:RECORD-AND-PRINT-WARNING TYPE SEVERITY NIL FORMAT-STRING (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ;; Copy temp area data only; note that ARGS lives in PDL-AREA. ;; on error for nonexistent package refname. (MAPCAR #'(LAMBDA (ARG) (SI:COPY-OBJECT-TREE ARG T 12.)) ARGS))))) ; Severities for WARN include: ; :IMPLAUSIBLE - something that is not intrinsically wrong but is probably due ; to a mistake of some sort. ; :IMPOSSIBLE - something that cannot have a meaning ; :IGNORABLE-MISTAKE - something that is definately illegal, but that has ; the severity of a warning instead of an error. ; :MISSING-DECLARATION - free variable not declared special, usually. ; :PROBABLE-ERROR - something that is an error unless you have changed something else. ; :OBSOLETE - something that you shouldn't use any more ; :VERY-OBSOLETE - similar only more so. ; :MACLISP - something that doesn't work in Maclisp ; :FATAL - something that means the function just can't be made sense of. ; :ERROR - there was an error in reading or macro expansion. ; :IMPLEMENTATION-LIMIT - exceeded the allowed number of something. ; :BUG - the compiler has detected something wrong with itself - not the user's fault.