INCLUDE "ERCC07.TRIMP_TFORM1S"
INCLUDE "ERCC07.TRIPCNSTS"
EXTRINSICRECORD (WORKAF) WORKA
EXTRINSICRECORD (PARMF) PARM
EXTERNALROUTINESPEC IMPABORT
EXTERNALROUTINESPEC MOVE BYTES(INTEGER L,FB,FO,TB,TO)
EXTERNALROUTINESPEC FAULT(INTEGER N,DATA,IDENT)
EXTERNALROUTINESPEC PRINT TRIPS(RECORD (TRIPF) ARRAYNAME TRIPLES)
CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,1,2,4;
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 *
!***********************************************************************
ROUTINESPEC EXTRACT(RECORD (RD) NAME OPND)
CONSTINTEGER UTRUNCMASK=X'00000800',BTRUNCMASK=X'00000013'
INTEGER K,TYPEP,PRECP,OP,MAXD,SVAL1,SVAL2,C,D,JJ,KK,TRUNCMASK
STRING (255) STRVAL,STRVAL1,STRVAL2
IF 1<<HOST&LINTAVAIL#0 THENSTART
LONGINTEGER VAL,VAL1,VAL2
FINISHELSESTART
INTEGER VAL,VAL1,VAL2
FINISH
IF 1<<HOST&LLREALAVAIL#0 THENSTART
LONGLONGREAL RVAL,RVAL1,RVAL2
FINISHELSESTART
LONGREAL RVAL,RVAL1,RVAL2
FINISH
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
RETURN IF 1<<HOST&LINTAVAIL=0 AND OPND1_PTYPE=X'61'
RETURN IF 1<<HOST&LLREALAVAIL=0 AND OPND1_PTYPE=X'72'
EXTRACT(OPND1)
VAL1=VAL; RVAL1=RVAL; STRVAL1=STRVAL
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=VAL; RVAL2=RVAL; STRVAL2=STRVAL
SVAL2<-VAL2
IF TYPEP=2 THEN ->BRSW(OP) ELSE ->BISW(OP)
UISW(10): ! ¬
VAL1=¬VAL1
INTEND:
IF 1<<HOST&LINTAVAIL#0 AND PRECP=6 THENSTART
OPND1_D<-VAL1>>32
OPND1_XTRA<-VAL1
FLAG=0
FINISHELSESTART
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
OPND1_FLAG=0
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=SCONST
IF PRECP=5 THEN OPND1_R=RVAL1 ELSEIF PRECP=6 THEN C
OPND1_LR=RVAL1 ELSESTART
OPND1_FLAG=LCONST
OPND1_D=WORKA_ARTOP
WORKA_ARTOP=WORKA_ARTOP+16
MOVE BYTES(16,ADDR(RVAL1),0,ADDR(WORKA_A(0)),OPND1_D)
FINISH
FLAG=0; OPND1_PTYPE=16*PRECP+2
RETURN
UISW(15): ! STRETCH INTEGER
IF 1<<HOST&LINTAVAIL#0 AND PRECP=5 THEN PRECP=6 AND ->INT END
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
IF PRECP=6 AND VAL1=SVAL1 THEN PRECP=5 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
MAXD=OPND2_D>>16&31; ! MAX DIMENSION
C=OPND2_D>>24; ! DIMENSION
D=OPND2_D&X'FFFF'; ! DV POINTER
RETURNUNLESS D>0; ! UNLESS DV AVAILABLE
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
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
FINISH
IF TARGET=EMAS START
C=3*(MAXD+1-C)
JJ=(VAL1-WORKA_CTABLE(D+C))*WORKA_CTABLE(D+C+1)
IF JJ<0 OR JJ>WORKA_CTABLE(D+C+2) THEN FAULT(50,VAL1,XTRA&X'FFFF')
VAL1=JJ
->INT END
FINISH
IF TARGET=IBM OR TARGET=IBMXA START
IF VAL1<WORKA_CTABLE(D+3*C) OR VAL1>WORKA_CTABLE(D+3*C+1) C
THEN FAULT(50,VAL1,XTRA&X'FFFF')
VAL1=VAL1*WORKA_CTABLE(D+3*C+2)
->INTEND
FINISH
RETURN
BISW(18): ! ARRAY SCALE
IF TARGET=PERQ OR TARGET=ACCENT OR TARGET=PNX START
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
FINISH
->INT END
BISW(11):
BISW(12): ! COMPARISONS
BRSW(11):
BRSW(12): ! REAL COMPARISONS
MASK=XTRA; ! XTRA HAS IBM TYPE MASK
! RETURN MASK AS 15(=JUMP) OR 0 (IGNORE)
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
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(*):
RETURN
ROUTINE EXTRACT(RECORD (RD) NAME OPND)
!***********************************************************************
!* 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
IF 1<<HOST&LINTAVAIL#0 AND PREC=6 THEN C
VAL=LENGTHENI(OPND_D)<<32!(OPND_XTRA&(LENGTHENI(-1)>>32)) C
ELSE VAL=OPND_D
RVAL=VAL
FINISHELSESTART
IF PREC=5 THEN RVAL=OPND_R ELSE C
IF PREC=6 THEN RVAL=OPND_LR ELSE C
MOVE BYTES(16,ADDR(WORKA_A(0)),OPND_D,ADDR(RVAL),0)
FINISH
END
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,COP
CONSTINTEGER FOLDI=X'1C00007F'; ! FOLD 10-16 & 36-38
CONSTINTEGER FOLDR=X'0107FFFF'; ! FOLD 128-146 &152
RECORD (TRIPF) NAME CURRT,REFT
ROUTINESPEC BACKTRACK(RECORD (TRIPF)NAME CURRT)
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
COP=CURRT_OPERN; ! CURRENT OPERATION
INSPECT OPND(1)
IF COP>=128 THEN INSPECT OPND(2)
!
IF CURRT_FLAGS&CONSTANTOP#0 AND ((COP<128 AND C
FOLDI&1<<(COP-10)#0) OR (CURRT_OPND1_FLAG<=1 AND C
CURRT_OPND2_FLAG<=1 AND FOLDR&1<<(COP&31)#0)) START
I=COP
CTOP(I,J,CURRT_X1,CURRT_OPND1,CURRT_OPND2)
IF I=0 THENSTART
CURRT_X1=COP; ! FOR DEBUGGING OPTIMISATIONS
CURRT_OPERN=NULLT
REPLACE TRIPREF(CURR TRIPNO,CURRT_OPND1)
FINISH
FINISH
IF COP=LASS AND CURRT_FLAGS&CONSTANTOP#0 AND C
CURRT_CNT>0 THEN REPLACE TRIPREF(CURRTRIPNO,CURRT_OPND2)
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
CURRT_DPTH<-DEPTH
IF CURRT_CNT>0 AND C
(TARGET=PERQ OR TARGET=ACCENT OR CURRT_OPTYPE&7=1) THEN C
DEPTH=DEPTH+WORDS(CURRT_OPTYPE>>4)
FINISH
IF TARGET=EMAS START ; ! DO SOME CRUDE REGISTER ALLOCATION
CURRT_DPTH=0; ! USE ACCR
IF COP=VMY OR COP=COMB OR COP=BADJ C
OR COP=FORPRE OR COP=FORPR2 OR COP=FOREND C
THEN CURRT_DPTH=7; ! USE BREG
IF CURRT_OPTYPE=X'35' AND COP=PRELOAD THEN C
CURRT_DPTH=1; ! USE DR
IF COP=VMY THEN BACK TRACK(CURRT)
FINISH
REPEAT
RETURN
ROUTINE BACKTRACK(RECORD (TRIPF)NAME CURRT)
!***********************************************************************
!* TRIES TO GET ALL OPERANDS OF A VMY EVALUATED IN B *
!***********************************************************************
INTEGER I
RECORD (RD)NAME OPND
RECORD (TRIPF)NAME REFT
IF TARGET=EMAS START ; ! EMAS ONLY OPTIMISATION
FOR I=1,1,2 CYCLE
IF I=1 THEN OPND==CURRT_OPND1 ELSE OPND==CURRT_OPND2
IF OPND_FLAG=REFTRIP AND (CURRT_OPERN#SUB OR I=1) START
REFT==TRIPLES(OPND_D)
IF REFT_OPERN=ADD OR REFT_OPERN=MULT OR C
REFT_OPERN=SUB THEN START
REFT_DPTH=7
BACK TRACK(REFT)
FINISH
FINISH
EXIT IF CURRT_OPERN<128
REPEAT
FINISH
END
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,OPERN
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 1<<OPND_FLAG&BTREFMASK#0 START
RTRIP==TRIPLES(OPND_D)
OPERN=RTRIP_OPERN
IF RTRIP_PUSE#CURRTRIPNO OR OPERN=PRECC OR C
(OPERN=LASS AND RTRIP_FLINK#CURRTRIPNO) OR C
OPERN=CONCAT OR OPERN=ITOS1 THEN C
CURRT_FLAGS=CURRT_FLAGS!LOADOP
IF TARGET=PNX AND RTRIP_PUSE=CURRTRIPNO AND RTRIP_OPTYPE&7=1 THEN C
DEPTH=DEPTH-WORDS(RTRIP_OPTYPE>>4)
IF (TARGET=PERQ OR TARGET=ACCENT) AND RTRIP_PUSE=CURRTRIPNO C
THEN DEPTH=DEPTH-WORDS(RTRIP_OPTYPE>>4)
FINISH
END
ROUTINE REPLACE TRIPREF(INTEGER TRIP, RECORD (RD) NAME OPND)
INTEGER PTR,COUNT
RECORD (TRIPF) NAME RTRIP
PTR=STPTR
COUNT=TRIPLES(TRIP)_CNT
TRIPLES(TRIP)_CNT=0
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,APTYPE
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
FINISHELSESTART ; ! 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
I=CURRT_OPERN
IF (TARGET=EMAS OR TARGET=IBMXA) AND I=MULT C
AND CURRT_CNT=1 START
NEXTT==TRIPLES(CURRT_PUSE)
IF NEXTT_OPERN=LNGTHN START
CURRT_OPTYPE=CURRT_OPTYPE+X'10'
NEXTT_OPND1_PTYPE=NEXTT_OPND1_PTYPE+X'10'
I=MULTX
CURRT_OPERN=MULTX
NOOP(CURRT_PUSE,NEXTT_OPND1)
FINISH
FINISH
CONTINUE IF CURRT_FLAGS&CONSTANTOP=0
OPND1==CURRT_OPND1
OPND2==CURRT_OPND2
IF OPND1_FLAG<=1 THEN C
OP1=1 AND VAL=OPND1_D AND XVAL=OPND1_XTRA ELSE C
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)) OR (VAL=-1 AND C
(J=2 OR J=12)))) OR (OP1=1 AND ((VAL=1 AND (J=2 OR C
J=12)) 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 (XVAL=0 OR CURRT_OPTYPE>>4<=5) AND C
(TARGET=EMAS OR 7<=J<=8) START
CURRT_OPERN=ZCOMP
IF OP1=1 THEN SWOP OPERANDS(CURRT)
CURRT_FLAGS=CURRT_FLAGS&(¬LOADOP2)!DONT OPT
FINISH
FINISH
IF (TARGET=PNX OR TARGET=EMAS OR TARGET=IBMXA) AND C
(I=LSHIFT OR I=RSHIFT) AND 1<=VAL<=31 AND 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
!
! THE ABOVE OPTIMISATION IS UNSOUND FOR NEGATIVE OPERANDS
!
UNLESS TARGET=PERQ OR TARGET=ACCENT START
! THESE HAVE NO ARITHMETIC SHIFT
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
FINISH
IF I>=128 THENSTART ; ! BINARY OPERATIONS
IF I=VMY START ; ! SOME VMY ARE NO OPS
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT C
THEN VAL=VAL>>24; ! DIM=1 IS NOOP
IF TARGET=EMAS START
APTYPE=CURRT_X1>>16
IF APTYPE>>8=2 AND APTYPE&7<=2 AND APTYPE&255#X'41' C
THEN VAL=VAL>>24; ! DIMEN 1 IS NOOP
FINISH
FINISH
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 ELSE START ; ! UNARY OPERATORS
! CAN OPTIMISE LOAD DOUBLE & SHRINK
! FOR PERQ & ACCENT
FINISH
REPEAT
! %IF CHANGES>0 %AND PARM_DCOMP#0 %THEN CHANGES=0 %AND PRINT TRIPS(TRIPLES)
!
! LOOK FOR REGISTER TO STORE OPERATIONS ON PNX
!
IF TARGET=PNX START
PTR=TRIPLES(0)_FLINK
WHILE PTR>0 CYCLE
CURRT==TRIPLES(PTR)
PTR=CURRT_FLINK
NEXTT==TRIPLES(PTR)
EXIT IF PTR=0; ! THE END
UNLESS NEXTT_OPERN=VASS AND NEXTT_OPTYPE=X'51'=CURRT_OPTYPE C
AND (NEXTT_OPND1_FLAG=DNAME OR NEXTT_OPND1_FLAG=INDNAME) C
AND NEXTT_OPND2_FLAG=REFTRIP AND C
CURRT_PUSE=PTR AND CURRT_CNT=1 THEN CONTINUE
CONTINUE UNLESS ADD<=CURRT_OPERN<=LSHIFT
IF CURRT_FLAGS&COMMUTABLE#0 AND C
SAME OPND(CURRT_OPND2,NEXTT_OPND1)=YES THEN C
SWOP OPERANDS(CURRT) ELSE START
CONTINUE UNLESS SAME OPND(CURRT_OPND1,NEXTT_OPND1)=YES
FINISH
CURRT_X1=CURRT_OPERN
CURRT_OPERN=RSTORE
CURRT_PUSE=0
CURRT_FLAGS=CURRT_FLAGS&(¬LOAD OP1);! THIS AVOIDS A USELESS PRELOAD
DELETE TRIPLE(PTR)
REPEAT
FINISH
!
! 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
!
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT START
PTR=TRIPLES(0)_FLINK
WHILE PTR>0 CYCLE
CURRT==TRIPLES(PTR)
IF CURRT_OPERN>=128 AND CURRT_OPERN#VASS AND C
CURRT_OPERN#VJASS AND C
(TARGET=PERQ OR TARGET=ACCENT OR CURRT_OPTYPE&7=1) AND C
CURRT_FLAGS&(LOADOP1!LOADOP2!COMMUTABLE)=LOADOP1 AND C
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)
! PRINTSTRING("TRIPLE EXAMINED")
! WRITE(I,5); WRITE(OP1,5)
! NEWLINE
IF NEXTT_DPTH<CURRT_DPTH THEN K=999 AND EXIT
! LOWER ESTACK ITEMS WILL BE USED
! CANOT PRELOAD THIS ITEM
OP1=NEXTT_OPERN
IF OP1=IOCPC OR OP1=PRECL OR OP1=RCALL OR C
OP1=RCRFR OR OP1=RCRMR THEN C
K=999 ANDEXIT
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
FINISH
!
! 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 (TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT) C
AND 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)
REPEATUNTIL NEXTT_OPERN#NULLT
IF CURRT_CNT=2 AND C
(TARGET=PERQ OR TARGET=ACCENT OR CURRT_OPTYPE&7=1) 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 C
(NEXTT_OPND1_FLAG=REFTRIP AND 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 THENRESULT =I
IF J>VAL THENRESULT =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
CONTINUEIF CURRT_OPERN=NULLT
OPND1==CURRT_OPND1
OPND2==CURRT_OPND2
IF (OPND1_FLAG=REFTRIP OR OPND1_FLAG=INDIRECT) AND C
OPND1_D=TRIPLE NO THENSTART
IF OPND1_FLAG=INDIRECT THENRETURN ; ! 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 THENRETURN
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 1<<NOOPT_OPND1_FLAG&BTREFMASK=0 AND C
(TARGET=PERQ OR TARGET=ACCENT OR C
(TARGET=PNX AND NOOPT_OPTYPE&7=1))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 AND CURRT_OPERN#RSTORE 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
CHANGES=CHANGES+1
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 THENCONTINUE
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
! COMPARISONS ARE IMPOSSIBLE TO OPTIMISE
! ON CONDITION CODE MACHINES
! POSSIBLE BUT DIFFICULT ON TRUE FLAG MCS
IF OPERN=COMP OR OPERN=DCOMP OR OPERN=SCOMP OR OPERN=SDCMP C
THEN RETURN
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 C
OPND1_D=OPND2_D AND OPND1_XTRA=OPND2_XTRA AND C
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