;;;; -*- 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 (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. ;;;; *-----------------------------------------------------------* ;;;; | -- TI Explorer Lisp Compiler -- | ;;;; | This file contains the peephole and branch optimizer. | ;;;; *-----------------------------------------------------------* ;;; Feb. 1984 - Version 98 from MIT via LMI. ;;; June 1984 - TI modifications by D.N.G. to merge code preceding two branches ;;; to the same place or two dead ends, to take care of some missed ;;; optimizations when blocks are merged, and to introduce use of ;;; IF-DEBUG macro to make diagnostic code conditional. ;;; 08/07/84 - From MIT patch 98.57, fix PEEP-ONE-SPOT not hang in infinite ;;; when looking at a branch to itself. ;;; 01/14/85 - Fix to not overlook some cross-jumping opportunities. ;;; 02/04/85 - Add a couple of new optimizations to PEEP-ONE-SPOT; ;;; simplified PEEP-PRINT-COUNTERS and PEEP-CLEAR-COUNTERS. ;;; 03/08/85 - Use COPY-LIST when an instruction is duplicated to allow ;;; later modification. ;;; 03/27/85 - Put IF-DEBUG around some INCF of debugging counters. ;;; 04/17/85 - Fix BRANCH-TESTING-CONSTANT optimization to not skip over ;;; UNBIND instructions. [bug 1587] ;;; 07/10/85 - Began modifications for release 3. ;;; 07/26/85 - ;;; 08/21/85 - POPPDL is an Aux-op for release 3. ;;; 09/06/85 - Fix a loophole in branch path optimization. [SPR 641] ;;; 01/29/86 - POPPDL instruction renamed to POP-PDL. ;;; ... ;;; 9/22/86 ;;; 1/15/87 CLM - Fixed BRANCH-OR-POP-TESTING-CONSTANT opt. to not be invoked for the ;;; Store instructions (e.g. SET-NIL). ;;; 1/16/87 DNG - Use EQ instead of EQL for testing MISC-LAP-CODE. ;;; 1/22/87 - Combine adjacent UNBIND aux-ops. ;;; 2/06/87 DNG - Fix PEEP-INDICATORS-USED-P for LEXICAL-UNSHARE and UNBIND. ;;; 2/09/88 DNG - Include enhanced version of PRINT-CODE-ARRAY. (DEFPARAMETER PEEP-TRACE NIL "T => print out each bunch of instructions that are going to be optimized.") (DEFMACRO PEEP-TRACE (COUNTER-NAME &OPTIONAL BRANCH-TARGET-INSN) `(PROGN (INCF PEEP-NUMBER-OF-OPTIMIZATIONS) (IF-DEBUG (INCF ,COUNTER-NAME) (AND PEEP-TRACE (PEEP-TRACE-1 ',COUNTER-NAME X Y Z INDEX ,BRANCH-TARGET-INSN))))) (if-debug (DEFUN PEEP-TRACE-1 (COUNTER-NAME X Y Z INDEX BRANCH-TARGET-INSN) (PKG-BIND "COMPILER" (SEND *STANDARD-OUTPUT* :FRESH-LINE) (FORMAT T "~S: " COUNTER-NAME) (WHEN X (FORMAT T "~S " X)) (FORMAT T "~D: ~S" INDEX Y) (WHEN BRANCH-TARGET-INSN (FORMAT T "[ -> ~S ]" BRANCH-TARGET-INSN)) (FORMAT T " ~S" Z))) (DEFPARAMETER SET-INDS-NOT-USED 0) (DEFPARAMETER TWO-BRANCHES-TO-SAME-PLACE 0) (DEFPARAMETER DEAD-CODE 0) (DEFPARAMETER TWO-BRANCHES-SAME-IND 0) (DEFPARAMETER MOVE-BRANCH-MOVE 0) (DEFPARAMETER BRANCH-TESTING-CONSTANT 0) (DEFPARAMETER BRANCH-OR-POP-TESTING-CONSTANT 0) (DEFPARAMETER PUSH-NIL-OR-0-THEN-POP 0) (DEFPARAMETER PUSH-THEN-MOVE-FROM-PDL 0) (DEFPARAMETER SET-INDS-ALREADY-SET 0) (DEFPARAMETER POP-THEN-PUSH 0) (DEFPARAMETER BRANCH-.+1 0) (DEFPARAMETER BRANCH-TO-BRANCH 0) (DEFPARAMETER BRANCH-ACROSS-BRANCH 0) (DEFPARAMETER BRANCH-TO-RETURN 0) (DEFPARAMETER BRANCH-TO-BRANCH-NOT-TAKEN 0) (DEFPARAMETER BRANCH-NOT-NOT 0) (DEFPARAMETER INSERT-COUNT 0) (DEFPARAMETER TWO-POPS 0) (DEFPARAMETER BRANCH-TO-SET-INDS-ALREADY-SET 0) (DEFPARAMETER MATCHING-CODE-PRECEDES-BRANCH-AND-TARGET 0) (DEFPARAMETER TWO-PUSH-NILS 0) (DEFPARAMETER BRANCH-TO-BRANCH-BACK 0) (DEFPARAMETER PEEP-ONE-SPOT 0) (DEFPARAMETER PEEP-OFF-QUEUE 0) (DEFPARAMETER MATCHING-CODE-PRECEDES-DEAD-ENDS 0) (DEFPARAMETER SWAP-COMMUTATIVE 0) ; added 2/4/85 (DEFPARAMETER POP-BEFORE-RETURN 0) ; added 2/4/85 (DEFPARAMETER TWO-IDENTICAL-RETURNS 0) ;added 3/21/86 (DEFPARAMETER PEEP-TOTAL-TIME 0) (DEFPARAMETER IMMED-INSN 0) ; added 5/12/86 (DEFPARAMETER EQ-T 0) ; added 5/12/86 (DEFPARAMETER UNBIND-FOLLOWED-BY-RETURN 0) ; added 5/29/86 (DEFPARAMETER CALL-N-TO-CALL 0) ; added 10/20/86 (DEFPARAMETER PUSH-THEN-CALL 0) (DEFPARAMETER TWO-LEXICAL-UNSHARE-ALL 0) (DEFPARAMETER MOVEM-BEFORE-RETURN 0) (DEFPARAMETER TEST-THEN-BRANCH-ON-SAME-CONDITION 0) ;added 4/11/88 (DEFPARAMETER TEST-THEN-BRANCH 0) ;added 4/11/88 (DEFCONSTANT PEEP-COUNTER-NAMES '(SET-INDS-NOT-USED TWO-BRANCHES-TO-SAME-PLACE DEAD-CODE TWO-BRANCHES-SAME-IND MOVE-BRANCH-MOVE BRANCH-TESTING-CONSTANT BRANCH-OR-POP-TESTING-CONSTANT PUSH-NIL-OR-0-THEN-POP PUSH-THEN-MOVE-FROM-PDL SET-INDS-ALREADY-SET POP-THEN-PUSH POP-BEFORE-RETURN SWAP-COMMUTATIVE BRANCH-.+1 BRANCH-TO-BRANCH BRANCH-ACROSS-BRANCH BRANCH-TO-RETURN BRANCH-TO-BRANCH-NOT-TAKEN BRANCH-NOT-NOT INSERT-COUNT TWO-POPS BRANCH-TO-SET-INDS-ALREADY-SET MATCHING-CODE-PRECEDES-BRANCH-AND-TARGET TWO-PUSH-NILS BRANCH-TO-BRANCH-BACK PEEP-ONE-SPOT PEEP-OFF-QUEUE MATCHING-CODE-PRECEDES-DEAD-ENDS TWO-IDENTICAL-RETURNS IMMED-INSN EQ-T UNBIND-FOLLOWED-BY-RETURN CALL-N-TO-CALL PUSH-THEN-CALL TWO-LEXICAL-UNSHARE-ALL MOVEM-BEFORE-RETURN TEST-THEN-BRANCH-ON-SAME-CONDITION TEST-THEN-BRANCH)) (DEFUN PEEP-PRINT-COUNTERS () (DOLIST (COUNTER PEEP-COUNTER-NAMES) (FORMAT T "~&~5D ~A" (SYMBOL-VALUE COUNTER) COUNTER)) (FORMAT T "~&PEEP-TOTAL-TIME = ~D msec." PEEP-TOTAL-TIME)) (DEFUN PEEP-CLEAR-COUNTERS () (DOLIST (COUNTER PEEP-COUNTER-NAMES) (SET COUNTER 0)) (SETQ PEEP-TOTAL-TIME 0)) (DEFUN PRINT-CODE-ARRAY (&OPTIONAL X Y &AUX CODE-ARRAY (S T) DBI) ;; display code array for debug purposes ;; 1/14/85 - allow passing starting and ending index as arguments. ;; 4/7/86 CLM - this has patrick's change for arrays ;; 7/29/86 DNG - Modify to not choke on (QUOTE-VECTOR ). ;; 8/17/87 DNG - Added comment with name of misc-op or value of constant ;; when represented as numbers. (DECLARE (ARGLIST &OPTIONAL START END)) (SETQ CODE-ARRAY (IF (ARRAYP X) X QCMP-OUTPUT)) (WHEN (AND (EQ (CAR (AREF CODE-ARRAY 0)) 'DEBUG-INFO) (ARRAYP (CDR (AREF CODE-ARRAY 0)))) (SETQ DBI (CDR (AREF CODE-ARRAY 0)))) (LOOP FOR INDEX FROM (IF (FIXNUMP X) X 0) TO (IF (FIXNUMP Y) Y (- (ARRAY-ACTIVE-LENGTH CODE-ARRAY) 1)) DO (LET ((ELEMENT (AREF CODE-ARRAY INDEX))) (UNLESS (NULL ELEMENT) (FORMAT S "~%~5D: " INDEX) (IF (ATOM ELEMENT) (FORMAT S "~A" ELEMENT) (PROGN (FORMAT S " (") (DO* ((ELEMENT ELEMENT (CDR-SAFE ELEMENT)) (X (IF (CONSP ELEMENT) (CAR ELEMENT) ELEMENT) (IF (CONSP ELEMENT) (CAR ELEMENT) ELEMENT))) ((NULL ELEMENT)) (COND ((NULL X) (FORMAT S " NIL")) ((ATOM X) (FORMAT S " ~A" X)) ((AND (EQ (FIRST X) 'QUOTE-VECTOR) (QUOTEP (SECOND X))) (LET ((Y (SECOND (SECOND X)))) (FORMAT T (COND ((NUMBERP Y) " '~D") ((STRINGP Y) " '~S") (T " '~A")) Y))) ((AND (EQ (FIRST X) 'QUOTE-VECTOR) (CONSP (SECOND X)) (EQ (FIRST (SECOND X)) 'FUNCTION)) (FORMAT S " #'~A" (SECOND (SECOND X)))) ((AND (= 2 (LENGTH X)) (ATOM (SECOND X))) (FORMAT S " (~A ~A)" (FIRST X) (SECOND X))) ((CONSP (FIRST X)) (FORMAT S " ( )")) (T (FORMAT S " (~A )" (FIRST X))))) (FORMAT S " )") (WHEN (> (LENGTH ELEMENT) 2) (LET ((ARG (THIRD ELEMENT))) (COND ((AND (EQ (FIRST ELEMENT) 'MISC) (INTEGERP ARG)) (LET ((NAME (AREF (MISC-OP-NAME-TABLE) ARG))) (UNLESS (NULL NAME) (FORMAT S " ; ~A" NAME)))) ((AND (CONSP ARG) (EQ (FIRST ARG) 'QUOTE-VECTOR) (INTEGERP (SECOND ARG))) (LET ((VALUE (NTH (- (SECOND ARG) (QLEVAL 'QUOTE-BASE T)) QUOTE-LIST))) (CASE (CAR-SAFE VALUE) (QUOTE (FORMAT S " ; '~S" (SECOND VALUE))) (FUNCTION (FORMAT S " ; #'~S" (SECOND VALUE))) (T (FORMAT S " ; ~S" VALUE))))) ((AND (CONSP ARG) (EQ (FIRST ARG) 'LOCBLOCK) (INTEGERP (SECOND ARG)) DBI) (LET ((NAME (NTH (SECOND ARG) (SI:GET-DEBUG-INFO-FIELD DBI :LOCAL-MAP)))) (UNLESS (NULL NAME) (FORMAT S " ; ~A" NAME)))) ((AND (CONSP ARG) (EQ (FIRST ARG) 'ARG) (INTEGERP (SECOND ARG)) DBI) (LET ((NAME (LET ((COUNT 0)) (DOLIST (AAA (SI:DBI-ARGLIST DBI) NIL) (IF (AND (ATOM AAA) (MEMBER AAA LAMBDA-LIST-KEYWORDS :TEST #'EQ)) (WHEN (MEMBER AAA '(&REST &KEY &AUX) :TEST #'EQ) (RETURN NIL)) (IF (= COUNT (SECOND ARG)) (RETURN (IF (ATOM AAA) AAA (FIRST AAA))) (INCF COUNT))))))) (UNLESS (NULL NAME) (FORMAT S " ; ~A" NAME)))) )))))))) (VALUES)) ) ; end of if-debug ;; The compiler can be run before this function is loaded. (OR (FBOUNDP 'TIME:MICROSECOND-TIME) (FSET 'TIME:MICROSECOND-TIME '(LAMBDA () 0))) (DEFPARAMETER TRACE-PEEP-SAVINGS NIL "T => print how many instructions are saved by PEEP in each function compiled.") (DEFVAR PEEP-INSNS-SAVED :UNBOUND "Accumulates count of instructions saved by PEEP within one function.") (DEFVAR PEEP-NUMBER-OF-OPTIMIZATIONS :UNBOUND "Accumulates number of optimizations made by PEEP within one function.") (DEFVAR PEEP-CODE-START-INDEX :UNBOUND "Within PEEP, the index in PEEP-CODE-ARRAY of the beginning of the actual code.") (DEFVAR PEEP-CODE-ARRAY :UNBOUND "The array whose elements contain the code to be optimized by PEEP. This is actually the function definition of QCMP-OUTPUT.") (DEFVAR PEEP-TAG-ALIST :UNBOUND "The alist which keeps track of all tags in the function PEEP is working on. Each element looks like (TAG USE-COUNT INDEX). INDEX is the index in PEEP-CODE-ARRAY where the tag appears.") (DEFPARAMETER PEEP-TWICE-FLAG NIL "T => run PEEP twice on each function, and print out if it finds anything the second time. This mode is used to verify that the queueing mechanism does its job.") (DEFUN PEEP-INSTRUCTION-P (CODE-ELEMENT) (AND (CONSP CODE-ELEMENT) (NOT (MEMBER (CAR CODE-ELEMENT) '(COMMENT PARAM NO-DROP-THROUGH RESTART-TAG) :TEST #'EQ)))) (DEFUN PEEP-LIST-AT-INDEX (INDEX) (%MAKE-POINTER DTP-LIST (LOCF (AREF PEEP-CODE-ARRAY INDEX)))) (DEFVAR PEEP-INDEX-LIST NIL "List of indices saved temporarily so they will be relocated if tags are inserted.") (DEFVAR PEEP-DEAD-ENDS NIL "Indexes of instructions seen so far that don't drop through") (DEFSUBST PEEP-BRANCH-TAG-P (ITEM-ARG) ; is the arg valid as a branch tag? (LET ((ITEM ITEM-ARG)) (AND (NOT (NULL ITEM)) (ATOM ITEM) (NOT (GET ITEM 'PEEP-KEEP))))) (DEFMACRO PEEP-UPDATING-INDEX (INDEX &BODY BODY) "Execute BODY, relocating the index in the variable INDEX if any tags are inserted by BODY." `(LET ((PEEP-INDEX-LIST (CONS ,INDEX PEEP-INDEX-LIST))) (PROG1 (PROGN . ,BODY) (SETQ ,INDEX (CAR PEEP-INDEX-LIST))))) (DEFUN PEEP (PEEP-CODE-ARRAY &OPTIONAL FUNCTION-NAME) (LET* ((PEEP-CODE-START-INDEX (1+ (POSITION 'PROGSA (THE LIST (G-L-P PEEP-CODE-ARRAY)) :TEST #'EQ))) (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T) PEEP-TAG-ALIST PEEP-INDEX-LIST (PEEP-NUMBER-OF-OPTIMIZATIONS 0) (PEEP-INSNS-SAVED 0) (INSN-COUNT 0)) (WHEN TRACE-PEEP-SAVINGS (DOLIST (ELT (PEEP-LIST-AT-INDEX PEEP-CODE-START-INDEX)) (COND ((ATOM ELT)) ((MEMBER (CAR ELT) '(RESTART-TAG NO-DROP-THROUGH PARAM COMMENT) :TEST #'EQ)) (T (INCF INSN-COUNT))))) (LET ( #+compiler:debug (START-TIME (TIME:MICROSECOND-TIME))) (SETQ PEEP-TAG-ALIST (PEEP-TAGS)) (PEEP-WHOLE-FUNCTION) #+compiler:debug (INCF PEEP-TOTAL-TIME (ASH (- (TIME:MICROSECOND-TIME) START-TIME) -10))) (WHEN TRACE-PEEP-SAVINGS (FORMAT T "~&~D instructions saved out of ~D in ~S; ~D optimizations." PEEP-INSNS-SAVED INSN-COUNT FUNCTION-NAME PEEP-NUMBER-OF-OPTIMIZATIONS)) #+compiler:debug (WHEN PEEP-TWICE-FLAG (DOTIMES (I 10) (LET ((PEEP-INSNS-SAVED 0) (PEEP-NUMBER-OF-OPTIMIZATIONS 0)) (PEEP-WHOLE-FUNCTION) (IF (ZEROP PEEP-NUMBER-OF-OPTIMIZATIONS) (RETURN) (FORMAT T "~&~D instructions saved the ~:R time in ~S; ~D optimizations." PEEP-INSNS-SAVED (+ I 2) FUNCTION-NAME PEEP-NUMBER-OF-OPTIMIZATIONS))))))) (DEFVAR PEEP-SCANNING-INDEX :UNBOUND "Index at which PEEP-WHOLE-FUNCTION is scanning for optimizations. There is no point in queueing any index greater than this because PEEP-WHOLE-FUNCTION is going to get there anyway.") (DEFVAR PEEP-QUEUE :UNBOUND "List of indices which should be reconsidered by PEEP-ONE-SPOT.") (DEFUN PEEP-QUEUE (INDEX) (OR (> INDEX PEEP-SCANNING-INDEX) (MEMBER INDEX PEEP-QUEUE :TEST #'EQ) (PUSH INDEX PEEP-QUEUE))) (DEFUN PEEP-WHOLE-FUNCTION () (LET ((PEEP-QUEUE NIL) (PEEP-DEAD-ENDS NIL)) (DO ((PEEP-SCANNING-INDEX PEEP-CODE-START-INDEX)) ((>= PEEP-SCANNING-INDEX (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY))) (IF (CONSP (AREF PEEP-CODE-ARRAY PEEP-SCANNING-INDEX)) (SETQ PEEP-SCANNING-INDEX (PEEP-ONE-SPOT PEEP-SCANNING-INDEX)) (INCF PEEP-SCANNING-INDEX))) (DO ((PEEP-SCANNING-INDEX (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY))) ((NULL PEEP-QUEUE)) (IF-DEBUG (INCF PEEP-OFF-QUEUE)) (PEEP-ONE-SPOT (POP PEEP-QUEUE))))) ;; clm 4/7/86 ;;new with bind-current (DEFPARAMETER SET-INDS-FROM-SOURCE-INSNS '(MOVE MOVEM POP SETE SET-NIL SET-ZERO SET-T BIND-NIL BIND-POP BIND-T SETE-CDR SETE-CDDR SETE-1+ SETE-1- BIND-CURRENT)) (PROCLAIM '(INLINE PEEP-POP-COUNT)) (DEFUN PEEP-POP-COUNT (INSTR) ;; If instr is an instruction that just pops the stack, return the number of ;; items popped; else return nil. ;; 1/29/86 - POPPDL instruction renamed to POP-PDL. (COND ((EQUAL INSTR '(MOVE D-IGNORE PDL-POP)) 1) ((EQ (CAR INSTR) 'MISC) (AND (EQ (THIRD INSTR) 'POP-PDL) (FOURTH INSTR))) ((EQ (CAR INSTR) 'AUX) (AND (EQ (SECOND INSTR) 'POP-PDL) (THIRD INSTR))) (T NIL))) (DEFUN PEEP-MOVE-CONST (INSTR DEST) ;; If INSTR is an instruction that moves a constant to DEST, return ;; the QUOTE form; else return NIL. ;; 8/24/85 - Original. ;; 9/26/85 - Fixed. ;; 4/28/86 CLM - Made PUSH-NUMBER and PUSH-NEG-NUMBER to be conditional ;; on a DEST of d-return (DECLARE (INLINE QUOTEP)) (COND ((EQ (FIRST INSTR) 'MOVE) (AND (EQ (SECOND INSTR) DEST) (EQ (CAR-SAFE (THIRD INSTR)) 'QUOTE-VECTOR) (QUOTEP (SECOND (THIRD INSTR))) ;; (move dest (quote-vector (quote ...))) (SECOND (THIRD INSTR)))) ((AND (EQ (FIRST INSTR) 'MISC) (EQ (SECOND INSTR) DEST)) (COND ((EQ (THIRD INSTR) 'TRUE) ''T) ((EQ (THIRD INSTR) 'FALSE) '(QUOTE NIL)) (T NIL))) ((EQ DEST 'D-PDL) (cond ((EQUAL INSTR '(SET-NIL 0 PDL-PUSH)) '(QUOTE NIL)) ((EQUAL INSTR '(SET-T 0 PDL-PUSH)) ''T) ((EQUAL INSTR '(SET-ZERO 0 PDL-PUSH)) ''0) ((MEMBER (FIRST INSTR) '(PUSH-NUMBER PUSH-NEG-NUMBER) :TEST #'EQ) `',(SECOND INSTR)) ) ) (T NIL))) (DEFCONSTANT POPPDL-MAX 15 "Maximum number of pops in one POPPDL instruction.") (DEFCONSTANT POPPDL-MAX-V2 63 "Maximum number of pops in one POP-PDL instruction in V2.") ;;; Delete dead code and perform all optimizations on non-branch instructions. (DEFUN PEEP-ONE-SPOT (INDEX) ;; 7/10/85 - Change ATOMIND -> ATOM, NILIND -> NULL; ;; avoid calling the MEMBER function. ;; 7/26/85 - Use REVERSE-SUBTRACT instruction; eliminate unneeded NOT D-INDS. ;; 8/22/85 - Recognize release 3 instruction (AUX POPPDL count). ;; 8/24/85 - Use new function peep-move-const. ;; 9/06/85 - Don't skip over (no-drop-through) when comparing instruction ;; sequences for cross-jumping. ;; 10/23/85 - Change names ADD-IMMEDIATE etc. to ADD-IMMED etc. ;; 1/29/86 - POPPDL instruction renamed to POP-PDL. ;; 4/26/86 DNG - Recognize EQL and EQUAL as commutative instructions. ;; 4/28/86 CLM - Optimization to reduce two identical consecutive returns ;; down to one instruction was sending PEEP-PREVIOUS-INSN-INDEX- ;; REDO-TAGS an instruction index rather than the instruction itself. ;; 5/15/86 CLM - Add in optimization to use the EQ-T misc-op; BRANCH-NOT-NOT opti- ;; mization changed to no longer work on the NOT misc-op. ;; 5/29/86 CLM - Add optimization to delete an UNBIND before a RETURN where possible. ;; 7/10/86 CLM - Update for changes made to certain defops; along with *dif, *logand, ;; etc., now checks for "-", logand, etc. ;; 9/05/86 CLM - Modify the TWO-IDENTICAL-RETURNS optimization so that it works for ;; the RETURN instruction as well as for the aux-op returns. ;; 10/01/86 DNG - Fix to not use immediate instructions for values less than -255. ;; 10/20/86 CLM - Added a number of other optimizations. ;; 11/04/86 CLM - Fixed MATCHING-CODE-PRECEDES-BRANCH-AND-TARGET opt. to handle special ;; case where TARGET was the first instruction. ;; 01/15/87 CLM - Fixed BRANCH-OR-POP-TESTING-CONSTANT opt. to not be invoked for the ;; Store instructions (e.g. SET-NIL). ;; 01/20/87 CLM - Added optimizer to combine consecutive UNBIND-1 instructions. ;; 1/22/87 DNG - Modified UNBIND-1 combination to limit count to 63. ;; 08/03/87 CLM - Make BRANCH-TO-SET-INDS-ALREADY-SET not apply when the ;; instruction following the target instruction is a branch to ;; to the same destination as the original branch. This prevents ;; PEEP from going into an infinite loop in certain cases, and ;; it prevents PEEP from generating infinite loops in other cases. ;; Also fix the BRANCH-TESTING-CONSTANT optimization to not be applied ;; if the user has somehow created a branch-on-zerop and the argument ;; to ZEROP is not a number. (SPRs 5732 and 5860) ;; 09/24/87 CLM - Fix TWO-BRANCHES-SAME-IND opt to set new unconditional branch's POP ;; value to NIL [SPR 6277]. QB2 was barfing because (branch always nil T) ;; is invalid; it should be (branch always nil NIL). ;; 04/11/88 CLM - Added two new optimizations TEST-THEN-BRANCH-ON-SAME-CONDITION and ;; TEST-THEN-BRANCH. ;; 05/17/88 CLM - Fix for the TEST-THEN-BRANCH optimization; added call to PEEP-INDICATORS- ;; USED-P to prevent optimization if it would break the branch instruction. (PROG (X X-PTR Y Z Z-PTR TAG-SKIPPED-FLAG Y-JUST-SETS-INDS Y-BRANCH-TARGET-INDEX YCOUNT ZCOUNT (POP-PDL-MAX (IF (COMPILING-FOR-V2) POPPDL-MAX-V2 POPPDL-MAX))) (IF-DEBUG (INCF PEEP-ONE-SPOT)) (SETQ Y (AREF PEEP-CODE-ARRAY INDEX)) (UNLESS (CONSP Y) (RETURN (1+ INDEX))) (WHEN (EQ (CAR Y) 'COMMENT) (SETF (AREF PEEP-CODE-ARRAY INDEX) NIL) (RETURN (1+ INDEX))) Y-RELOADED-RELOAD-Z (SETQ TAG-SKIPPED-FLAG NIL) (SETQ Z-PTR (1+ INDEX)) RELOAD-Z ;; Find next non-deleted object (instruction or tag). (DO ((LENGTH (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY))) (()) (WHEN (>= Z-PTR LENGTH) (RETURN (SETQ TAG-SKIPPED-FLAG T))) (WHEN (SETQ Z (AREF PEEP-CODE-ARRAY Z-PTR)) (COND ((ATOM Z) (SETQ TAG-SKIPPED-FLAG T)) ((MEMBER (CAR Z) '(RESTART-TAG PARAM) :TEST #'EQ) (SETQ TAG-SKIPPED-FLAG T)) ((EQ (CAR Z) 'COMMENT)) ;; Note: NO-DROP-THROUGH is allowed for z so that it will become the ;; first instruction the next time PEEP-ONE-SPOT is called ;; instead of being skipped over. (T (RETURN)))) (INCF Z-PTR)) Y-RELOADED ;; There are a few optimizations that can go on even across a tag. ;; They are the ones that can delete the first insn, not the second. ;; Specifically, delete the first instruction ;; if all it does is set the indicators ;; but what follows does not use them. (SETQ Y-JUST-SETS-INDS NIL X NIL) (AND (OR (AND (MEMBER (CAR Y) '(MOVE CAR CDR CADR CDDR CAAR CDAR) :TEST #'EQ) (NEQ (CADDR Y) 'PDL-POP) (MEMBER (CADR Y) '(D-INDS 0 D-IGNORE) :TEST #'EQ)) (AND (EQ (FIRST Y) 'MISC) (MEMBER (THIRD Y) '(FALSE TRUE) :TEST #'EQ) (MEMBER (SECOND Y) '(D-INDS D-IGNORE) :TEST #'EQ)) (EQUAL Y '(MOVE D-PDL PDL-POP)) (MEMBER (CAR Y) '(TEST-CAR TEST-CDR TEST-CADR TEST-CDDR TEST-CAAR TEST-MEMQ) :TEST #'EQ)) (SETQ Y-JUST-SETS-INDS T) (NOT (PEEP-INDICATORS-USED-P Z-PTR T)) (PROGN (PEEP-TRACE SET-INDS-NOT-USED) (GO DELETE-Y))) ;;Added 4/11/88. note: there should be a way of combining these two. ;; (MOVE D-INDS 'NIL) --> (BRANCH ALWAYS NIL NIL TAG2) ;; TAG1 TAG1 ;; (BRANCH NULL TRUE NIL TAG2) --> (BRANCH NULL TRUE NIL TAG2) ;; (WHEN (AND (EQUAL Y '(MOVE D-INDS (QUOTE-VECTOR (QUOTE NIL)))) (EQ (CAR Z) 'BRANCH) (EQ (SECOND Z) 'NULL) (EQ (THIRD Z) 'TRUE) ) (SETQ Y `(BRANCH ALWAYS NIL NIL ,(FIFTH Z))) (SETF (AREF PEEP-CODE-ARRAY INDEX) Y) (PEEP-CREATE-TAG-REF (FIFTH Y)) (PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS INDEX Y) (PEEP-TRACE TEST-THEN-BRANCH-ON-SAME-CONDITION) (GO Y-RELOADED)) (WHEN (AND (EQUAL Y '(MOVE D-INDS (QUOTE-VECTOR (QUOTE NIL)))) (EQ (CAR Z) 'BRANCH) (EQ (SECOND Z) 'NULL) (EQ (THIRD Z) 'FALSE) ) (LET ((NTAG (PEEP-UPDATING-INDEX INDEX (PEEP-FIND-OR-INSERT-TAG (1+ Z-PTR))))) (SETQ Y `(BRANCH ALWAYS NIL NIL ,NTAG)) (SETF (AREF PEEP-CODE-ARRAY INDEX) Y) (PEEP-CREATE-TAG-REF NTAG) (PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS INDEX Y) (PEEP-TRACE TEST-THEN-BRANCH-ON-SAME-CONDITION) (GO Y-RELOADED))) (WHEN (EQ (CAR Y) 'BRANCH) ;; Conditional branch followed by unconditional branch to same place. (AND (EQ (CAR Z) 'BRANCH) (EQ (CADR Z) 'ALWAYS) (NOT (FOURTH Y)) (NOT (FOURTH Z)) (EQ (FIFTH Y) (FIFTH Z)) (NEQ (SECOND Y) 'PUSHJ) (PROGN (PEEP-TRACE TWO-BRANCHES-TO-SAME-PLACE) (GO DELETE-Y))) (LET ((Y-TARGET-TAG-INDEX (PEEP-TAG-INDEX (FIFTH Y)))) ;; Branch to .+1, and not popping. (WHEN (AND (EQ INDEX (SETQ Y-BRANCH-TARGET-INDEX (PEEP-PREVIOUS-INSN-INDEX-SKIPPING-TAGS Y-TARGET-TAG-INDEX))) (NULL (FOURTH Y)) (NEQ (SECOND Y) 'PUSHJ)) (PEEP-TRACE BRANCH-.+1) (GO DELETE-Y)) (WHEN (EQ (CADR Y) 'ALWAYS) ;; See if the code before the branch target ;; matches the code before the branch. (DO ((PREV-PTR (PEEP-PREVIOUS-INSN-INDEX INDEX) (PEEP-PREVIOUS-INSN-INDEX PREV-PTR)) (TARGET-PTR (PEEP-PREVIOUS-INSN-INDEX-SKIPPING-TAGS Y-TARGET-TAG-INDEX T) (PEEP-PREVIOUS-INSN-INDEX-SKIPPING-TAGS TARGET-PTR T)) (PREV-MATCH INDEX PREV-PTR) (TARGET-MATCH NIL TARGET-PTR)) ((OR (NULL PREV-PTR) (NULL TARGET-PTR) (EQUAL (AREF PEEP-CODE-ARRAY PREV-PTR) '(NO-DROP-THROUGH)) (NOT (EQUAL (AREF PEEP-CODE-ARRAY PREV-PTR) (AREF PEEP-CODE-ARRAY TARGET-PTR)))) (UNLESS (= INDEX PREV-MATCH) (SETQ X (AREF PEEP-CODE-ARRAY PREV-MATCH)) (PEEP-TRACE MATCHING-CODE-PRECEDES-BRANCH-AND-TARGET (AREF PEEP-CODE-ARRAY (PEEP-NEXT-INSN-INDEX-SKIPPING-TAGS Y-TARGET-TAG-INDEX))) (LET ((OINSN (AREF PEEP-CODE-ARRAY PREV-MATCH))) (WHEN (EQ (CAR OINSN) 'BRANCH) (PEEP-DELETE-TAG-REF (FIFTH OINSN)))) (LET ((NTAG (PEEP-UPDATING-INDEX PREV-MATCH (PEEP-UPDATING-INDEX INDEX (PEEP-FIND-OR-INSERT-TAG TARGET-MATCH))))) (SETF (AREF PEEP-CODE-ARRAY PREV-MATCH) `(BRANCH ALWAYS NIL NIL ,NTAG)) (PEEP-CREATE-TAG-REF NTAG)) ;; Start deleting this branch ;; so that peep-locally doesn't do this optimization again. (SETF (AREF PEEP-CODE-ARRAY INDEX) NIL) ;; Perhaps this new branch insn causes optimizations ;; in branches branching to tags that precede it. (PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS PREV-MATCH (AREF PEEP-CODE-ARRAY PREV-MATCH)) ;;clm 10/17/86 11/04/86 fixed for a certain case - this needs cleaning ;;inserting a new tag may have produced conditions for further opt's. (WHEN (PEEP-PREVIOUS-INSN-OR-TAG-INDEX TARGET-MATCH) (UNLESS (PEEP-PREVIOUS-INSN-INDEX TARGET-MATCH) (PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS (PEEP-PREVIOUS-INSN-OR-TAG-INDEX TARGET-MATCH) (AREF PEEP-CODE-ARRAY (PEEP-PREVIOUS-INSN-OR-TAG-INDEX TARGET-MATCH) )) )) (PEEP-LOCALLY (1+ PREV-MATCH)) (PEEP-LOCALLY PREV-MATCH) ;; Finish deleting this branch. (GO DELETE-Y))))) ;; Various other optimizations of branch insns ;; that involve looking at the insn following the target tag. (LET (TARGET TARGET-PTR X-PTR) (SETQ TARGET-PTR (LOOP FOR TP FROM (1+ Y-TARGET-TAG-INDEX) BELOW (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY) DO (COND ((PEEP-BRANCH-TAG-P (SETQ TARGET (AREF PEEP-CODE-ARRAY TP))) ;; when two or more adjacent tags, branch to the ;; last one so that equivalent branches will look ;; the same for cross-jumping. (PEEP-DELETE-TAG-REF (FIFTH Y)) (SETF (FIFTH Y) TARGET) (PEEP-CREATE-TAG-REF TARGET)) ((PEEP-INSTRUCTION-P TARGET) (RETURN TP))) FINALLY NIL)) (IF (NULL TARGET-PTR) ;; A branch beyond the end of the function can occur following a ;; move to D-LAST which completes a call with destination of ;; D-RETURN. The branch will never be taken, so delete it. (PROGN (PEEP-DELETE-TAG-REF (FIFTH Y)) (SETF (AREF PEEP-CODE-ARRAY INDEX) (SETQ Y '(NO-DROP-THROUGH))) (INCF PEEP-INSNS-SAVED) (GO Y-RELOADED)) (COND ((AND (EQ (CAR TARGET) 'BRANCH) (NEQ (CADR TARGET) 'PUSHJ) (NEQ TARGET Y) ;degenerate case of branch to self ) (COND ((OR (EQ (CADR TARGET) 'ALWAYS) (AND (EQ (CADR TARGET) (CADR Y)) (EQ (CADDR TARGET) (CADDR Y)))) ;; Target of branch is an unconditional branch ;; or a branch testing the same indicator with the same sense. (PEEP-TRACE BRANCH-TO-BRANCH TARGET) (LET ((OTAG (FIFTH Y))) (SETF (FIFTH Y) (FIFTH TARGET)) (PEEP-CREATE-TAG-REF (FIFTH Y)) (PEEP-DELETE-TAG-REF OTAG)) (PEEP-LOCALLY INDEX) (GO Y-RELOADED)) ((AND (EQ (CADR TARGET) (CADR Y)) (NOT (FOURTH TARGET))) ;;Branch to another branch on same indicator ;;but opposite sense (and not popping). ;;The other branch will never branch if reached from here, ;;so branch to a new tag following it. (PEEP-TRACE BRANCH-TO-BRANCH-NOT-TAKEN TARGET) (PEEP-UPDATING-INDEX INDEX (PEEP-CHANGE-BRANCH-TO-INDEX Y (1+ TARGET-PTR))) (GO Y-RELOADED-RELOAD-Z)) ((AND (EQ (CADR Y) 'ALWAYS) (NULL (FOURTH TARGET)) (EQ INDEX (PEEP-PREVIOUS-INSN-INDEX-SKIPPING-TAGS (PEEP-TAG-INDEX (FIFTH TARGET))))) ;; branch [branch .+1] turns into ;; a branch on the opposite condition, to one after that branch. (PEEP-TRACE BRANCH-TO-BRANCH-BACK TARGET) (SETF (CADR Y) (CADR TARGET)) (SETF (CADDR Y) (OTHER (CADDR TARGET))) (PEEP-CAN-DROP-THROUGH (1+ INDEX)) (PEEP-UPDATING-INDEX INDEX (PEEP-CHANGE-BRANCH-TO-INDEX Y (1+ TARGET-PTR))) (GO Y-RELOADED-RELOAD-Z)))) ;end target branch not pushj ((AND (EQ (CADR Y) 'ALWAYS) (OR (AND (EQ (CADR TARGET) 'D-RETURN) (MEMBER (CAR TARGET) (IF (COMPILING-FOR-V2) '(MOVE CAR CDR CAAR CADR CDAR CDDR MISC FALSE TRUE CALL0 CALL) '(MOVE CAR CDR CAAR CADR CDAR CDDR MISC FALSE TRUE CALL0)) :TEST #'EQ)) ;; clm 3/10/86 (AND (EQ (CAR TARGET) 'AUX) (MEMBER (CADR TARGET) '(RETURN-N RETURN-T RETURN-NIL RETURN-LIST RETURN-PRED RETURN-NOT-INDS return-0) :TEST #'EQ)))) ;; Unconditional branch to a single instruction that returns. (PEEP-TRACE BRANCH-TO-RETURN TARGET) (LET ((OY Y)) (SETQ Y (COPY-LIST TARGET)) (SETF (AREF PEEP-CODE-ARRAY INDEX) Y) (PEEP-DELETE-TAG-REF (FIFTH OY))) ;;adding CALL to the above list may make other opt's possible. ;;clm 10/17/86 (PEEP-LOCALLY INDEX) (GO Y-RELOADED)) ((AND (OR (EQ (CADR TARGET) 'D-INDS) (EQ (GET (CAR TARGET) 'DEST) 'D-INDS)) (SETQ X-PTR (PEEP-PREVIOUS-INSN-INDEX INDEX)) (SETQ X (AREF PEEP-CODE-ARRAY X-PTR)) (EQUAL (CADDR TARGET) (CADDR X)) (NOT (MEMBER (CADR X) '(D-LAST D-RETURN) :TEST #'EQ)) (OR (AND (MEMBER (CAR X) SET-INDS-FROM-SOURCE-INSNS :TEST #'EQ) (EQ (CAR TARGET) 'MOVE)) (AND (MEMBER (CAR X) '(CAR CDR CAAR CADR CDAR CDDR) :TEST #'EQ) (EQ (CAR X) (CAR TARGET))) (AND (EQ (GET (CAR X) 'DEST) 'D-INDS) (EQ (CAR X) (CAR TARGET)))) ;;If the instruction following the target instruction ;;is a branch to the same destination as the branch in y, ;;then don't do this optimization. This prevents PEEP ;;from going into an infinited loop. The problem is that ;;the branch-to-branch optimization will undo this one, but ;;leave the code set up to satisfy the conditions for this ;;opt. Then this opt sets up the code to satisfy the b-to-b ;;opt again, and so FOREVER. ;;This also prevents PEEP from generating a branch back to itself. (LET ((NEXT-INSN (AREF PEEP-CODE-ARRAY (PEEP-NEXT-INSN-INDEX-SKIPPING-TAGS TARGET-PTR)))) (NOT (AND (EQ (CAR NEXT-INSN) 'BRANCH) (EQ (FIFTH NEXT-INSN) (FIFTH Y)))) )) ;; Branch to an insn that just sets the inds ;; to what they already were. (PEEP-TRACE BRANCH-TO-SET-INDS-ALREADY-SET TARGET) (PEEP-UPDATING-INDEX INDEX (PEEP-CHANGE-BRANCH-TO-INDEX Y (1+ TARGET-PTR))) (GO Y-RELOADED-RELOAD-Z) ) ) ;cond )) )) ; end of (when (eq (car y) 'branch)... (COND ((OR (EQ (FIRST Y) 'NO-DROP-THROUGH) (AND (EQ (FIRST Y) 'BRANCH) (EQ (SECOND Y) 'ALWAYS))) ;; See if the code before another dead end ;; matches the code before this dead end. (LET ((BEFORE-INDEX (IF (EQ (FIRST Y) 'BRANCH) INDEX (PEEP-PREVIOUS-INSN-INDEX INDEX)))) (UNLESS (NULL BEFORE-INDEX) (DOLIST (OTHER-INDEX PEEP-DEAD-ENDS) (WHEN (/= BEFORE-INDEX OTHER-INDEX) (DO ((PREV-PTR BEFORE-INDEX (PEEP-PREVIOUS-INSN-INDEX PREV-PTR)) (TARGET-PTR OTHER-INDEX (PEEP-PREVIOUS-INSN-INDEX-SKIPPING-TAGS TARGET-PTR T)) (PREV-MATCH NIL PREV-PTR) (TARGET-MATCH NIL TARGET-PTR) (MATCH-COUNT 0 (1+ MATCH-COUNT))) ;; until ((OR (NULL PREV-PTR) (NULL TARGET-PTR) (NOT (EQUAL (AREF PEEP-CODE-ARRAY PREV-PTR) (AREF PEEP-CODE-ARRAY TARGET-PTR)))) ;; finally (UNLESS (< MATCH-COUNT 3) ;; This optimization saves space but increases ;; execution time by one additional branch instruction. ;; Therefore, do it only if at least 2 instructions ;; can be removed. (SETQ X (AREF PEEP-CODE-ARRAY PREV-MATCH)) (PEEP-TRACE MATCHING-CODE-PRECEDES-DEAD-ENDS) (WHEN (EQ (FIRST X) 'BRANCH) (PEEP-DELETE-TAG-REF (FIFTH X))) (SETQ PEEP-DEAD-ENDS (DELETE BEFORE-INDEX (THE LIST PEEP-DEAD-ENDS) :COUNT 1 :TEST #'EQ)) (LET ((NTAG (PEEP-UPDATING-INDEX PREV-MATCH (PEEP-FIND-OR-INSERT-TAG TARGET-MATCH)))) (SETQ Y `(BRANCH ALWAYS NIL NIL ,NTAG)) (SETQ INDEX PREV-MATCH) (SETF (AREF PEEP-CODE-ARRAY PREV-MATCH) Y) (PEEP-CREATE-TAG-REF NTAG)) ;; Perhaps this new branch insn causes optimizations ;; in branches branching to tags that precede it. (PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS PREV-MATCH Y) ;; Now go delete newly dead code following new branch (GO Y-RELOADED-RELOAD-Z) ))) )) ; end of dolist (PUSH BEFORE-INDEX PEEP-DEAD-ENDS) ))) ;;Delete the first of two adjacent identical return instructions. ((OR (AND (EQ (CAR Y) 'AUX) (MEMBER (CADR Y) '(RETURN-N RETURN-T RETURN-NIL RETURN-LIST return-0 RETURN-PRED RETURN-NOT-INDS) :TEST #'EQ)) (AND (EQ (CAR Y) 'MOVE) (EQ (CADR Y) 'D-RETURN))) (LET ((BEFORE-INDEX (PEEP-PREVIOUS-INSN-INDEX-SKIPPING-TAGS INDEX))) (AND BEFORE-INDEX (EQUAL (AREF PEEP-CODE-ARRAY BEFORE-INDEX) Y) (PROGN (PEEP-TRACE TWO-IDENTICAL-RETURNS) (SETF (AREF PEEP-CODE-ARRAY BEFORE-INDEX) NIL) (PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS BEFORE-INDEX Y) (GO Y-RELOADED-RELOAD-Z) ) ) ) ) ) ; end cond (LET (IMMED-INST NUM) (WHEN (AND (EQUAL (SECOND Y) 0) (EQ (CAR-SAFE (THIRD Y)) 'QUOTE-VECTOR) (SETQ IMMED-INST (CDR (ASSOC (FIRST Y) '((*PLUS . ADD-IMMED) (*DIF . SUBTRACT-IMMED) (EQ . EQ-IMMED) (INTERNAL-= . =-IMMED) (INTERNAL-< . <-IMMED) (INTERNAL-> . >-IMMED) (= . =-IMMED) (< . <-IMMED) (> . >-IMMED) (+ . ADD-IMMED) (- . SUBTRACT-IMMED)) :TEST #'EQ))) (INSTRUCTION-EXISTS-P 'ADD-IMMED) (FIXNUMP (SETQ NUM (QUOTE-NUMBER (SECOND (THIRD Y))))) (<= -255 NUM 255)) ;; (*PLUS 0 (QUOTE-VECTOR (QUOTE n))) ==> (ADD-IMMED n) (WHEN (AND (MEMBER (FIRST Y) '(*DIF -) :TEST #'EQ) (NOT (INSTRUCTION-EXISTS-P 'SUBTRACT-IMMED))) (SETQ IMMED-INST 'ADD-IMMED NUM (- NUM))) (SETF Y (LIST IMMED-INST (LOGAND NUM 511))) (SETF (AREF PEEP-CODE-ARRAY INDEX) Y) (PEEP-TRACE IMMED-INSN) (GO Y-RELOADED-RELOAD-Z))) ;; The rest can happen only if no tag intervenes. (WHEN TAG-SKIPPED-FLAG (RETURN Z-PTR)) ;; Ok, we have instructions in Y and Z. (COND ;;When a MOVEM is followed by a return that pops, ;;delete the MOVEM, unless Safety is more important. ;;This may not be general enough ((AND (EQUAL Z '(MOVE D-RETURN PDL-POP)) (EQ (CAR Y) 'MOVEM) (MEMBER (CAR-SAFE (THIRD Y)) '(ARG LOCBLOCK) :TEST #'EQ)) (UNLESS (> (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)) (PEEP-TRACE MOVEM-BEFORE-RETURN) (GO DELETE-Y))) ((EQUAL Y '(NO-DROP-THROUGH)) ;; Delete dead code following a (NO-DROP-THROUGH) (WHEN (PEEP-INSTRUCTION-P Z) (PEEP-TRACE DEAD-CODE)) (GO DELETE-Z)) ;;Delete dead code after a return ((AND (OR (AND (EQ (CADR Y) 'D-RETURN) (MEMBER (CAR Y) (IF (COMPILING-FOR-V2) '(MOVE CAR CDR CAAR CADR CDAR CDDR MISC FALSE TRUE CALL0 CALL) '(MOVE CAR CDR CAAR CADR CDAR CDDR MISC FALSE TRUE CALL0)) :TEST #'EQ)) (AND (EQ (CAR Y) 'AUX) (MEMBER (CADR Y) '(RETURN-N RETURN-T RETURN-NIL RETURN-LIST RETURN-0 RETURN-PRED RETURN-NOT-INDS) :TEST #'EQ)) ) (PEEP-INSTRUCTION-P Z)) (PEEP-TRACE DEAD-CODE) (GO DELETE-Z)) ((AND (EQ (CAR Y) 'BRANCH) ;; clm 3/11/86 (NOT (EQ (CADR Y) 'PUSHJ))) (COND ((EQ (CADR Y) 'ALWAYS) (WHEN (PEEP-INSTRUCTION-P Z) (PEEP-TRACE DEAD-CODE)) (GO DELETE-Z)) ((AND (EQ Y-BRANCH-TARGET-INDEX Z-PTR) (NOT (FOURTH Y)) (EQ (CAR Z) 'BRANCH) (EQ (CADR Z) 'ALWAYS)) ;; branch .+2 followed by unconditional branch. (PEEP-TRACE BRANCH-ACROSS-BRANCH) (SETF (CADDR Y) (OTHER (CADDR Y))) (LET ((OTAG (FIFTH Y))) (SETF (FIFTH Y) (FIFTH Z)) (SETF (FIFTH Z) OTAG) (GO DELETE-Z)))) (COND ((AND (EQ (CAR Z) 'BRANCH) (NOT (FOURTH Y)) (EQ (CADR Y) (CADR Z))) ;; Two branches in a row testing the same indicator. (PEEP-TRACE TWO-BRANCHES-SAME-IND) (IF (EQ (CADDR Y) (CADDR Z)) ;; same sense => just delete the second one. (GO DELETE-Z) ;; opposite sense => second one is really unconditional. (PROGN (SETF (CADR Z) 'ALWAYS) (SETF (CADDR Z) NIL) ;;make sure POP value is seet to nil (SETF (CADDDR Z) NIL)))) ;; Branch followed by move. See if move is to d-inds and is superfluous ((EQ (CAR Z) 'MOVE) (AND (SETQ X-PTR (PEEP-PREVIOUS-INSN-INDEX INDEX)) (SETQ X (AREF PEEP-CODE-ARRAY X-PTR)) (MEMBER (CAR X) SET-INDS-FROM-SOURCE-INSNS :TEST #'EQ) (EQUAL (CADDR X) (CADDR Z)) (OR (AND (EQ (CADR Z) 'D-PDL) ;; Can optimize branch push ;; only if the branch is a branch-or-pop. ;; and the previous insn is also a push or a movem. (OR (EQUAL X Z) (EQ (CAR X) 'MOVEM)) (FOURTH Y)) (AND (MEMBER (CADR Z) '(D-IGNORE D-INDS 0) :TEST #'EQ) (NOT (MEMBER (CADR X) '(D-RETURN D-LAST) :TEST #'EQ)))) (PROGN (PEEP-TRACE MOVE-BRANCH-MOVE) (WHEN (EQ (CADR Z) 'D-PDL) (SETF (FOURTH Y) NIL)) (GO DELETE-Z)))))) ((AND (EQ (CAR Z) 'BRANCH) (NOT (EQ (CADR Z) 'PUSHJ))) ;; check for MOVE D-INDS constant followed by branches. ;; Decide where the branching will stop ;; and make one branch straight there. ;; Then back to Y-RELOADED which may delete the MOVE. ;; Note: we know that the indicators will get used, ;; for otherwise the MOVE would already have been deleted, above. (LET ((QUOTE-FORM (PEEP-MOVE-CONST Y 'D-INDS))) (UNLESS (NULL QUOTE-FORM) (LET ((INDS-USED (PEEP-INDICATORS-USED-P Z-PTR NIL))) (UNLESS (NULL INDS-USED) (PEEP-TRACE BRANCH-TESTING-CONSTANT) (LET* ((FINAL-BRANCH (AREF PEEP-CODE-ARRAY INDS-USED)) (INDICATOR (SECOND FINAL-BRANCH)) (OTAG (FIFTH Z)) (SENSE (THIRD FINAL-BRANCH))) (UNLESS (OR (AND (EQ (CADR Z) 'ALWAYS) (EQ (FIFTH Z) (FIFTH FINAL-BRANCH))) (AND (EQ INDICATOR 'ZEROP) (NOT (NUMBERP (SECOND QUOTE-FORM))))) (COND ((EQ (CASE SENSE (TRUE T) (FALSE NIL)) (FUNCALL INDICATOR (SECOND QUOTE-FORM))) ;; The final branch will go. (SETF (FIFTH Z) (FIFTH FINAL-BRANCH))) (T ;; The final branch will not branch. (WHEN (FOURTH FINAL-BRANCH) ;; Can't skip over a branch that pops. (RETURN Z-PTR)) (PEEP-UPDATING-INDEX INDEX (SETF (FIFTH Z) (PEEP-FIND-OR-INSERT-TAG (1+ INDS-USED)))))) (SETF (CADR Z) 'ALWAYS) (SETF (CADDR Z) NIL) (PEEP-CREATE-TAG-REF (FIFTH Z)) (PEEP-DELETE-TAG-REF OTAG) (GO Y-RELOADED-RELOAD-Z))))))) ;; Check for push followed by branch-or-pop that will never branch. (LET (QUOTE-FORM) (WHEN (AND (FOURTH Z) ;Must be branch-or-pop (SETQ QUOTE-FORM (PEEP-MOVE-CONST Y 'D-PDL)) ;; Test that branch will not occur. (NEQ (CASE (THIRD Z) (TRUE T) (FALSE NIL)) (FUNCALL (SECOND Z) (SECOND QUOTE-FORM))) (EQ (SECOND Y) 'D-PDL)) (PEEP-TRACE BRANCH-OR-POP-TESTING-CONSTANT) ;; Change the push to a d-inds, and delete the branch. (SETF (AREF PEEP-CODE-ARRAY INDEX) (SETQ Y (LIST* (CAR Y) 'D-INDS (CDDR Y)))) (GO DELETE-Z))) ;;this optimization is causing problems when compiling for ;;"explorer" (WHEN (AND (EQ (FIRST Y) 'MISC) (EQ (SECOND Y) 'D-INDS) (EQL (THIRD Y) (MISC-LAP-CODE 'NOT-INDICATORS)) (EQ (SECOND Z) 'NULL) (NOT (PEEP-INDICATORS-USED-P (PEEP-TAG-INDEX (FIFTH Z)) T))) ;;(misc d-inds not-indicators) ;; (BRANCH NULL TRUE pop tag) ==> (BRANCH NULL FALSE pop tag) (SETF (THIRD Z) (OTHER (THIRD Z))) (PEEP-TRACE BRANCH-NOT-NOT) (GO DELETE-Y)) ;;clm 10/21/86 ;; (SET-T 0 PDL-PUSH) \ (SET-T 0 LOCAL-X) ;; (BRANCH ALWAYS * * TAG) \ __ (BRANCH ALWAYS * * TAG2) ;; TAG / TAG ;; (POP 0 LOCAL-X) / (POP ---) ;; TAG2 (WHEN (AND (EQ (CADR Z) 'ALWAYS) (MEMBER (CAR Y) '(SET-T SET-NIL SET-ZERO) :TEST #'EQ) (EQ (THIRD Y) 'PDL-PUSH)) (LET* ((TARGET-INSN-INDEX (PEEP-NEXT-INSN-INDEX-SKIPPING-TAGS (PEEP-TAG-INDEX (FIFTH Z)))) (TARGET-INSN (IF TARGET-INSN-INDEX (AREF PEEP-CODE-ARRAY TARGET-INSN-INDEX) NIL))) (WHEN (AND TARGET-INSN-INDEX (EQ (CAR TARGET-INSN) 'POP)) (SETF (AREF PEEP-CODE-ARRAY INDEX) `(,(FIRST Y) ,(SECOND Y) ,(THIRD TARGET-INSN))) (SETF (FIFTH Z) (PEEP-FIND-OR-INSERT-TAG (1+ TARGET-INSN-INDEX))) (PEEP-CREATE-TAG-REF (FIFTH Z))) ) ) ;;;Added 4/11/88 ;;; (PUSH x) ---\ (TEST x) ;;; (MISC TEST cond) -----> (BRANCH-NOT-cond) ;;; (BRANCH NULL ...) ---/ ;;; (LET (TEMP-INSN BRANCH-CONDITION (MISC-OP (THIRD Y)) (DEST 'D-INDS) ) (WHEN (AND (EQ (FIRST Y) 'MISC) (EQ (SECOND Y) 'D-INDS) (SETQ BRANCH-CONDITION (COND ((EQL (MISC-LAP-CODE 'ZEROP) MISC-OP) 'ZEROP) ((EQL (MISC-LAP-CODE 'ATOM) MISC-OP) 'ATOM) ((EQL (MISC-LAP-CODE 'SYMBOLP) MISC-OP) 'SYMBOLP))) (SETQ X-PTR (PEEP-PREVIOUS-INSN-INDEX INDEX)) (SETQ X (AREF PEEP-CODE-ARRAY X-PTR)) (EQ (SECOND Z) 'NULL) (NOT (PEEP-INDICATORS-USED-P (PEEP-TAG-INDEX (FIFTH Z)) T)) (SETQ TEMP-INSN (IF (EQ (CAR X) 'MOVE) (AND (EQ (SECOND X) 'D-PDL) (CAR X)) (PROGN (SETQ DEST 0) (CADR (ASSOC (CAR X) '((PUSH TEST) (PUSH-CAR TEST-CAR) (PUSH-CDR TEST-CDR) (PUSH-CADR TEST-CADR) (PUSH-CDDR TEST-CDDR) (PUSH-CAAR TEST-CAAR))))))) ) (SETF (AREF PEEP-CODE-ARRAY X-PTR) `(,TEMP-INSN ,DEST ,(THIRD X))) (SETF (SECOND Z) BRANCH-CONDITION) (SETF (THIRD Z) (OTHER (THIRD Z))) (PEEP-TRACE TEST-THEN-BRANCH ) (GO DELETE-Y) ) ) ) ; end (EQ (CAR Z) 'BRANCH) ;;new optimization for deleting an unbind before a return ;;the return will take care of the unbindings ((AND (EQ (CAR Y) 'AUX) (EQ (CADR Y) 'UNBIND-1) (OR (AND (EQ (CADR Z) 'D-RETURN) (MEMBER (CAR Z) '(MOVE CAR CDR CAAR CADR CDAR CDDR MISC FALSE TRUE) :TEST #'EQ) (NOT (EQ (CAR-SAFE (THIRD Z)) 'SPECIAL)) ) (AND (EQ (CAR Z) 'AUX) (MEMBER (CADR Z) '(RETURN-N RETURN-T RETURN-NIL RETURN-LIST RETURN-0 RETURN-PRED RETURN-NOT-INDS) :TEST #'EQ))) ) (PEEP-TRACE UNBIND-FOLLOWED-BY-RETURN) (GO DELETE-Y) ) ((EQ (CAR Z) 'POP) ;; PUSH 0, PUSH NIL or PUSH T followed by POP. (LET ((QUOTE-FORM (PEEP-MOVE-CONST Y 'D-PDL))) (WHEN (AND (NOT (NULL QUOTE-FORM)) (MEMBER (SECOND QUOTE-FORM) '(0 NIL T) :TEST #'EQ) (OR (NEQ (SECOND QUOTE-FORM) 'T) (INSTRUCTION-EXISTS-P 'SET-T))) (PEEP-TRACE PUSH-NIL-OR-0-THEN-POP) (SETF (AREF PEEP-CODE-ARRAY INDEX) (SETQ Y (LIST (CASE (SECOND QUOTE-FORM) (NIL 'SET-NIL) (0 'SET-ZERO) (T 'SET-T)) 0 (CADDR Z)))) (GO DELETE-Z)))) ((AND (SETQ ZCOUNT (PEEP-POP-COUNT Z)) (< ZCOUNT POP-PDL-MAX) (SETQ YCOUNT (PEEP-POP-COUNT Y))) ;; Two insns in a row that just pop something(s) from the pdl. (PEEP-TRACE TWO-POPS) (LET ((TOTAL-POPS (+ YCOUNT ZCOUNT))) (COND ((<= TOTAL-POPS POP-PDL-MAX) (SETF (AREF PEEP-CODE-ARRAY INDEX) (SETQ Y (MAKE-AUX 'POP-PDL TOTAL-POPS))) (GO DELETE-Z)) (T (SETF (AREF PEEP-CODE-ARRAY INDEX) (SETQ Y (MAKE-AUX 'POP-PDL POP-PDL-MAX))) (SETF (AREF PEEP-CODE-ARRAY Z-PTR) (SETQ Z (MAKE-AUX 'POP-PDL (- TOTAL-POPS POP-PDL-MAX)))) (RETURN Z-PTR))))) ;;this goes with the two-push-nils test below ((AND (EQUAL Z '(SET-NIL 0 PDL-PUSH)) (EQUAL Y '(SET-NIL 0 PDL-PUSH))) (PROGN (LET ((PEEP-NUMBER-OF-OPTIMIZATIONS PEEP-NUMBER-OF-OPTIMIZATIONS)) (PEEP-TRACE TWO-PUSH-NILS)) (RETURN Z-PTR))) ((EQ (CAR Z) 'MOVE) (WHEN (AND (EQ (CAR Y) 'MOVE) (EQ (CADR Y) 'D-PDL) (EQ (CADDR Z) 'PDL-POP)) ;; Push followed by move from pdl. ;; Transfer the destination into the push, ;; then the pop is not needed. (PEEP-TRACE PUSH-THEN-MOVE-FROM-PDL) (SETF (CADR Y) (CADR Z)) (GO DELETE-Z)) (IF-DEBUG (AND (EQUAL Z '(MOVE D-PDL (QUOTE-VECTOR (QUOTE NIL)))) (EQUAL Y '(MOVE D-PDL (QUOTE-VECTOR (QUOTE NIL)))) (PROGN (LET ((PEEP-NUMBER-OF-OPTIMIZATIONS PEEP-NUMBER-OF-OPTIMIZATIONS)) (PEEP-TRACE TWO-PUSH-NILS)) (RETURN Z-PTR)))) (WHEN (EQUAL (CADDR Y) (CADDR Z)) (COND ((AND (EQ (CADR Z) 'D-INDS) (NOT (MEMBER (CADR Y) '(D-LAST D-RETURN) :TEST #'EQ)) (MEMBER (CAR Y) SET-INDS-FROM-SOURCE-INSNS :TEST #'EQ)) ;; Delete MOVE D-INDS X after something that stores or fetches X. (PEEP-TRACE SET-INDS-ALREADY-SET) (GO DELETE-Z)) ((AND (EQ (CADR Z) 'D-PDL) (EQ (CAR Y) 'POP)) ;; Turn POP X ? MOVE D-PDL X into MOVEM X (PEEP-TRACE POP-THEN-PUSH) (RPLACA Y 'MOVEM) (GO DELETE-Z)) ((AND (EQ (CADR Z) 'D-RETURN) (EQ (CAR Y) 'POP) (MEMBER (CAR-SAFE (THIRD Z)) '(ARG LOCBLOCK) :TEST #'EQ) (> (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))) ;; Turn POP X , MOVE D-RETURN X into MOVE D-RETURN PDL-POP (PEEP-TRACE POP-BEFORE-RETURN) (SETF (THIRD Z) 'PDL-POP) (GO DELETE-Y))))) ((AND (EQ (FIRST Y) 'MOVE) (EQ (SECOND Y) 'D-PDL) (EQUAL (SECOND Z) 0) (OR (MEMBER (FIRST Z) '(*PLUS + *TIMES * *LOGAND LOGAND *LOGIOR LOGIOR *LOGXOR LOGXOR INTERNAL-= EQ EQL EQUAL) :TEST #'EQ) (AND (MEMBER (FIRST Z) '(*DIF - REVERSE-SUBTRACT) :TEST #'EQ) (INSTRUCTION-EXISTS-P 'REVERSE-SUBTRACT))) ;; commutative operation; possible to exchange operands ) (LET (NUM) (COND ((AND (SETQ X-PTR (PEEP-PREVIOUS-INSN-INDEX INDEX)) (SETQ X (AREF PEEP-CODE-ARRAY X-PTR)) (EQ (FIRST X) 'POP) (EQUAL (THIRD X) (THIRD Z))) ;; (POP 0 a) \ / (MOVEM 0 a) ;; (MOVE D-PDL b) > ==> < ;; (*PLUS 0 a) / \ (*PLUS 0 b) (PEEP-TRACE SWAP-COMMUTATIVE) (SETF (THIRD Z) (THIRD Y)) (SETF (THIRD Y) (THIRD X)) (PEEP-QUEUE X-PTR)) ; go back to change POP to MOVEM ((AND (EQ (CAR-SAFE (THIRD Z)) 'QUOTE-VECTOR) (QUOTEP (SETQ NUM (SECOND (THIRD Z)))) (FIXNUMP (SETQ NUM (SECOND NUM))) (<= NUM 511) (OR (<= 0 NUM) (AND (<= -511 NUM) (INSTRUCTION-EXISTS-P 'PUSH-NEG-NUMBER)))) ;; (MOVE D-PDL b) > ==> < (PUSH-NUMBER n) ;; (*PLUS 0 'n) / \ (*PLUS 0 b) (PEEP-TRACE SWAP-COMMUTATIVE) (SETF (THIRD Z) (THIRD Y)) (SETF (AREF PEEP-CODE-ARRAY INDEX) (IF (< NUM 0) `(PUSH-NEG-NUMBER ,(- 0 NUM)) `(PUSH-NUMBER ,NUM)))) ((AND (MISC-OP-EVAL 'EQ-T) (EQ (CAR-SAFE (THIRD Z)) 'QUOTE-VECTOR) (QUOTEP (SETQ NUM (SECOND (THIRD Z)))) (eq (SETQ NUM (SECOND NUM)) t) ) ;;use the new eq-t misc-op (PEEP-TRACE EQ-T) (SETF (AREF PEEP-CODE-ARRAY Z-PTR) `(MISC D-INDS ,(MISC-LAP-CODE 'EQ-T)))) (T (RETURN Z-PTR))) (COND ((MEMBER (FIRST Z) '(*DIF -) :TEST #'EQ) (SETF (FIRST Z) 'REVERSE-SUBTRACT)) ((EQ (FIRST Z) 'REVERSE-SUBTRACT) (SETF (FIRST Z) '-))) (RETURN Z-PTR))) ;;convert call-n's to specific call-#'s when the number is low enough ((AND (EQ (FIRST Z) 'CALL-N) (EQ (FIRST Y) 'PUSH-NUMBER) (< (SECOND Y) 7)) ;the max is call-6 (PEEP-TRACE CALL-N-TO-CALL) (SETF (FIRST Z) 'CALL) (RPLACD (LAST Z) (CDR Y)) (GO DELETE-Y)) ;; (MOVE D-PDL function) ;; (CALL DEST PDL-POP ...) ==> (CALL DEST function ...) ((AND (EQ (FIRST Z) 'CALL) (EQ (THIRD Z) 'PDL-POP) (EQ (FIRST Y) 'MOVE) (EQ (SECOND Y) 'D-PDL)) (PEEP-TRACE PUSH-THEN-CALL) (SETF (THIRD Z) (THIRD Y)) (GO DELETE-Y)) ;;delete first of two (AUX LEXICAL-UNSHARE-ALL) ((AND (EQUAL Y '(AUX LEXICAL-UNSHARE-ALL)) (EQUAL Z '(AUX LEXICAL-UNSHARE-ALL))) (PEEP-TRACE TWO-LEXICAL-UNSHARE-ALL) (GO DELETE-Y)) ;;combine UNBIND's ((AND (EQ (SECOND Y) 'UNBIND-1) (EQ (SECOND Z) 'UNBIND-1)) (LET ((NUM (+ (THIRD Y) (THIRD Z) 1))) ;plus 1 for each unbind, minus 1 for the new unbind (WHEN (< NUM #o77) (SETF (THIRD Z) NUM) (GO DELETE-Y)))) ;;clm 2/2/88 ;; (MISC TEST NOT-INDICATORS) ----> (AUX RETURN-PRED) ;; (AUX RETURN-NOT-INDS) ((AND (EQ (FIRST Y) 'MISC) (EQ (SECOND Y) 'D-INDS) (EQL (THIRD Y) (MISC-LAP-CODE 'NOT-INDICATORS)) (equal z '(aux return-not-inds))) (setf (second z) 'return-pred) (go delete-y)) ) ;end of COND (RETURN Z-PTR) DELETE-Z (OR (MEMBER (CAR Z) '(NO-DROP-THROUGH COMMENT) :TEST #'EQ) (INCF PEEP-INSNS-SAVED)) (SETF (AREF PEEP-CODE-ARRAY Z-PTR) NIL) (WHEN (EQ (CAR Z) 'BRANCH) (PEEP-CAN-DROP-THROUGH (1+ Z-PTR)) (PEEP-DELETE-TAG-REF (FIFTH Z))) (INCF Z-PTR) ;; If the previous instruction was a NO-DROP-THROUGH ;; we may have turned the branch before it into a branch to .+1. Check for that. (WHEN (OR (EQ (CAR Y) 'NO-DROP-THROUGH) (AND (EQ (FIRST Y) 'BRANCH) (EQ (SECOND Y) 'ALWAYS))) (PEEP-LOCALLY INDEX)) (GO RELOAD-Z) DELETE-Y (SETF (AREF PEEP-CODE-ARRAY INDEX) NIL) (WHEN (EQ (CAR Y) 'BRANCH) (PEEP-CAN-DROP-THROUGH (1+ INDEX)) (PEEP-DELETE-TAG-REF (FIFTH Y))) (INCF PEEP-INSNS-SAVED) (MULTIPLE-VALUE-BIND (I F) (PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS INDEX Z) (SETQ INDEX I) (SETQ TAG-SKIPPED-FLAG (OR F TAG-SKIPPED-FLAG))) (UNLESS INDEX (RETURN Z-PTR)) (SETQ Y (AREF PEEP-CODE-ARRAY INDEX)) ;; If we delete the insn following an unconditional branch, ;; we may have created a branch to .+2 before it, ;; so scan there. (WHEN (AND (EQ (CAR Y) 'BRANCH) (EQ (CADR Y) 'ALWAYS)) (PEEP-LOCALLY INDEX)) (SETQ PEEP-QUEUE (DELETE Y (THE LIST PEEP-QUEUE) :TEST #'EQ)) (GO Y-RELOADED-RELOAD-Z))) ;;needs to work for new test insns - actually anything that just sets the inds (DEFUN PEEP-PREVIOUS-INSN-INDEX-REDO-TAGS (INDEX NEXT-INSN &AUX TAG-SKIPPED-FLAG) ;; 10/20/86 CLM - Modified to make more use of the MATCHING-CODE-PRECEDES-DEAD-ENDS opt. (DO ((Y)) (NIL) (SETQ INDEX (PEEP-PREVIOUS-INSN-OR-TAG-INDEX INDEX)) (WHEN (NULL INDEX) (RETURN)) (SETQ Y (AREF PEEP-CODE-ARRAY INDEX)) (COND ((SYMBOLP Y) (WHEN (OR (SYMBOLP NEXT-INSN) (MEMBER (CAR NEXT-INSN) '(RESTART-TAG PARAM COMMENT NO-DROP-THROUGH) :TEST #'EQ) (EQ (CAR NEXT-INSN) 'BRANCH) ;; clm 3/18/86 ;;(eq (cadr next-insn) 'd-inds) (EQ (GET (CAR NEXT-INSN) 'DEST) 'D-INDS)) (PEEP-REDO-BRANCHES (AREF PEEP-CODE-ARRAY INDEX)) ) ) ((MEMBER (CAR Y) '(RESTART-TAG PARAM COMMENT NO-DROP-THROUGH) :TEST #'EQ)) (T (RETURN))) (SETQ TAG-SKIPPED-FLAG T)) (VALUES INDEX TAG-SKIPPED-FLAG)) ;; Reoptimize all branches to TAG. ;; Called when the instruction that used to follow TAG is deleted. (DEFUN PEEP-REDO-BRANCHES (TAG &OPTIONAL UNCONDITIONAL-ONLY) ;; 1/14/85 - Replaced (array-active-length peep-code-array) with ;; peep-scanning-index to avoid wasting time when ;; peep-queue isn't going to do anything anyway. (DO ((INDEX PEEP-CODE-START-INDEX (1+ INDEX)) Y (LENGTH PEEP-SCANNING-INDEX)) ((>= INDEX LENGTH)) (AND (CONSP (SETQ Y (AREF PEEP-CODE-ARRAY INDEX))) (EQ (CAR Y) 'BRANCH) (EQ (FIFTH Y) TAG) (OR (NOT UNCONDITIONAL-ONLY) (EQ (SECOND Y) 'ALWAYS)) (PEEP-QUEUE INDEX)))) ;;; Flush any (NO-DROP-THROUGH)s following a deleted branch. (DEFUN PEEP-CAN-DROP-THROUGH (INDEX) ;; 1/14/85 - Call peep-redo-branches for any tags that are passed ;; over since cross-jumping opportunities may have been ;; created. (DO ((I INDEX (1+ I)) (LENGTH (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY))) ((= I LENGTH)) (LET ((TEM (AREF PEEP-CODE-ARRAY I))) (COND ((ATOM TEM) (UNLESS (NULL TEM) (PEEP-REDO-BRANCHES TEM T))) ((MEMBER (CAR TEM) '(RESTART-TAG PARAM COMMENT) :TEST #'EQ)) ((EQ (CAR TEM) 'NO-DROP-THROUGH) (SETF (AREF PEEP-CODE-ARRAY I) NIL)) (T (RETURN)))))) ;; Returns non-NIL if the indicators are used by the code starting at INDEX. ;; The value is the index of the instruction that uses the indicators, ;; which is a conditional branch instruction. ;;add %close-catch to the skip-pop category ;;(%close-catch preserves the indicators) ;;pushj -if skip-pop is t treat like a branch-always otherwise return nil (DEFUN PEEP-INDICATORS-USED-P (INDEX SKIP-POP) ;; 2/01/84 - Allowance for poppdl miscop made to fix condition-case bug. ;; 4/17/85 - Added new argument, skip-pop, to indicate whether ;; instructions that don't alter the indicators should ;; be skipped over. This is part of the fix for bug report 1587. ;; 8/22/85 - Check for release 3 Aux instructions. ;; 1/29/86 - POPPDL instruction renamed to POP-PDL. ;; 4/01/86 CLM - Recognize the misc-op NOT-INDICATORS and the aux-ops RETURN-PRED ;; and RETURN-NOT-INDS as instructions which use the branch ;; indicators. ;; 5/29/86 CLM - Fix the check made for aux-ops RETURN-PRED and RETURN-NOT-INDS. ;; Optimization was occurring when it should not have. ;; 7/08/86 CLM - For the misc-op and the aux-op's that use the indicators, if ;; skip-pop is nil, return nil. This will avoid problems when the ;; optimization is looking specifically for a BRANCH instruction ;; (such as BRANCH-TESTING-CONSTANT). ;; 2/06/87 DNG - Recognize LEXICAL-UNSHARE and LEXICAL-UNSHARE-ALL as not ;; affecting indicators; recognize AUX op UNBIND-1 instead of UNBIND. (DO ((I INDEX)) (NIL) (LET ((INSN (AREF PEEP-CODE-ARRAY I))) (COND ((ATOM INSN) (INCF I)) ((EQ (CAR INSN) 'BRANCH) (IF (OR (EQ (CADR INSN) 'ALWAYS) (AND SKIP-POP (EQ (CADR INSN) 'PUSHJ))) (SETQ I (PEEP-TAG-INDEX (FIFTH INSN))) (RETURN I))) ((OR (AND (EQ (CAR INSN) 'MISC) (EQL (THIRD INSN) (MISC-LAP-CODE 'NOT-INDICATORS))) (AND (EQ (CAR INSN) 'AUX) (MEMBER (SECOND INSN) '(RETURN-PRED RETURN-NOT-INDS) :TEST #'EQ)) ) (IF SKIP-POP (RETURN I) (RETURN NIL)) ) ((AND SKIP-POP (COND ((EQ (CAR INSN) 'MISC) (MEMBER (THIRD INSN) '(POP-PDL UNBIND) :TEST #'EQ)) ((EQ (CAR INSN) 'AUX) (MEMBER (SECOND INSN) '(POP-PDL UNBIND UNBIND-1 LEXICAL-UNSHARE-ALL %CLOSE-CATCH) :TEST #'EQ)) ((EQ (CAR INSN) 'LEXICAL-UNSHARE) T) )) (INCF I)) (T (RETURN NIL)))))) (DEFUN PEEP-TAG-INDEX (TAG) (CADDR (ASSOC TAG PEEP-TAG-ALIST :TEST #'EQ))) ;; Return the index in code-array of the next instruction after INDEX, ;; even if there are tags in between. Returns NIL if there is no insn after INDEX. (DEFUN PEEP-NEXT-INSN-INDEX-SKIPPING-TAGS (INDEX) (DO ((I (1+ INDEX) (1+ I)) (LENGTH (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY)) TEM) (NIL) (COND ((>= I LENGTH) (RETURN NIL)) ((AND (CONSP (SETQ TEM (AREF PEEP-CODE-ARRAY I))) (NOT (MEMBER (CAR TEM) '(RESTART-TAG PARAM COMMENT NO-DROP-THROUGH) :TEST #'EQ))) (RETURN I))))) ;; Return the index in code-array of the last instruction before INDEX, ;; even if there are tags in between. Returns NIL if there is no insn before INDEX. (DEFUN PEEP-PREVIOUS-INSN-INDEX-SKIPPING-TAGS (INDEX &OPTIONAL DROP-THROUGH-REQUIRED) ;; 09/06/85 - added option to stop on a (no-drop-through). (DO ((I (1- INDEX) (1- I))) (NIL) (IF (< I PEEP-CODE-START-INDEX) (RETURN NIL) (LET ((TEM (AREF PEEP-CODE-ARRAY I))) (WHEN (CONSP TEM) (IF (EQ (CAR TEM) 'NO-DROP-THROUGH) (WHEN DROP-THROUGH-REQUIRED (RETURN NIL)) (UNLESS (MEMBER (CAR TEM) '(RESTART-TAG PARAM COMMENT) :TEST #'EQ) (RETURN I)))))))) ;; Return the index in code-array of the last instruction or tag before INDEX, ;; Returns NIL if there is no insn before INDEX. (DEFUN PEEP-PREVIOUS-INSN-OR-TAG-INDEX (INDEX) (DO ((I (1- INDEX) (1- I))) (NIL) (COND ((< I PEEP-CODE-START-INDEX) (RETURN NIL)) ((AREF PEEP-CODE-ARRAY I) (RETURN I))))) ;; Return the index in code-array of the last instruction before INDEX, ;; or NIL if there is none or if a tag intervenes. (DEFUN PEEP-PREVIOUS-INSN-INDEX (INDEX) (DO ((I (1- INDEX) (1- I)) TEM) (NIL) (COND ((< I PEEP-CODE-START-INDEX) (RETURN NIL)) ((SETQ TEM (AREF PEEP-CODE-ARRAY I)) (RETURN (IF (OR (ATOM TEM) (MEMBER (CAR TEM) '(RESTART-TAG PARAM) :TEST #'EQ)) NIL I)))))) (DEFUN PEEP-LOCALLY (INDEX) (BLOCK FUNCTION (PROG ((PREV-INSN-INDEX (1- INDEX))) (WHEN (> PREV-INSN-INDEX PEEP-SCANNING-INDEX) (RETURN)) (DO () (NIL) (COND ((AREF PEEP-CODE-ARRAY PREV-INSN-INDEX) (RETURN)) ((= PREV-INSN-INDEX PEEP-CODE-START-INDEX) (RETURN-FROM FUNCTION NIL))) (DECF PREV-INSN-INDEX)) (WHEN (ATOM (AREF PEEP-CODE-ARRAY PREV-INSN-INDEX)) (RETURN NIL)) (PEEP-QUEUE PREV-INSN-INDEX)))) ;; PEEP keeps track of all tags in the code with PEEP-TAG-ALIST, ;; a list which contains an element for each tag. ;; The element looks like (TAG USE-COUNT INDEX). ;;; Replace all unreferenced tags with nil in code, ;;; and construct and return the initial value for PEEP-TAG-ALIST. (DEFUN PEEP-TAGS () ;; 9/05/86 DNG - Add handling for tags referenced by DISPATCH table. (LET ((TAG-ALIST NIL) (CODE (PEEP-LIST-AT-INDEX PEEP-CODE-START-INDEX))) (FLET ((RECORD-TAG (TAG) (LET ((TEM (ASSOC TAG TAG-ALIST :TEST #'EQ))) (IF TEM (INCF (CADR TEM)) (PUSH (LIST TAG 1 NIL) TAG-ALIST))) NIL)) (MAPC #'(LAMBDA (INSN) (UNLESS (ATOM INSN) (CASE (CAR INSN) (BRANCH (RECORD-TAG (FIFTH INSN))) ((DISPATCH SELECT) (RECORD-TAG (SECOND INSN)) (LET ((TABLE (THIRD INSN))) (DOTIMES (I (LENGTH TABLE)) (LET ((TAG (AREF TABLE I))) (RECORD-TAG TAG))))) ))) CODE) ) (MAPL #'(LAMBDA (INSN-PTR &AUX TEM) (AND (ATOM (CAR INSN-PTR)) (NOT (GET (CAR INSN-PTR) 'PEEP-KEEP)) (IF (SETQ TEM (ASSOC (CAR INSN-PTR) TAG-ALIST :TEST #'EQ)) (SETF (CADDR TEM) (%POINTER-DIFFERENCE INSN-PTR (LOCF (AREF PEEP-CODE-ARRAY 0)))) (RPLACA INSN-PTR NIL)))) CODE) TAG-ALIST)) ;; Call when a reference to a tag has been deleted. ;; If the tag is now unreferenced, delete it ;; and do any optimizations between the instructions before and after it. (DEFUN PEEP-DELETE-TAG-REF (TAG) ;; 01/14/85 DNG - Queue branch following deleted tag to prevent ;; missing oppportunities for cross-jumping. (UNLESS (GET TAG 'PEEP-KEEP) (LET ((ELT (ASSOC TAG PEEP-TAG-ALIST :TEST #'EQ))) (DECF (CADR ELT)) (WHEN (ZEROP (CADR ELT)) (LET ((INDEX (CADDR ELT))) (SETF (AREF PEEP-CODE-ARRAY INDEX) NIL) ;; If the deleted tag is followed by an unconditional branch, ;; need to take another look at the branch instruction for ;; cross-jumping. (LOOP FOR NEXT-INSN-INDEX FROM (+ INDEX 1) TO PEEP-SCANNING-INDEX FOR NEXT-INSN = (AREF PEEP-CODE-ARRAY NEXT-INSN-INDEX) WHILE (NULL NEXT-INSN) FINALLY (WHEN (AND (CONSP NEXT-INSN) (EQ (FIRST NEXT-INSN) 'BRANCH) (EQ (SECOND NEXT-INSN) 'ALWAYS)) (PEEP-QUEUE NEXT-INSN-INDEX))) ;; Take another look at the instruction preceding the tag. (PEEP-LOCALLY INDEX)))))) (DEFUN PEEP-CREATE-TAG-REF (TAG) (LET ((ELT (ASSOC TAG PEEP-TAG-ALIST :TEST #'EQ))) (INCF (CADR ELT)))) ;; Insertion of new tags must be requested carefully, because it can invalidate ;; the indices that you have saved in your local variables. ;; Use PEEP-UPDATING-INDEX on each index you wish to have relocated ;; across each call to any of these functions. ;; Return a tag that is at INDEX (or the same pc), ;; inserting one if necessary. (DEFUN PEEP-FIND-OR-INSERT-TAG (INDEX) (LET ((LENGTH (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY)) TEM) (OR (DO ((I INDEX (1+ I))) ((= I LENGTH)) (WHEN (SETQ TEM (AREF PEEP-CODE-ARRAY I)) (IF (ATOM TEM) (RETURN TEM) (RETURN)))) (DO ((I (1- INDEX) (1- I))) ((< I PEEP-CODE-START-INDEX)) (WHEN (SETQ TEM (AREF PEEP-CODE-ARRAY I)) (IF (ATOM TEM) (RETURN TEM) (RETURN)))) (PEEP-INSERT-TAG INDEX)))) (DEFMACRO PEEP-UPDATE-INDEX (NUM) `(IF (>= ,NUM INDEX) (INCF ,NUM))) (DEFUN PEEP-INSERT-TAG (INDEX) (WHEN (= (ARRAY-TOTAL-SIZE PEEP-CODE-ARRAY) (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY)) (ADJUST-ARRAY PEEP-CODE-ARRAY (+ (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY) 100))) (%BLT-TYPED (LOCF (AREF PEEP-CODE-ARRAY (1- (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY)))) (LOCF (AREF PEEP-CODE-ARRAY (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY))) (- (ARRAY-ACTIVE-LENGTH PEEP-CODE-ARRAY) INDEX) -1) (DOLIST (ELT PEEP-TAG-ALIST) (PEEP-UPDATE-INDEX (CADDR ELT))) (DO ((L PEEP-INDEX-LIST (CDR L))) ((NULL L)) (PEEP-UPDATE-INDEX (CAR L))) (DO ((L PEEP-QUEUE (CDR L))) ((NULL L)) (PEEP-UPDATE-INDEX (CAR L))) (DO ((L PEEP-DEAD-ENDS (CDR L))) ((NULL L)) (PEEP-UPDATE-INDEX (CAR L))) (PEEP-UPDATE-INDEX PEEP-SCANNING-INDEX) (INCF (FILL-POINTER PEEP-CODE-ARRAY)) (IF-DEBUG (INCF INSERT-COUNT)) (LET ((TAG (GENSYM))) (PUSH (LIST TAG 0 INDEX) PEEP-TAG-ALIST) (SETF (AREF PEEP-CODE-ARRAY INDEX) TAG) TAG)) ;Change the instruction BRANCH-INSN to branch to a tag at index NEW-INDEX. ;A new tag is created if there is no suitable one. (DEFUN PEEP-CHANGE-BRANCH-TO-INDEX (BRANCH-INSN NEW-INDEX) (LET ((OTAG (FIFTH BRANCH-INSN))) (SETF (FIFTH BRANCH-INSN) (PEEP-FIND-OR-INSERT-TAG NEW-INDEX)) (PEEP-CREATE-TAG-REF (FIFTH BRANCH-INSN)) (PEEP-DELETE-TAG-REF OTAG)))