;;; -*- 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) 1985-1989 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 .
;;;------------------ The following done after Explorer release 3.0 ------
;;;  7/06/87 DNG - Add OVERLAP argument to DYNAMIC-BINDING-HACK to fix SPR 5566.
;;;  7/22/87 DNG - Deleted *LAST-ADDRESS-READ*.
;;;------------------ The following done for Explorer release 5.0 ------
;;;  8/04/88 DNG - (INVULNERABLE-EXPRESSION-P '(QUOTE-LOAD-TIME-EVAL ...)) => T
;;;------------------ The following done for Explorer release 6.0 ------
;;;  4/10/89 DNG - Deleted obsolete variable TLFUNINIT .
;;;  4/26/89 DNG - Delete obsolete variable FAST-ARGS-POSSIBLE .
;;;		Added new variable *LOOP-VAR-BIT* .
;;;  5/03/89 DNG - New function VALIDATE-TYPES-P .


(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)


;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 Zetalisp
functions 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.")
(DEFVAR SETQ-PROPAGATE-ENABLE T "Enable propagation of variables initialized by a SETQ.") ; 5/7/89

;;; 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 *LOOP-VAR-BIT*) ; value of VAR-BIT before the innermost loop or conditional form.
  ;; Local variables with a bit greater than or equal to this have been bound 
  ;; within the innermost loop.
  ;; Zero implies unconditional code.

(EVAL-WHEN ( LISP:COMPILE )
  (PROCLAIM '(INLINE KEYWORDP)) )


;;;;       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)))

(DEFSUBST VALIDATE-TYPES-P ()
  ;; Should code be generated to perform run-time checks to make sure that 
  ;; the data is consistent with the program's type declarations?
  ;;  5/03/89 DNG - Original.
  (> (- (OPT-SAFETY OPTIMIZE-SWITCH)
	(OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))
     1))

(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 &OPTIONAL OVERLAP) ; 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.
  ;;  7/06/87 DNG - Add OVERLAP argument to fix SPR 5566.
  (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 (LET ,(AND OVERLAP
				 `((*OVERLAP-CANDIDATES*
				     (IF (LISTP *OVERLAP-CANDIDATES*)
					 *OVERLAP-CANDIDATES*
				       ,OVERLAP))))
			(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 specifier
corresponding 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.
  ;;  8/04/88 DNG - Return true for QUOTE-LOAD-TIME-EVAL .
  ;;  4/22/89 DNG - FUNCTION is not invulnerable in Scheme mode.
  (AND (CONSP FORM)
       (MEMBER (FIRST FORM)
	       '(QUOTE FUNCTION BREAKOFF-FUNCTION LEXICAL-CLOSURE QUOTE-LOAD-TIME-EVAL)
	       :TEST #'EQ)
       (NOT (AND (EQ (FIRST FORM) 'FUNCTION) (COMPILING-SCHEME-P)))))

(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)) ))))

;; This is being considered for inclusion in ANSI Common Lisp.
(export '(define-optimizer))
(defmacro define-optimizer (name arglist &body body)
  ;;  4/24/89 DNG - Original.
  (let ((whole 'form))
    (when (eq (first arglist) '&whole)
      (setq whole (second arglist))
      (setq arglist (cddr arglist)))
    `(defoptimizer ,name ,(intern (concatenate 'string (SYMBOL-NAME NAME) "~OPTIMIZER")
				  (symbol-package name))
		   nil (,whole &optional (sys::*macroenvironment* *local-environment*))
       (declare (unspecial sys::*macroenvironment*))
       sys::*macroenvironment*
       (or (destructuring-bind ,arglist (cdr ,whole)
	     . ,body)
	   ,whole))))