LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030362. :SYSTEM-TYPE :LOGICAL :VERSION 7. :TYPE "LISP" :NAME "P1DEFS" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758302696. :AUTHOR "REL3" :LENGTH-IN-BYTES 16776. :LENGTH-IN-BLOCKS 17. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;; -*- Mode:Common-Lisp; Package:COMPILER2; Base:10 -*-;;;      RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(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) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;; Copyright (C) 1980, Massachusetts Institute of Technology;;;;   *-----------------------------------------------------------*;;;;   |           --  TI Explorer Lisp Compiler  --               |;;;;   |  This file contains definitions for pass 1.   |;;;;   *-----------------------------------------------------------*;;;  9/19/85 DNG - File QCP1 split into files P1DEFS, P1FUNS, P1HAND, and COMPILE.;;; 10/21/85 DNG - Added *SUPPRESS-DEBUG-INFO*.;;; 12/07/85 DNG - Moved some more variables to here from the DEFS file.;;;  1/31/86 DNG - New special form MAKE-VARIABLE-OBSOLETE.;;;  3/08/86 DNG - Moved a few things to new file MINDEFS.;;;  3/25/86 DNG - Converted from Zetalisp to Common Lisp.;;;    ...;;;  8/08/86 DNG -;;;  9/16/86 DNG - Deleted variable DEAD-CODE-SKIPPED; new function ARBITRARY-SIDE-EFFECTS.;;; 12/15/86 DNG - New macro DYNAMIC-BINDING-HACK .(DEFTYPE T-OR-NIL () '(MEMBER T NIL));;;;===  Declarations of variables used in pass 1  ===;BINDP on pass 1 is T if BIND is called in the current PROG.;It is then consed into the internal form of the PROG, for pass 2's sake.(DEFVAR BINDP);TLEVEL on pass 1 is T if we are at "top level" within the function being compiled,;not within any actual function calls.;If a PROG is seen when TLEVEL is set, the locals of the prog can;be initialized by the entry to the function.(DEFVAR TLEVEL);TLFUNINIT on pass 1 is T if we have already seen a variable initialized to the;result of a function call.  Such initializations can't be done except;by compiled code, and once we have initialized one thing that way;all succeeding variables must be initialized by code as well.;(This applies to SPROGs.  PPROGs are a little different).(DEFVAR TLFUNINIT);FAST-ARGS-POSSIBLE on pass 1 is T if we haven't come across;any argument to this function with a non-NIL initialization.;If this remains T after all the arguments are processed,;then it is an optimization to make top-level prog vars;be initialized at function entry instead of by code.(DEFVAR FAST-ARGS-POSSIBLE);P1VALUE is used during pass 1 to indicate whether a form is being ; compiled for its value or its effect.  It may be one of the following:;   NIL    => the value of the expression is not being used.;   T      => the value is being used [in some arbitrary way].;   D-INDS => the value is only used by testing it for NIL.;   VALUE-ONLY => the value is used, but its address is not significant. [see P1SIMPLE];   DOWNWARD-ONLY => if the value is a function, it is being passed downward ;only. [see P1-DOWNWARD-FUNARG and P1FUNCTION];   SINGLE-VALUE => only a single value is being used.;   INTEGER => the value is expected to be an integer.;   UNKNOWN-NUMBER-OF-VALUES => the context accepts multiple values but does;not know how many values to expect. [used by MAYBE-BREAKOFF-BIND];   TOP-LEVEL-FORM => the current form is at top-level in a file; which implies;that we may end up EVALing it instead of compiling it.;  <a list> => the value is to be returned as the result of the function.(DEFVAR P1VALUE);Set to T during pass 1 if SYS:SELF-MAPPING-TABLE is being used.(DEFVAR SELF-REFERENCES-PRESENT)(DEFVAR TRE-OK) ; is it safe to do Tail Recursion Elimination?(DEFVAR INLINE-EXPANSIONS NIL)  ; list of function calls which are in the process of inline expansion.(DEFVAR EXPRESSION-SIZE)  ; size of function being compiled as the number of objects processed by P1(DEFVAR EXPRESSION-SIZE-LIMIT (TRUNCATE MOST-POSITIVE-FIXNUM 2))  ; point at which to give up on inline expansion because it is too big.(DEFVAR HIDDEN-ACTIVE-VARS NIL)  ; List of list of vars which are currently active but are hidden from   ; view while doing inline expansion of function calls.  Set in function  ; PROCEDURE-INTEGRATION and used in function VAR-CONSIDER-OVERLAP .(DEFVAR *OVERLAP-CANDIDATES* T)  ; When a list, variables to be considered by VAR-CONSIDER-OVERLAP .  ; When T, use ALLVARS instead.(DEFVAR LOCAL-GOTAGS)   ; list of GO tags which are defined at the current level.  ; Same format as GOTAGS, which is all tags lexically visible.;; The following variable is normally 1, but is set to 0 when dead;;  code is being processed.  It is used for adding to use counts;;  so that dead code is not counted.(DEFVAR 1-IF-LIVE-CODE 1)(DEFVAR SAVE-INTERP-DEF NIL) ; set by probe utility; checked by SET-UP-DEBUG-INFO.(DEFVAR *SUPPRESS-DEBUG-INFO* NIL  "Compiler does not record debug info when this is true.")(DEFVAR *WARN-OF-SUPERSEDED-FUNCTIONS-P* NIL ; tested in SUPERSEDED  "If this variable is true, then the compiler warns about the use of Zetalispfunctions which have been superseded by new Common Lisp functions.");;; The following switches are to make it possible to disable the major ;;; new optimizations if necessary to get around a bug.   They may be ;;; removed in the future after the compiler becomes stable enough.(EXPORT '(TRE-ENABLE INLINE-ENABLE PROPAGATE-ENABLE))(DEFVAR TRE-ENABLE T "Enable Tail Recursion Elimination optimization in the compiler")(DEFVAR INLINE-ENABLE T "Enable inline expansion of function calls")(DEFVAR PROPAGATE-ENABLE T "Enable value propagation optimization")(DEFVAR SIDE-EFFECT-ENABLE NIL "Enable use of ALTERED-VAR-SET for testing for side-effects.");;; The following 5 variables are all integers which are used as ;;;  bit vectors representing a set of variables.  Each bit corresponds;;;  to a particular local variable.(PROCLAIM '(TYPE INTEGER  VAR-BIT ALTERED-VAR-SET USED-VAR-SET PROPAGATE-VAR-SET SUBST-VAR-SET))(DEFVAR VAR-BIT) ; bit mask for next local variable to be defined(DEFVAR ALTERED-VAR-SET) ; set of local variables altered in current expression(DEFVAR USED-VAR-SET)    ; set of local variables used in current expression(DEFVAR PROPAGATE-VAR-SET) ; variables which can be replaced by their initial value(DEFVAR SUBST-VAR-SET) ; variables used in propagatable initial values(DEFCONSTANT SPECIAL-VAR-BIT 1 "Bit mask corresponding to a special or instance variable reference.")(DEFCONSTANT DATA-ALTERATION-BIT 2 "Bit mask corresponding to destructive operation")(DEFCONSTANT GLOBAL-SIDE-EFFECTS (LOGIOR SPECIAL-VAR-BIT DATA-ALTERATION-BIT))(DEFPARAMETER DONT-PROPAGATE-INTO-LOOP 0) ; a subset of PROPAGATE-VAR-SET#-compiler:debug (PROCLAIM '(INLINE ARBITRARY-SIDE-EFFECTS))(DEFUN ARBITRARY-SIDE-EFFECTS ()  ;; The function is called when generating a call to some arbitrary function  ;; which must be assumed to reference special variables or have other  ;; side-effects.  ;;  9/16/86 DNG - Original.  (SETF USED-VAR-SET    (LOGIOR USED-VAR-SET    GLOBAL-SIDE-EFFECTS))  (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET GLOBAL-SIDE-EFFECTS))  (VALUES))(DEFVAR MAX-LEXICAL-CLOSURE-COUNT 0)(DEFVAR %PUSH-DONE) ; used to disable DOLIST optimization if any %PUSH in the body.(DEFVAR MACRO-CONS-AREA) ; memory area for macro expansions -- bound in PASS1, used in PRE-OPTIMIZE(DEFVAR *LAST-ADDRESS-READ* NIL) ; set in COMPILE-STREAM, tested in PRE-OPTIMIZE(EVAL-WHEN ( LISP:COMPILE )  (PROCLAIM '(INLINE KEYWORDP)) )#| Don't include this automatically because it slows things down.(if-debug       ;; in order to use the debugger on the compiler, we need to      ;; prevent it from trying to print circular lists.  (advise si:print-object :around trap-circular-var-list nil    (let ((a (first arglist)) b )      (cond ( (and (consp a)   (eq (first a) 'LOCAL-REF)   (consp (setq b (second a)))   (rest2 b) )     (apply #'si:print-object (cons (list (first a) (list (first b) '***))    (rest1 arglist) ) ) )    ( t :do-it )    ))) )|#;;;;       Macros used in pass 1;Return T if OBJECT is something quoted.(PROCLAIM '(INLINE QUOTEP))(DEFUN QUOTEP (OBJECT)    (AND (NOT (ATOM OBJECT))         (EQ (CAR OBJECT) 'QUOTE)))(defmacro defoptimizer (function-to-optimize optimizer-name&optional ((&rest optimizes-into)) arglist &body body)  "(defoptimizer foo foo-optimizer (optfoo1 optfoo2) (form)     (if (eq (cadr form) 'foo)         `(and (optfoo . ,(cadr form))               (optfoo2 . (caddr form)))        form))OR\(defoptimizer foo common-foo-optimizer (optfoo1 optfoo2))"  (unless optimizer-name    (setq optimizer-name (string-append function-to-optimize "-OPTIMIZER"))    (if (find-symbol optimizer-name) (setq optimizer-name (gentemp (string-append optimizer-name "-")))      (setq optimizer-name (intern optimizer-name))))  (if (null arglist)      `(add-optimizer ,function-to-optimize ,optimizer-name . ,optimizes-into)    `(progn (add-optimizer ,function-to-optimize ,optimizer-name . ,optimizes-into)    (defun ,optimizer-name ,arglist      (declare (function-parent ,optimizer-name defoptimzer))      . ,body))))(defmacro defcompiler-synonym (function synonym-function)  "Make the compiler substitute SYNONYM-FUNCTION for FUNCTION when compiling.eg (defcompiler-synonym plus +)"  `(defoptimizer ,function ,(intern (string-append function "-TO-" synonym-function))                           (,synonym-function) (form)     (cons ',synonym-function (cdr form))))(DEFUN ADD-POST-OPTIMIZER (&QUOTE TARGET-FUNCTION OPTIMIZER-NAME &REST OPTIMIZED-INTO)  "Add OPTIMIZER-NAME to TARGET-FUNCTION's list of optimizers applied after P1."  ;; This is similar in purpose to ADD-OPTIMIZER (defined in SYS;QCDEFS), but  ;; ADD-OPTIMIZER declares optimizers to be applied to the original source  ;; forms, while ADD-POST-OPTIMIZER declares optimizers to be applied after  ;; the form's arguments have been processed by P1.  In other words,  ;; ADD-POST-OPTIMIZER is used for optimizers that should be applied bottom up  ;; instead of top down.   This is usually used for optimizers which fold  ;; constant arguments so that folded constants can be propagated up the  ;; tree.  Note that constant arguments will always be a (QUOTE value)  ;; form and a constant result must be returned that way also.  ;;  ;;  5/12/86 DNG - Changed to use new function PUSH-NEW-PROPERTY.  ;;  ;; First, remove function from old OPTIMIZERS property.  #+compiler:debug ; only needed during development.  (LET ((OPTS (GET TARGET-FUNCTION 'OPTIMIZERS)))    (IF (ATOM OPTS)(WHEN (EQ OPTIMIZER-NAME OPTS)  (REMPROP TARGET-FUNCTION 'OPTIMIZERS))      (WHEN (MEMBER OPTIMIZER-NAME OPTS :TEST #'EQ)(SETF (GET TARGET-FUNCTION 'OPTIMIZERS)      (DELETE OPTIMIZER-NAME (THE LIST OPTS) :TEST #'EQ)))) )  ;; Now, add function to POST-OPTIMIZERS property.  (PUSH-NEW-PROPERTY TARGET-FUNCTION OPTIMIZER-NAME 'POST-OPTIMIZERS (CONSP OPTIMIZER-NAME))  (DOLIST (INTO OPTIMIZED-INTO)    (PUSH-NEW-PROPERTY TARGET-FUNCTION INTO 'OPTIMIZED-INTO))  OPTIMIZER-NAME )(DEFVAR *LOOP-LEVEL* 0)(DEFVAR *VAR-LEVEL-COUNTS* NIL)(PROCLAIM '(INLINE LOOP-WEIGHTED-INCREMENT))(DEFUN LOOP-WEIGHTED-INCREMENT (LOOP-LEVEL)  (+ 6 (* (THE INTEGER LOOP-LEVEL)  (THE INTEGER       (+ 3 (- (OPT-SPACE OPTIMIZE-SWITCH)       (OPT-SPEED OPTIMIZE-SWITCH)))))))(DEFMACRO DYNAMIC-BINDING-HACK (BINDP VLIST) ; used by P1LET etc.  ;; When a LET contains dynamic binding (i.e. BIND or %BIND) and the context  ;; requires the result to be an arbitrary number of multiple values  ;; with the number of values on the stack, then P2LET-INTERNAL needs to be  ;; given a local variable slot in which it can store the SPECIAL-PDL-INDEX  ;; since the normal technique of leaving it on the stack won't work when  ;; it would be at an unknown depth.  [ref SPR 2271]  ;;  ;; 12/15/86 DNG - Original.  Previously, MAYBE-BREAKOFF-BIND broke the LET  ;;body off as an :INTERNAL function so that the unbinding would  ;;be done by the function return.  (DECLARE (UNSPECIAL BINDP))  `(WHEN (AND ,BINDP (EQ P1VALUE 'UNKNOWN-NUMBER-OF-VALUES))     ;; provide a local variable slot for P2LET-INTERNAL to save the SPECIAL-PDL-INDEX      (PUSH-END (FIRST (P1SBIND '((SPECIAL-PDL-INDEX (UNDEFINED-VALUE)))       'FEF-ARG-INTERNAL-AUX NIL NIL NIL))       ,VLIST)     (SETF ,BINDP (ALTERING-VAR (P1VAR 'SPECIAL-PDL-INDEX)))))(DEFCONSTANT RETURN-THE-TYPE #\?) ; an arbitrary flag that cannot be a type name(DEFSUBST TYPE-OF-EXPRESSION ( FORM )  "Given a Lisp form that has been processed by P1, return a type specifiercorresponding to the set of values the form can produce."  (EXPR-TYPE-P FORM RETURN-THE-TYPE) )(DEFSUBST INVULNERABLE-EXPRESSION-P (FORM)  ;; Given a form that has been processed by P1, return true if the expression's  ;; value cannot be altered by the side-effects of other expressions.  This  ;; assumes that global function definitions will be altered only at top level,  ;; not in the middle of an expression that uses the function.  ;;  9/18/86 - Original.  (AND (CONSP FORM)       (MEMBER (FIRST FORM)       '(QUOTE FUNCTION BREAKOFF-FUNCTION LEXICAL-CLOSURE)       :TEST #'EQ)))(DEFMACRO OPTIMIZE-PATTERN ( TEMPLATE REPLACEMENT &OPTIONAL (CONDITION T)    &ENVIRONMENT ENV)  "Cause calls that match TEMPLATE to be optimized to REPLACEMENT.The TEMPLATE looks like a function call form except that each argument is represented by one of the following:   * A type name symbol, indicating that the optimization can be done     if the argument is known to always be of that type.  [This should      not be confused with the type the function expects.]  Note that      T can be used to say that the argument can be anything.   * A QUOTE form, which says the argument must be that constant value.   * A #'f form says the argument may be either #'f or 'f.   * The form (PASSES p) calls function p on the argument form to test     whether it is acceptable.The REPLACEMENT is a list whose first element is the new function name, and the remaining elements indicate the new arguments by one of the following:   * An integer means to insert that numbered argument from the original form.   * A QUOTE or FUNCTION form is used as the actual argument.For example, the declaration (OPTIMIZE-PATTERN (FOO T LIST) (BAR 2 1))would cause (FOO X (THE LIST Y)) to be optimized to (BAR (THE LIST Y) X)."  ;; The optional third argument, CONDITION, may be used to specify an  ;; additional requirement; it is a Lisp expression to be evaluated.  The  ;; optimization is not performed when it evaluates to NIL.  In order to avoid  ;; the overhead of using the evaluator, it is best for this to be either a  ;; special variable symbol or a function call without any arguments (or a  ;; macro that expands to one of these since the macro expansion is done only  ;; once).  ;;  ;;Revision:  ;;  7/17/86 DNG - Support optional CONDITION argument; make sure constants in  ;;the template are QUOTEd.  (LET (( PERMUTATIONS NIL )( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))    (DO (( RS REPLACEMENT (REST RS) ))((NULL RS))      (WHEN (FIXNUMP (FIRST RS))(LET (( COMPARE-WITH NIL ))  (DOLIST ( OTHER (REST RS) )    (WHEN (AND (FIXNUMP OTHER)       (< OTHER (FIRST RS)))      ;; Going to change the order of evaluation; better make      ;; sure that is safe to do.      (PUSH OTHER COMPARE-WITH) ))  (UNLESS (NULL COMPARE-WITH)    (PUSH (CONS (FIRST RS) COMPARE-WITH)  PERMUTATIONS) ) )))    (LABELS (( PROCESS-CONDITION (CONDITION)(COND ((ATOM CONDITION)       CONDITION)      ((QUOTEP CONDITION)       (AND (SECOND CONDITION) T))      (T (LET ((EXP (MACROEXPAND-1 CONDITION ENV)))   (COND     ((EQ CONDITION EXP)      CONDITION)     ((AND (NULL (CDR CONDITION))   (CONSP EXP)   (CDR EXP)   (NOT (QUOTEP EXP))   (FUNCTIONP (CAR CONDITION)))      ;; FUNCALL a DEFSUBST instead of expanding it.      CONDITION)     (T (PROCESS-CONDITION EXP)) )))) ))      (LET (( CONDITION-EXPRESSION (PROCESS-CONDITION CONDITION) )    ( TEMPLATE-ARGS (MAPCAR #'(LAMBDA (X)(IF (OR (KEYWORDP X)(AND (NOT (SYMBOLP X))     (NOT (CONSP X))))    `(QUOTE ,X)  X))    (REST TEMPLATE)) ))(IF (AND (NULL PERMUTATIONS) (EQ CONDITION-EXPRESSION 'T))    `(ADD-OPTIMIZE-PATTERN ',(FIRST TEMPLATE) ',TEMPLATE-ARGS ',REPLACEMENT)  `(ADD-OPTIMIZE-PATTERN ',(FIRST TEMPLATE) ',TEMPLATE-ARGS ',REPLACEMENT ',PERMUTATIONS ',CONDITION-EXPRESSION)) ))))FORMS (SECOND FORM) (THIRD FORM))   (NO-SIDE-EFFECTS-P (SECOND FORM))   (<= (OPT-SAFETY OPTIMIZE-SWITCH)       (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)))      (PROGN (DISCARD (THIRD FORM))     (IF (EQ (FIRST FORM) 'LOGXOR) (PROGN (DISCARD (SECOND FORM))'(QUOTE 0)); (LOGXOR x x) ==> 0       (SECOND FORM))); (LOGIOR x x) ==> x    FORM) )(ADD-POST-OPTIMIZER LOGAND LOGAND-OPT)(DEFUN LOGAND-OPT ( FORM )  ;; 12/27/84 DNG - Original version written.  ;;  4/23/85 DNG - Check SAFETY.  (LET ((ARG2 (QUOTE-NUMBER (THIRD FORM))))    (COND ( (NULL ARG2) FORM )  ( (> (OPT-SAFETY OPTIMIZE-SWITCH)       (OPT-SP