%INCLUDE "ERCC07.TRIMP_TFORM1S"
      %INCLUDE "ERCC07.TRIPCNSTS"
%EXTRINSICRECORD(WORKAF) WORKA
%EXTRINSICRECORD(PARMF) PARM
%CONSTINTEGER YES=1
%CONSTINTEGER NO=0
%EXTERNALROUTINESPEC IMPABORT
%EXTERNALROUTINESPEC FAULT(%INTEGER N,DATA,IDENT)
%EXTERNALROUTINESPEC PRINT TRIPS(%RECORD(TRIPF) %ARRAYNAME TRIPLES)
%CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,1,2,4; 
%ROUTINE EXTRACT(%RECORD(RD) %NAME OPND, %INTEGERNAME VAL,
    %LONGREALNAME RVAL, %STRINGNAME STRVAL)
!***********************************************************************
!*    EXTRACTS A CONTANT OPERAND RETURNING REAL &INT VALUES           *
!***********************************************************************
%INTEGER TYPE,PREC,I,AD
      TYPE=OPND_PTYPE; PREC=TYPE>>4
      TYPE=TYPE&15
      VAL=0; RVAL=0; STRVAL=""
      %IF TYPE=5 %START
         LENGTH(STRVAL)=WORKA_A(OPND_D)
         %FOR I=1,1,OPND_XTRA %CYCLE
            CHARNO(STRVAL,I)=WORKA_A(OPND_D+I)
         %REPEAT
      %FINISHELSEIF TYPE=1 %THENSTART
         VAL=OPND_D
         RVAL=VAL
      %FINISHELSESTART
         %IF PREC=5 %THEN RVAL=OPND_R %ELSE RVAL=OPND_LR
      %FINISH
%END
%EXTERNALROUTINE CTOP(%INTEGERNAME FLAG,MASK, %INTEGER XTRA,
    %RECORD(RD) %NAME OPND1,OPND2)
!***********************************************************************
!*    AN OPERATION HAS BEEN FOUND WHERE BOTH OPERANDS ARE              *
!*    CONSTANTS OR KNOWN AT COMPILE TIME. THIS ROUTINE INTERPRETS      *
!*    THE OPERATION                                                    *
!*    ON EXIT FLAG=0 IF INTERPRETED. REFRAINS FROM INTERPRETING        *
!*    X=1/0 FOR EXAMPLE. CODE IS PLANTED FOR THESE FUNNIES             *
!***********************************************************************
%CONSTINTEGER UTRUNCMASK=X'00000800',BTRUNCMASK=X'00000013'
%CONSTBYTEINTEGERARRAY FCOMP(1:14)= %C
                                        8,10,2,7,12,4,7,
                                        8,12,4,7,10,2,7

%INTEGER K,TYPEP,PRECP,OP,VAL,SVAL1,SVAL2,C,D,JJ,KK,TRUNCMASK
%STRING(255) STRVAL1,STRVAL2
!%LONGINTEGER VAL1,VAL2
%INTEGER VAL1,VAL2
!%LONGLONGREAL RVAL1,RVAL2
%LONGREAL RVAL1,RVAL2
%SWITCH UISW,URSW(10:40),BISW,BRSW(0:24)
      %ONEVENT 1,2 %START
         %RETURN
      %FINISH
      TYPEP=OPND1_PTYPE&7; PRECP=OPND1_PTYPE>>4&15; OP=FLAG
      EXTRACT(OPND1,VAL1,RVAL1,STRVAL1)
      SVAL1<-VAL1
      %IF OP<128 %START;                ! UNARY
         %RETURNUNLESS 10<=OP<=40
         TRUNCMASK=UTRUNCMASK
         %IF TYPEP=2 %THEN ->URSW(OP) %ELSE ->UISW(OP)
      %FINISH
      OP=OP-128
      %RETURNIF OP>24
      EXTRACT(OPND2,VAL2,RVAL2,STRVAL2)
      SVAL2<-VAL2
      %IF TYPEP=2 %THEN ->BRSW(OP) %ELSE ->BISW(OP)
UISW(10):                               ! \
      VAL1=\VAL1
INTEND:
!      %IF PRECP=6 %THEN %START
!         OPND1_D<-VAL1>>32
!         OPND1_XTRA<-VAL1
!         FLAG=0
!      %FINISH %ELSE %START
      VAL<-VAL1
      %IF VAL=VAL1 %OR 1<<OP&TRUNCMASK=0 %THEN FLAG=0 %AND OPND1_D=VAL
! NO ARITH OFLOW CONDITION
!      %FINISH
      %IF FLAG=0 %START
         OPND1_PTYPE=PRECP<<4!1
         %IF X'FFFF8000'<=VAL1<=X'FFFF' %THEN OPND1_FLAG=0 %ELSE OPND1_FLAG=1
      %FINISH
      %RETURN
UISW(11):                               ! INTEGER NEGATE
      VAL1=-VAL1; ->INT END
UISW(13):                               ! INTEGER ABS
      VAL1=IMOD(VAL1); ->INT END
UISW(12):                               ! INTEGER FLOAT
      RVAL1=VAL1; PRECP=PRECP+1
      ->REAL END
URSW(15):                               ! STRETCH REAL
      PRECP=PRECP+1
REAL END:OPND1_FLAG=1
      %IF PRECP=5 %THEN OPND1_R=RVAL1 %ELSE OPND1_LR=RVAL1
!      %IF PRECP=7 %THEN %START
!         OPND1_FLAG=3
!         OPND1_XTRA=ADDR(A(R))
!         %CYCLE K=0,1,15
!            A(R)=BYTEINTEGER(ADDR(RVAL1)+K)
!            R=R+1
!         %REPEAT
!      %FINISH
      FLAG=0; OPND1_PTYPE=16*PRECP+2
      %RETURN
UISW(15):                               ! STRETCH INTEGER
      %IF PRECP=4 %THEN PRECP=5 %AND ->INT END
      %RETURN
UISW(14):                               ! SHORTEN INTEGER
      %IF IMOD(VAL1)<=X'7FFF' %THEN PRECP=4 %AND ->INT END
      %RETURN
URSW(14):                               ! SHORTEN REAL
      PRECP=PRECP-1
      ->REAL END
URSW(12):                               ! FLOAT REAL
      IMPABORT
UISW(16):                               ! SHORTEN FOR <-
      %IF PRECP=5 %THEN VAL1=VAL1&X'FFFF' %AND PRECP=4 %AND ->INTEND
      %RETURN
URSW(36):                               ! INT
      %RETURNUNLESS MOD(RVAL1)<X'7FFFFFFE'
      VAL1=INT(RVAL1)
      PRECP=5
      ->INTEND
URSW(37):                               ! INTPT
      %RETURNUNLESS MOD(RVAL1)<X'7FFFFFFE'
      VAL1=INTPT(RVAL1)
      PRECP=5
      ->INTEND
UISW(38):                               ! TOSTRING
      STRVAL1=TOSTRING(VAL1)
      ->STREND
BISW(0):                                ! ADD
BISW(14):                               ! COMBINE VMY RESULTS
      VAL1=VAL1+VAL2; ->INT END
BISW(1):                                ! MINUS
      VAL1=VAL1-VAL2; ->INT END
BISW(2):                                ! EXCLUSIVE OR
      VAL1=VAL1!!VAL2; ->INT END
BISW(3):                                ! OR
      VAL1=VAL1!VAL2; ->INT END
BISW(4):                                ! MULT
      VAL1=VAL1*VAL2; ->INT END
BISW(6):%RETURN;                        ! / DIVISION
BISW(5):%RETURNIF VAL2=0;               ! // DIVISION
      VAL1=VAL1//VAL2; ->INT END
BISW(7):                                ! AND
      VAL1=VAL1&VAL2; ->INT END
BISW(9):                                ! SLL
      %IF PRECP=6 %THEN VAL1=VAL1<<SVAL2 %ELSE VAL1=SVAL1<<SVAL2
      ->INT END
BISW(8):                                ! SRL
      %IF PRECP=6 %THEN VAL1=VAL1>>SVAL2 %ELSE VAL1=SVAL1>>SVAL2
      ->INT END
BISW(13):                               ! VMY & CHK BOUNDS
      C=VAL2>>24;                       ! DIMENSION
      D=VAL2&X'FFFF';                   ! DV POINTER
      %RETURNUNLESS D>0;                ! UNLESS DV AVAILABLE
      %IF VAL1<WORKA_CTABLE(D+3*C+1) %OR VAL1>WORKA_CTABLE(D+3*C) %THEN %C
         FAULT(50,VAL1,XTRA&X'FFFF')
      VAL1=VAL1*WORKA_CTABLE(D+3*C-1) %UNLESS C=1
      ->INT END
BISW(18):                               ! ARRAY SCALE
      D=VAL2>>16&31;                    ! TOTAL NO OF DIMENSIONS
      KK=VAL2&X'FFFF';                  ! DV DISP
      %RETURNUNLESS KK>0
      JJ=WORKA_CTABLE(KK+4);            ! LB(1)
      C=6
      %WHILE C<=3*D %CYCLE
         JJ=JJ+WORKA_CTABLE(KK+C-1)*WORKA_CTABLE(KK+C+1)
         C=C+3
      %REPEAT
      VAL1=VAL1-JJ
      ->INT END
BISW(11):
BISW(12):                               ! COMPARISONS
BRSW(11):
BRSW(12):                               ! REAL COMPARISONS
      MASK=FCOMP(XTRA)
      FLAG=0
      %IF TYPEP=2 %THEN ->RCOMP
      %IF(MASK&8#0 %AND VAL1=VAL2) %OR(MASK&4#0 %AND VAL1<VAL2) %OR %C
         (MASK&2#0 %AND VAL1>VAL2) %THEN MASK=15 %ELSE MASK=0
      %RETURN
RCOMP:
      %IF(MASK&8#0 %AND RVAL1=RVAL2) %OR(MASK&4#0 %AND RVAL1<RVAL2) %OR %C
         (MASK&2#0 %AND RVAL1>RVAL2) %THEN MASK=15 %ELSE MASK=0
      %RETURN
URSW(11):                               ! NEGATE
      RVAL1=-RVAL1; ->REAL END
BRSW(13):                               ! ABS
      RVAL1=MOD(RVAL1); ->REAL END
BRSW(0):                                ! ADD
      RVAL1=RVAL1+RVAL2; ->REAL END
BRSW(1):                                ! SUBTRACT
      RVAL1=RVAL1-RVAL2; ->REAL END
BRSW(4):                                ! MULT
      RVAL1=RVAL1*RVAL2; ->REAL END
BRSW(6):                                ! DIVISION
      %RETURNIF RVAL2=0;                ! AVOID DIV BY ZERO
      RVAL1=RVAL1/RVAL2; ->REAL END
BISW(10):                               ! '**' WITH 2 INTEGER OPERANDS
BRSW(10):                               ! '**' WITH AT LEAST 1 REAL
      %RETURNUNLESS OPND2_PTYPE&7=1 %AND-63<=VAL2<=63
      RVAL1=RVAL1**VAL2
      ->REALEND
BISW(17):                               ! '****' WITH 2 INTEGER OPERAND
      %RETURNUNLESS 0<=VAL2<=63
      VAL2=1
      %WHILE SVAL2>0 %CYCLE
         VAL2=VAL2*VAL1
         SVAL2=SVAL2-1
!         %RETURN %IF VAL2#INTEGER(ADDR(VAL2)+4)
      %REPEAT
      VAL1=VAL2; ->INT END
BISW(24):                               ! CONCAT
      %RETURNIF LENGTH(STRVAL1)+LENGTH(STRVAL2)>255
      STRVAL1=STRVAL1.STRVAL2
STREND:                                 ! RETURN VALUE
      OPND1_PTYPE=X'35'
      OPND1_FLAG=LCONST
      OPND1_XTRA=LENGTH(STRVAL1)
      JJ=WORKA_ARTOP
      WORKA_A(JJ)=OPND1_XTRA
      %FOR K=1,1,OPND1_XTRA %CYCLE
         WORKA_A(JJ+K)=CHARNO(STRVAL1,K)
      %REPEAT
      OPND1_D=JJ
      WORKA_ARTOP=(JJ+OPND1_XTRA+2)&(-2); ! PERQ KEEP 16 BIT ALIGNED
      FLAG=0
      %RETURN
URSW(*):
UISW(*):
BRSW(*):
BISW(*):
%END
%EXTERNALROUTINE FLAG AND FOLD(%RECORD(TRIPF) %ARRAYNAME TRIPLES)
!***********************************************************************
!*    WORKS DOWN AN ARRAY OF TRIPLES SETTING BITS FOR CODE GENERATOR   *
!*    ALSO FOLDS OUT ANY REMAINING CONSTANT OPERATIONS                 *
!***********************************************************************
%INTEGER STPTR,CURRTRIPNO,I,J,DEPTH
%CONSTINTEGER FOLDI=X'1C00007F';        ! FOLD 10-16 & 36-38
%CONSTINTEGER FOLDR=X'0107FFFF';        ! FOLD 128-146 &152
%RECORD(TRIPF) %NAME CURRT,REFT
%ROUTINESPEC INSPECT OPND(%INTEGER NO)
%ROUTINESPEC REPLACE TRIPREF(%INTEGER TRIP, %RECORD(RD) %NAME OPND)
      STPTR=TRIPLES(0)_FLINK
      DEPTH=0
!
      %WHILE STPTR>0 %CYCLE
         CURRT==TRIPLES(STPTR)
         CURRTRIPNO=STPTR
         STPTR=CURRT_FLINK
         INSPECT OPND(1)
         %IF CURRT_OPERN>=128 %THEN INSPECT OPND(2)
!
         %IF CURRT_FLAGS&CONSTANTOP#0 %AND((CURRT_OPERN<128 %AND %C
            FOLDI&1<<(CURRT_OPERN-10)#0) %OR(CURRT_OPND1_FLAG<=1 %AND %C
            CURRT_OPND2_FLAG<=1 %AND FOLDR&1<<(CURRT_OPERN&31)#0)) %START
            I=CURRT_OPERN
            CTOP(I,J,CURRT_X1,CURRT_OPND1,CURRT_OPND2)
            %IF I=0 %THENSTART
               CURRT_X1=CURRT_OPERN;    ! FOR DEBUGGING OPTIMISATIONS
               CURRT_OPERN=NULLT
               REPLACE TRIPREF(CURR TRIPNO,CURRT_OPND1)
            %FINISH
         %FINISH
         %IF CURRT_OPERN=LASS %AND CURRT_FLAGS&CONSTANTOP#0 %AND %C
            CURRT_CNT>0 %THEN REPLACE TRIPREF(CURRTRIPNO,CURRT_OPND2)
         CURRT_DPTH<-DEPTH
         %IF CURRT_CNT>0 %AND CURRT_OPTYPE&7#2 %C
            %THEN DEPTH=DEPTH+WORDS(CURRT_OPTYPE>>4)
      %REPEAT
      %RETURN
%ROUTINE INSPECT OPND(%INTEGER NO)
%RECORD(TRIPF) %NAME RTRIP
%RECORD(RD) %NAME OPND
%CONSTBYTEINTEGERARRAY LOAD ALLOW(0:199)=LOAD OP1(128){UNARY},
                                        LOADOP1!LOADOP2(10),
                                        LOADOP1{**},
                                        LOADOP1!LOADOP2(2),
                                        LOADOP1{VMY},
                                        LOADOP1!LOADOP2,
                                        LOADOP2(2){ASS AND JAM ASS},
                                        LOADOP1{****},
                                        LOADOP1{SCALE},
                                        LOADOP1!LOADOP2,
                                        LOADOP2{INDEXED FETCH},
                                        LOADOP2{LASS},
                                        LOADOP1!LOADOP2(3),
                                        LOADOP2{IOCP DONT LOAD EPNO},
                                        LOADOP2(6){P PASSING},
                                        0(6){LABELS AND SWITCH DECLS},
                                        LOADOP2{GOTO SW LOAD OPERAND},
                                        LOADOP2(7){STR,PTR&RESULT ASSMNT},
                                        LOADOP1!LOADOP2(2){STR COMP&DCOMP},
                                        LOADOP2(2){PRE RES DONT LD WKAREA},
                                        LOADOP1{RESLN DONT LOAD LABEL},
                                        LOADOP2{RES FINALE DONT LOAD WKAREA},
                                        LOADOP1!LOADOP2{SIG EVNT UNUSED},
                                        LOADOP2{REC ASSNMNT},
                                        LOADOP1!LOADOP2(*);
%INTEGER I,LOADOP
      OPND==CURRT_OPND1
      LOADOP=LOAD OP1
      %IF NO=2 %THEN OPND==CURRT_OPND2 %AND LOADOP=LOAD OP2
      LOADOP=LOADOP&LOAD ALLOW(CURRT_OPERN)
      %IF OPND_FLAG<=1 %THEN CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
      %IF OPND_FLAG<8 %THEN CURRT_FLAGS=CURRT_FLAGS!LOADOP
      %IF OPND_FLAG=REFTRIP %OR OPND_FLAG=INDIRECT %START
         RTRIP==TRIPLES(OPND_D)
         %IF RTRIP_PUSE#CURRTRIPNO %OR %C
            (RTRIP_OPERN=LASS %AND RTRIP_FLINK#CURRTRIPNO)  %OR %C
            RTRIP_OPERN=PRECC %OR RTRIP_OPERN=CONCAT %OR %C
            RTRIP_OPERN=ITOS1 %THEN CURRT_FLAGS=CURRT_FLAGS!LOADOP
         %IF RTRIP_PUSE=CURRTRIPNO %AND RTRIP_OPTYPE&7#2 %C
         %THEN DEPTH=DEPTH-WORDS(RTRIP_OPTYPE>>4)
      %FINISH
%END
%ROUTINE REPLACE TRIPREF(%INTEGER TRIP, %RECORD(RD) %NAME OPND)
%INTEGER PTR
%BYTEINTEGERNAME COUNT
%RECORD(TRIPF) %NAME RTRIP
      PTR=STPTR
      COUNT==TRIPLES(TRIP)_CNT
      %WHILE COUNT>0 %AND PTR>0 %CYCLE
         RTRIP==TRIPLES(PTR)
         PTR=RTRIP_FLINK
         %IF RTRIP_OPND1_FLAG=REFTRIP %AND RTRIP_OPND1_D=TRIP %START
            RTRIP_OPND1=OPND
            COUNT=COUNT-1
         %FINISH
         %IF RTRIP_OPERN>=128 %AND RTRIP_OPND2_FLAG=REFTRIP %AND %C
            RTRIP_OPND2_D=TRIP %START
            RTRIP_OPND2=OPND
            COUNT=COUNT-1
         %FINISH
      %REPEAT
%END
%END
%EXTERNALROUTINE TRIP OPT(%RECORD(TRIPF) %ARRAYNAME TRIPLES,
    %INTEGERNAME NEXT TRIP)
!***********************************************************************
!*    SCANS A TRIPLES LIST FOR POSSIBLE OPTIMISATIONS                  *
!***********************************************************************
%INTEGER CHANGES,DUPS,DUPTNO,PTR,I,J,K,VAL,XVAL,CURR,NEXT,OP1,OP2,
         CTOPOP,REVOP
%BYTEINTEGERARRAYNAME A
%RECORD(TRIPF) %NAME CURRT,NEWT,NEXTT
%RECORD(RD) %NAME OPND1,OPND2,POPND
%ROUTINESPEC SWOP OPERANDS(%RECORD(TRIPF)%NAME CURRT)
%INTEGERFNSPEC POWEROF2(%INTEGER VAL)
%INTEGERFNSPEC PRELOAD PLACE(%INTEGER TRIP)
%ROUTINESPEC NOOP(%INTEGER TRIPLE, %RECORD(RD) %NAME ROPND)

%INTEGERFNSPEC SAME OPND(%RECORD(RD) %NAME OPND1,OPND2)
%ROUTINESPEC CHECK DUPS(%INTEGER STRIPNO,STRIPNO)
%ROUTINESPEC DUPLICATE TRIP(%INTEGER TRIPNO,DTRIPNO)
%ROUTINESPEC DEC USE(%INTEGER TRIPLE NO)
%ROUTINESPEC DELETE TRIPLE(%INTEGER TRIPLE NO)
%CONSTBYTEINTEGERARRAY FOLD NOOP INFO(0:199)= 0(128),
                    X'89',X'41',X'89',X'89',X'B6',{+,-,!!,!,*} %C
                    2,0,X'A4',1,1,{//,/,&,>>,<<} %C
                    2,0,0,3,X'89',{**,COMP,DCOMP,VMY,COMB} %C
                    0,0,2,0,1,{=,<-,****,SCALE,INDEX} %C
                    0{IFETCH},0(3),
                    X'40'{CONCAT},0(*)

! 2**0 SET IF SECOND OPERAND ZERO IS NOOP
! 2**1 SET IF SECOND OPERAND 1 IS A NOOP
! 2**2 SET IF SECOND OPERAND 0 MEANS RESULT=0
! 2**3 SET IF FIRST OPERAND ZERO IS NOOP
! 2**4 SET IF FIRST OPERAND 1 IS A NOOP
! 2**5 SET IF  FIRST OPERAND ZERO MEANS RESULT=0
! 2**6 SET IF FOLDING WITH ITSELF POSSIBLE BUT NOT SIMPE
! 2**7 SET FOR NORMAL FOLDING
!
      CHANGES=0;                        ! NO CHANGES AS YET
      DUPS=0;                           ! NO DUPLICATES YET

      FLAG AND FOLD(TRIPLES)
      A==WORKA_A
!
! ADVANCED FOLDING FACTOR CONSTANTS OUT OF 2 OR MORE TRIPLES
! TO SAVE AN OPERATION. ONLY MORE USUSAL CASE CATERED FOR AS IN
! VAR+CONST+CONST.
!
      PTR=TRIPLES(0)_FLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         NEXT=CURRT_FLINK
         %EXITIF NEXT<=0
         NEXTT==TRIPLES(NEXT)
         %WHILE NEXTT_OPERN=NULLT %AND NEXTT_FLINK>0 %CYCLE
            NEXT=NEXTT_FLINK;           ! SKIP OVER ANY NOOPS
            NEXTT==TRIPLES(NEXT)
         %REPEAT
         %UNLESS CURRT_CNT=1 %AND NEXTT_CNT=1 %AND %C
            CURRT_FLAGS&NEXTT_FLAGS&CONSTANTOP#0 %AND CURRT_PUSE=NEXT %THEN %C
            PTR=NEXT %ANDCONTINUE
         PTR=NEXT %ANDCONTINUEUNLESS(CURRT_FLAGS!NEXTT_FLAGS)&DONT OPT=0
         J=CURRT_OPERN
         K=NEXTT_OPERN
         %UNLESS FOLD NOOP INFO(J)>>6#0 %AND FOLD NOOP INFO(K)>>6#0 %THEN %C
            PTR=NEXT %ANDCONTINUE
         %IF CURRT_OPND1_FLAG<=1 %THEN OP1=1 %AND OPND1==CURRT_OPND1 %ELSE %C
            OP1=2 %AND OPND1==CURRT_OPND2
         %IF NEXTT_OPND1_FLAG<=1 %THEN OP2=1 %AND OPND2==NEXTT_OPND1 %ELSE %C
            OP2=2 %AND OPND2==NEXTT_OPND2
         CTOPOP=0; REVOP=0
         %IF J=K %AND FOLD NOOP INFO(J)&X'80'#0 %THEN CTOPOP=J
         %IF J=K=SUB %START
            %IF OP2=2 %START
               %IF OP1=2 %THEN CTOPOP=ADD %ELSE CTOPOP=SUB
            %FINISH %ELSE %START;          ! OP2=1 CASE
               %IF OP1=1 %THEN CTOPOP=SUB %AND REVOP=ADD %ELSE CTOPOP=ADD
            %FINISH
         %FINISH
         %IF J=ADD %AND K=SUB %AND OP2=2 %THEN CTOPOP=SUB
         %IF J=SUB %AND K=ADD %THENSTART
            %IF OP1=1 %THEN CTOPOP=ADD %ELSE CTOPOP=SUB
         %FINISH
         %IF J=K=CONCAT %AND OP1=OP2=2 %THEN CTOPOP=CONCAT
         %IF CTOPOP#0 %START
            CTOP(CTOPOP,K,0,OPND1,OPND2)
            %IF CTOPOP=0 %THENSTART
               %IF OP2=2 %THEN OPND2==NEXTT_OPND1 %ELSE OPND2==NEXTT_OPND2
               NOOP(NEXT,OPND2)
               %IF REVOP#0 %THEN CURRT_OPERN=REVOP
               %CONTINUE
            %FINISH
         %FINISH
         PTR=NEXT
      %REPEAT
!      %IF CHANGES>0 %THEN PRINT TRIPS(TRIPLES)
!
! FIRST REAL OPTIMISATION IS TO SEARCH FOR AND REMOVE NOPS
! LIKE *1 OR <<0 OR +0 ETC. THESE ARE SURPRISINGLY COMMON
! IN PROGRAMS MADE MACHINE INDEPENDENT BY LIBERAL USE
! OF CONSTANT VARIABLES
!
! ALSO DOES A FEW REARRANGEMENTS OF SIMPLE COMPARISONS AND ARITHMETICS
!
      PTR=TRIPLES(0)_FLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR);           ! EXAMINE EACH TRIPLE
         CURR=PTR
         PTR=CURRT_FLINK
         %CONTINUEIF CURRT_FLAGS&DONT OPT#0 %OR CURRT_FLAGS&CONSTANTOP=0
         I=CURRT_OPERN
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
         %IF OPND1_FLAG<=1 %THEN OP1=1 %AND VAL=OPND1_D %AND XVAL=OPND1_XTRA %C
               %ELSE OP1=2 %AND VAL=OPND2_D %AND XVAL=OPND2_XTRA
         %IF I=DCOMP %AND OP1=2 %START;! EXPAND I=0=J ETC
            I=COMP; CURRT_OPERN=COMP
            NEXTT==TRIPLES(CURRT_PUSE)
            NEXTT_OPND1=OPND2
            NEXTT_FLAGS=NEXTT_FLAGS!LOADOP1
         %FINISH
         %IF I=COMP %START
            J=CURRT_X1&15;                 ! IBM COND MASK
            %IF CURRT_OPTYPE&7=1 %START;! TRANSFORM I>=1 TO I>0 ETC
               %IF (OP1=2 %AND  ((VAL=1 %AND (J=4 %OR J=10)) %C
                  %OR (VAL=-1 %AND (J=2 %OR J=12)))) %C
                  %OR (OP1=1 %AND ((VAL=1 %AND (J=2 %OR J=12)) %C
                  %OR (VAL=-1 %AND (J=4 %OR J=10)))) %START
                  J=J!!8
                  CURRT_X1=CURRT_X1!!8
                  NEXTT==TRIPLES(CURRT_FLINK)
                  NEXTT_X1=NEXTT_X1!!8; ! ALSO ALTER MASK IN THE JUMP 
                  VAL=0
                  %IF OP1=2 %THEN OPND2_D=0 %ELSE OPND1_D=0
               %FINISH
            %FINISH
            %IF VAL=0 %AND 7<=J<=8 %AND(XVAL=0 %OR CURRT_OPTYPE>>4<=5) %START
               CURRT_OPERN=ZCOMP
               %IF OP1=1 %THEN SWOP OPERANDS(CURRT)
               CURRT_FLAGS=CURRT_FLAGS&(\LOADOP2)!DONT OPT
            %FINISH
         %FINISH
         %IF (I=LSHIFT %OR I=RSHIFT) %AND 1<=VAL<=31 %AND %C
            OP1=2 %START;               ! <<CONST AND >> CONST
            CURRT_OPERN=CLSHIFT
            %IF I=RSHIFT %THEN VAL=-VAL %AND OPND2_D=VAL
            I=CLSHIFT
            CURRT_FLAGS=CURRT_FLAGS&(\LOADOP2)
         %FINISH
         %IF I=INTDIV %AND OP1=2 %AND VAL>1 %START
            J=POWEROF2(VAL)
            %IF J>0 %START
               CURRT_OPERN=CASHIFT
               I=CASHIFT
               OPND2_D=-J
               CURRT_FLAGS=CURRT_FLAGS&(\LOADOP2)
            %FINISH
         %FINISH
         %IF I=MULT %AND VAL>1 %AND CURRT_OPTYPE&15=1 %START
            J=POWEROF2(VAL)
            %IF J>0 %START
               %IF OP1=1 %THEN SWOP OPERANDS(CURRT)
               CURRT_OPERN=CASHIFT
               I=CASHIFT
               OPND2_D=J
               CURRT_FLAGS=CURRT_FLAGS&(\LOADOP2)
            %FINISH
         %FINISH
         %IF I>=128 %THENSTART;         ! BINARY OPERATIONS
            %IF I=VMY %THEN VAL=VAL>>24;! DIM=1 IS NOOP
            J=FOLD NOOP INFO(I)&X'3F'
            %CONTINUEUNLESS VAL<=1 %AND J#0 %AND CURRT_OPTYPE&7=1
            POPND==OPND1;               ! FOR PASSING FORWARD
            %IF OP1=1 %THEN K=3 %AND POPND==OPND2 %ELSE K=0;! BIT SHIFT FOR MASK
            %IF(J&(1<<K)#0 %AND VAL=0) %OR(J&(2<<K)#0 %AND VAL=1) %START
               NOOP(CURR,POPND);        ! THIS IS NOOP
               %CONTINUE
            %FINISH
            %IF J&(4<<K)#0 %AND VAL=0 %THENSTART
               %IF OPND1_FLAG=REFTRIP %THEN DEC USE(OPND1_D)
               %IF OP1=2 %THEN OPND1=OPND2; ! RESULT IS ZERO
               NOOP(CURR,OPND1)
                                        ! MAY CAUSE OTHER NOOPS
                                        ! GE I=(A+B)*0
            %FINISH
            %IF VAL=0 %AND OP1=1 %AND CURRT_OPERN=SUB %THEN %C
               OPND1=OPND2 %AND CURRT_OPERN=LNEG;! OPTIMISE"0-X"
         %FINISH
      %REPEAT
!
! PASS TO CHECK FOR COMMON SUBEXPRESSIONS. DONE IN SUCH A WAY THAT
! SEQUENCES ARE DETECTED AND COMBINED
!
      PTR=TRIPLES(0)_FLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         %IF CURRT_FLAGS&DONT OPT=0 %THEN CHECK DUPS(PTR,CURRT_FLINK)
         PTR=CURRT_FLINK
      %REPEAT
!
! NESTED ACCUMULATOR PASS. AVOID EXCHANGES BY ARRANGING EARLY LOADS
! OF OPERANDS FOR NON COMMUTABLE OPERATIONS
!
      PTR=TRIPLES(0)_FLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         %IF CURRT_OPERN>=128 %AND CURRT_OPERN#VASS %AND CURRT_OPERN#VJASS %C
            %AND CURRT_OPTYPE&7#2 %AND CURRT_FLAGS&(LOADOP1!LOADOP2!COMMUTABLE)=LOADOP1 %C
            %AND CURRT_OPND2_FLAG=REFTRIP %AND 1<<CURRT_OPND1_FLAG&BTREFMASK=0 %START
            J=PRELOAD PLACE(CURRT_OPND2_D)
            %IF J>=0 %AND CURRT_DPTH=TRIPLES(J)_DPTH %START;! PLACE ACCESSIBLE
               I=J; K=0
               %WHILE I#PTR %CYCLE;     ! CHECK FOR DEPTH OF NESTING
                  NEXTT==TRIPLES(I)
               %IF NEXTT_OPERN=IOCPC %OR NEXTT_OPERN=PRECL %C
                  %THEN K=999 %AND %EXIT
                  %IF K<NEXTT_DPTH %THEN K=NEXTT_DPTH
                  I=NEXTT_FLINK
               %REPEAT
               %IF K+WORDS(CURRT_OPTYPE>>4)>=6 %THEN %C
                  PTR=CURRT_FLINK %ANDCONTINUE
               NEXTT==TRIPLES(J)
               NEWT==TRIPLES(NEXT TRIP)
               NEWT=0
               NEWT_OPERN=PRELOAD;      ! PRELOAD
               NEWT_CNT=1
               NEWT_OPTYPE=CURRT_OPTYPE
               NEWT_FLAGS=LOADOP1!LEAVE STACKED
               NEWT_PUSE=PTR
               NEWT_OPND1=CURRT_OPND1
               CURRT_FLAGS=CURRT_FLAGS&(\LOAD OP1); ! OP1 DOES NOT NEED LOAD
               CURRT_OPND1_FLAG=REFTRIP
               CURRT_OPND1_D=NEXT TRIP
               CURRT_OPND1_XTRA=0
                                        ! LINK IN NEW TRIPLE
               NEWT_FLINK=J
               NEWT_BLINK=NEXTT_BLINK
               NEXTT_BLINK=NEXT TRIP
               TRIPLES(NEWT_BLINK)_FLINK=NEXT TRIP
               NEXT TRIP=NEXT TRIP+1
!
! CORRECT DEPTH OF NESTING FIELD
!
               NEWT_DPTH=NEXTT_DPTH
               %WHILE J#PTR %CYCLE
                  NEXTT_DPTH=NEXTT_DPTH+WORDS(NEWT_OPTYPE>>4)
                  J=NEXTT_FLINK
                  NEXTT==TRIPLES(J)
               %REPEAT
!               CHANGES=CHANGES+1
            %FINISH
         %FINISH
         PTR=CURRT_FLINK
      %REPEAT
!
! PASS TO TRY TO KEEP DUPLICTE TRIPLES IN ESTACK. THE SAVING
! HERE IS SO LARGE THAT IT IS WORTH THE EFFORT TO FIND THESE
! RATHER RARE CASES. OFTEN THE FORM IS A(I)=A(I)+B.
!
      %IF DUPS>0 %START;                ! THERE IS AT LEST ONE
         PTR=TRIPLES(0)_FLINK
         %WHILE PTR>0 %CYCLE
            CURRT==TRIPLES(PTR)
            NEXTT==CURRT
            %CYCLE
               NEXT=NEXTT_FLINK
               NEXTT==TRIPLES(NEXT)
            %REPEAT %UNTIL NEXTT_OPERN#NULLT
            %IF CURRT_CNT=2 %AND CURRT_OPTYPE&7#2 %START;! ONLY DUPILCATES POSSIBLE
               %IF CURRT_PUSE#NEXT %AND((NEXTT_OPND1_FLAG=REFTRIP %AND %C
                  NEXTT_OPND1_D=PTR) %OR(NEXTT_OPND2_FLAG=REFTRIP %AND %C
                  NEXTT_FLAGS&(COMMUTABLE!LOADOP1)=COMMUTABLE!LOADOP1 %AND %C
                  NEXTT_OPND2_D=PTR)) %START
                  CURRT_FLAGS=CURRT_FLAGS!USE ESTACK
                  CHANGES=CHANGES+1
                  PTR=NEXT
                  %CONTINUE
               %FINISH
               %IF CURRT_PUSE=NEXT %AND %C
                  NEXTT_OPND1_FLAG=REFTRIP=NEXTT_OPND2_FLAG %AND %C
                  NEXTT_OPND1_D=PTR=NEXTT_OPND2_D %THENSTART
                  CURRT_FLAGS=CURRT_FLAGS!USE ESTACK
                  CHANGES=CHANGES+1
                  PTR=NEXT; %CONTINUE
               %FINISH
               %IF CURRT_PUSE=NEXT %AND NEXTT_FLINK=NEXTT_PUSE#0 %AND %C
                  (NEXTT_FLAGS&COMMUTABLE#0 %OR(NEXTT_OPND1_FLAG=REFTRIP %AND %C
                  NEXTT_OPND1_D=PTR)) %START
                  NEWT==TRIPLES(NEXTT_FLINK)
                  NEWT==TRIPLES(NEWT_FLINK) %WHILE NEWT_OPERN=NULLT
                  %IF(NEWT_OPND2_FLAG=REFTRIP %AND NEWT_OPND2_D=PTR) %OR %C
                     (NEWT_FLAGS&COMMUTABLE#0 %AND %C
                     NEWT_OPND1_FLAG=REFTRIP %AND NEWT_OPND1_D=PTR) %START
                        CURRT_FLAGS=CURRT_FLAGS!USE ESTACK
                        CHANGES=CHANGES+1
                        PTR=NEXT
                        %CONTINUE
                  %FINISH
               %FINISH
            %FINISH
            PTR=NEXT
         %REPEAT
      %FINISH
!      %IF CHANGES>0 %AND PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES)
      %RETURN
%INTEGERFN POWEROF2(%INTEGER VAL)
!***********************************************************************
!*    CHECKS IF VAL IS A POWER OF 2                                    *
!***********************************************************************
%INTEGER I,J
      %FOR I=1,1,30 %CYCLE
         J=1<<I
         %IF J=VAL %THEN %RESULT=I
         %IF J>VAL %THEN %RESULT=0
      %REPEAT
      %RESULT=0
%END
%ROUTINE SWOP OPERANDS(%RECORD(TRIPF)%NAME CURRT)
!***********************************************************************
!*    EXCHANGE OPND1&OPND2 KEEPING THE FLAGS CORRECT                   *
!***********************************************************************
%RECORD(RD)TOPND
%INTEGER FLAGS,NEWFLAGS
      TOPND=CURRT_OPND1
      CURRT_OPND1=CURRT_OPND2
      CURRT_OPND2=TOPND
      FLAGS=CURRT_FLAGS
      NEWFLAGS=FLAGS&(\(LOADOP1+LOADOP2))
      %IF FLAGS&LOADOP1#0 %THEN NEWFLAGS=NEWFLAGS!LOADOP2
      %IF FLAGS&LOADOP2#0 %THEN NEWFLAGS=NEWFLAGS!LOADOP1
      CURRT_FLAGS=NEWFLAGS
%END
%INTEGERFN PRELOAD PLACE(%INTEGER TRIP)
!***********************************************************************
!*    LOOK FOR FIRST TRIPLE IN THE CHAIN THAT LEADS TO TRIP            *
!*    CAN BE VERY COMPILCATED. RETURN -1 IF NOT SIMPLE                 *
!***********************************************************************
%CONSTINTEGER TRIPREFS=X'140';          ! BITMASK OF OPERAND FORMATS
%RECORD(RD) %NAME OPND1,OPND2
%RECORD(TRIPF) %NAME CURRT
      CURRT==TRIPLES(TRIP)
      OPND1==CURRT_OPND1
      OPND2==CURRT_OPND2
      %IF CURRT_OPERN<128 %OR 1<<CURRT_OPND2_FLAG&TRIPREFS=0 %START; ! BACK VIA OPND1
         %IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 %THENRESULT=TRIP
         %RESULT=PRELOAD PLACE(OPND1_D)
      %FINISH
      %IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 %OR OPND1_D=CURRT_BLINK %THEN %C
         %RESULT=PRELOAD PLACE(OPND2_D)
!
! BOTH OPERANDS ARE LOADED TRIPLES
!
      %IF CURRT_BLINK=OPND2_D %THENRESULT=PRELOADPLACE(OPND1_D)
      %RESULT=-1;                       ! TOO COMPLICATED
%END
%ROUTINE NOOP(%INTEGER TRIPLE NO, %RECORD(RD) %NAME ROPND)
!***********************************************************************
!*    THIS TRIPLE HAS BECOME A NOOP.DELETE IT AND PASS ITS ENTRY TRIPLE*
!*    FORWARD TO ANT WHO USE IT                                        *
!***********************************************************************
%RECORD(TRIPF) %NAME CURRT,NOOPT
%RECORD(RD) %NAME OPND1,OPND2
%INTEGER PTR,CNT
      NOOPT==TRIPLES(TRIPLE NO);        ! THIS ONE TO BECOME NOOP
      CNT=NOOPT_CNT;                    ! HOW MANY TIMES USED
      IMPABORT %UNLESS CNT=1;              ! NO OPS ELIMINATED BEFORE DUPS
      PTR=NOOPT_BLINK
      %WHILE PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         %IF CURRT_PUSE=TRIPLE NO %THEN CURRT_PUSE=NOOPT_PUSE
         PTR=CURRT_BLINK
      %REPEAT
      PTR=NOOPT_FLINK
      %CYCLE
         CURRT==TRIPLES(PTR)
         PTR=CURRT_FLINK
         %CONTINUE %IF CURRT_OPERN=NULLT
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
         %IF (OPND1_FLAG=REFTRIP %OR OPND1_FLAG=INDIRECT) %C
            %AND OPND1_D=TRIPLE NO %THENSTART
            %IF OPND1_FLAG=INDIRECT %THEN %RETURN;! CAN OPTIMISE AT PRESESNT
            OPND1=ROPND
            CNT=CNT-1
            %IF OPND1_FLAG#REFTRIP %THEN CURRT_FLAGS=CURRT_FLAGS!LOAD OP1
         %FINISH
         %IF CURRT_OPERN>=128 %AND OPND2_D=TRIPLE NO %AND %C
            (OPND2_FLAG=REFTRIP %OR OPND2_FLAG=INDIRECT)  %START
            %IF OPND2_FLAG=INDIRECT %THEN %RETURN
            OPND2=ROPND
            CNT=CNT-1
            %IF OPND2_FLAG#REFTRIP %THEN CURRT_FLAGS=CURRT_FLAGS!LOAD OP2
         %FINISH
         %IF CNT=0 %OR PTR=0 %THENEXIT
         %IF NOOPT_OPND1_FLAG#REFTRIP %THEN %C
            CURRT_DPTH<-CURRT_DPTH-WORDS(NOOPT_OPTYPE>>4)
      %REPEAT
      NOOPT_X1=NOOPT_OPERN;             ! FOR DEBUGGING
      NOOPT_OPERN=NULLT;                ! SET AS NOOP
      NOOPT_PUSE=0
      NOOPT_FLAGS=NOOPT_FLAGS!DONT OPT;! SKIP DUP CHECKING
      CHANGES=CHANGES+1
%END
%ROUTINE DEC USE(%INTEGER TRIPLE NO)
!***********************************************************************
!*    A TRIPLE HAS BEEN PASSED INTO 'DEAD' CODE. DECREMENT ITS USE     *
!*    AND IF RELEVANT DELETE OPERATIONS LEADING TO IT                  *
!***********************************************************************
%RECORD(TRIPF) %NAME CURRT
      CURRT==TRIPLES(TRIPLE NO)
      CURRT_CNT=CURRT_CNT-1
      %IF CURRT_CNT=1 %THEN DUPS=DUPS-1
      %IF CURRT_CNT=0 %THEN DELETE TRIPLE(TRIPLE NO)
%END
%ROUTINE DELETE TRIPLE(%INTEGER TRIPLE NO)
%RECORD(TRIPF) %NAME DELT
      DELT==TRIPLES(TRIPLE NO)
      %IF DELT_OPND1_FLAG=REFTRIP %OR DELT_OPND1_FLAG=INDIRECT %THEN %C
         DEC USE(DELT_OPND1_D)
      %IF DELT_OPERN>=128 %AND(DELT_OPND2_FLAG=REFTRIP %OR %C
         DELT_OPND2_FLAG=INDIRECT) %THEN DEC USE(DELT_OPND2_D)
      DELT_X1=DELT_OPERN;               ! FOR DEBUGGING
      DELT_OPERN=NULLT;                 ! NO OP
      DELT_FLAGS=DELT_FLAGS!DONT OPT
%END
%ROUTINE DUPLICATE TRIP(%INTEGER TRIPNO,DTRIPNO)
!***********************************************************************
!*    DTRIPNO IS A DUPLICATE OF TRIPNO. CHANGE ALL REFERENCES          *
!*    AND DELETE IT                                                    *
!***********************************************************************
%RECORD(RD) %NAME OPND1,OPND2
%RECORD(TRIPF) %NAME MASTER,CURRT,DUPT
%INTEGER CNT,PTR
      DUPS=DUPS+1
      DUPTNO=TRIPNO
      MASTER==TRIPLES(TRIPNO)
      DUPT==TRIPLES(DTRIPNO)
      CNT=DUPT_CNT
      PTR=DUPT_FLINK
!
      %WHILE CNT>0 %AND PTR>0 %CYCLE
         CURRT==TRIPLES(PTR)
         PTR=CURRT_FLINK
         %IF CURRT_OPERN=NULLT %THEN %CONTINUE
         OPND1==CURRT_OPND1
         OPND2==CURRT_OPND2
         %IF OPND1_D=DTRIPNO %AND(OPND1_FLAG=REFTRIP %OR %C
            OPND1_FLAG=INDIRECT) %START
            MASTER_CNT=MASTER_CNT+1
            OPND1_D=TRIPNO
            CURRT_FLAGS=CURRT_FLAGS!LOAD OP1
            CNT=CNT-1
         %FINISH
         %IF CURRT_OPERN>=128 %AND OPND2_D=DTRIPNO %AND %C
            (OPND2_FLAG=REFTRIP %OR OPND2_FLAG=INDIRECT) %START
            MASTER_CNT=MASTER_CNT+1
            OPND2_D=TRIPNO
            CURRT_FLAGS=CURRT_FLAGS!LOAD OP2
            CNT=CNT-1
         %FINISH
      %REPEAT
      DELETE TRIPLE(DTRIPNO)
%END
%ROUTINE CHECK DUPS(%INTEGER TRIPNO,STRIPNO)
!***********************************************************************
!*    CHECK STARTING FROM STRIPNO FOR DUPLICATES OF TRIPNO             *
!*    MAY BE MORE THAN ONE                                             *
!***********************************************************************
%RECORD(TRIPF) %NAME CURRT,DUPT
%INTEGER OPERN,F,NEXT
      DUPT==TRIPLES(TRIPNO)
      OPERN=DUPT_OPERN
      F=DUPT_FLAGS
      %WHILE STRIPNO>0 %CYCLE
         CURRT==TRIPLES(STRIPNO)
         %EXITIF CURRT_OPERN=TLAB %OR CURRT_OPERN=RTXIT %OR CURRT_OPERN=RCALL
         %EXITIF CURRT_OPERN=VASS %OR CURRT_OPERN=VJASS;! PRO TEM
         NEXT=CURRT_FLINK
         %IF CURRT_OPERN=OPERN %AND((OPERN<128 %AND %C
            SAME OPND(DUPT_OPND1,CURRT_OPND1)=YES) %OR(OPERN>=128 %AND %C
            SAME OPND(DUPT_OPND1,CURRT_OPND1)=YES %AND %C
            SAME OPND(DUPT_OPND2,CURRT_OPND2)=YES) %OR(F&COMMUTABLE#0 %AND %C
            SAME OPND(DUPT_OPND1,CURRT_OPND2)=YES %AND %C
            SAME OPND(DUPT_OPND2,CURRT_OPND1)=YES)) %START
            DUPLICATE TRIP(TRIPNO,STRIPNO)
            CHANGES=CHANGES+1
         %FINISH
         STRIPNO=NEXT
      %REPEAT
%END
%INTEGERFN SAME OPND(%RECORD(RD) %NAME OPND1,OPND2)
!***********************************************************************
!*    ARE THESE OPERANDS THE SAME ?                                    *
!***********************************************************************
%INTEGER F,I
      %RESULT=NO %UNLESS OPND1_S1=OPND2_S1
      F=OPND1_FLAG
      %IF F=2 %OR F=5 %START
         %RESULT=NO %UNLESS OPND1_D=OPND2_D %AND %C
            OPND1_XTRA=OPND2_XTRA %AND OPND1_PTYPE&X'3000'=0
         %RESULT=YES
      %FINISH
      %IF F<=1 %START;                  ! CONSTANTS
         %IF OPND1_PTYPE=X'35' %START
            %RESULT=NO %UNLESS OPND1_XTRA=OPND2_XTRA
            %FOR I=1,1,OPND1_XTRA %CYCLE
               %RESULT=NO %UNLESS A(OPND1_D+I)=A(OPND2_D+I)
            %REPEAT
            %RESULT=YES
         %FINISH
         %RESULT=YES %IF OPND1_D=OPND2_D %AND(OPND1_XTRA=OPND2_XTRA %OR %C
            OPND1_PTYPE&X'F0'<=X'50')
         %RESULT=NO
      %FINISH
      %RESULT=YES %IF OPND1_D=OPND2_D %AND OPND1_XTRA=OPND2_XTRA
      %RESULT=NO
%END
%END
%ENDOFFILE