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,2,4,8;
ROUTINE EXTRACT(RECORD (RD) NAME OPND, LONGINTEGERNAME VAL,
LONGLONGREALNAME 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
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 PREC=6 THEN VAL=OPND_LI ELSE VAL=OPND_D
RVAL=VAL
FINISHELSESTART
VAL=0
IF PREC=7 START
FOR I=0,1,15 CYCLE
BYTEINTEGER(ADDR(RVAL)+I)=WORKA_A(OPND_XTRA+I)
REPEAT
FINISH ELSE 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
LONGLONGREAL 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_LI=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
PRECP=PRECP+1; ->INT END
UISW(14): ! SHORTEN INTEGER
IF PRECP=6 THEN PRECP=5 AND ->INT END
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>>16&31; ! TOTAL NO OF DIMENS
C=3*(D+1-C); ! TRIPLE OFFSET FROM DVBASE
D=VAL2&X'FFFF'; ! DV POINTER
RETURNUNLESS D>0; ! UNLESS DV AVAILABLE
JJ=(VAL1-WORKA_CTABLE(D+C))*WORKA_CTABLE(D+C+1)
IF JJ<0 OR JJ>WORKA_CTABLE(D+C+2) THEN C
FAULT(50,VAL1,XTRA&X'FFFF')
VAL1=JJ
->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 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,
0(2){ASS AND JAM ASS},
LOADOP1{****},
LOADOP1{SCALE},
LOADOP1!LOADOP2,
LOADOP2{INDEXED FETCH},
LOADOP2{LASS},
LOADOP1!LOADOP2(4),
LOADOP2(5){P PASSING},
LOADOP1!LOADOP2(8),
LOADOP2(7){STR,PTR&RESULT ASSMNT},
LOADOP1!LOADOP2(7),
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 START
RTRIP==TRIPLES(OPND_D)
IF RTRIP_PUSE#CURRTRIPNO OR RTRIP_OPERN=LASS OR C
RTRIP_OPERN=PRECC OR RTRIP_OPERN=CONCAT OR C
RTRIP_OPERN=ITOS1 THEN CURRT_FLAGS=CURRT_FLAGS!LOADOP
IF RTRIP_PUSE=CURRTRIPNO 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,CURR,NEXT,OP1,OP2,CTOPOP
BYTEINTEGERARRAYNAME A
RECORD (TRIPF) NAME CURRT,NEWT,NEXTT
RECORD (RD) NAME OPND1,OPND2
RECORD (LISTF) NAME LCELL
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'81',X'41',X'81',X'81',X'86',{+,-,!!,!,*} C
2,0,X'84',1,1,{//,/,&,>>,<<} C
2,0,0,3,X'81',{**,COMP,DCOMP,VMY,COMB} C
0,0,2,0,1,{=,<-,****,SCALE,INDEX} C
0{IFETCH},0(*)
! 2**0 SET IF SECOND OPERANR ZERO IS NOOP
! 2**1 SET IF SECOND OPERAND 1 IS A NOOP
! 2**2 SET IF SECOND OPERAND 0 MEANS RESULT=0
! 2**5 SET IF SOME FOLDING POSSIBLE
! 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
!
! FIRST OPTIMISATIO 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
!
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
OPND1==CURRT_OPND1
OPND2==CURRT_OPND2
IF I>=128 THENSTART ; ! BINARY OPERATIONS
J=FOLD NOOP INFO(I)&15
CONTINUEUNLESS OPND2_FLAG<=1 AND J#0 AND OPND2_PTYPE&7=1
VAL=OPND2_D; ! VALUE OF CONSTANT
IF (J&1#0 AND VAL=0) OR (J&2#0 AND VAL=1) START
NOOP(CURR,OPND1); ! THIS IS NOOP
CONTINUE
FINISH
IF J&4#0 AND VAL=0 THENSTART
IF OPND1_FLAG=REFTRIP THEN DEC USE(OPND1_D)
CURRT_OPND1=OPND2; ! RESULT IS ZERO
NOOP(CURR,OPND2)
! MAY CAUSE OTHER NOOPS
! GE I=(A+B)*0
FINISH
FINISHELSESTART ; ! UNARY
! OPTIMISE LOAD DOUBLE & SHRINK
! IN CASE WHERE CHECKING IS OFF
CONTINUEUNLESS OPND1_PTYPE=X'51' AND (I=JAMSHRTN OR C
(I=SHRTN AND PARM_OPT=0))
IF OPND1_FLAG=2 AND A(OPND1_D+2)=2=A(OPND2_D+3) THENSTART
J=WORKA_TAGS(OPND1_XTRA)
LCELL==RECORD(WORKA_AASL0+16*J); ! ON TO NAME RECORD
OPND1_FLAG=7; ! LOCAL
OPND1_PTYPE=X'41'; ! PRESHORTENED
CURRT_OPTYPE=X'41'; ! REVISE TRIPLE PTYPE
OPND1_D=(LCELL_UIOJ&X'F0')<<12!LCELL_SLINK
NOOP(CURR,OPND1)
FINISH
IF OPND1_FLAG=REFTRIP THENSTART
NEXTT==TRIPLES(OPND1_D)
IF NEXTT_CNT=1 AND NEXTT_OPERN=IFETCH START
NEXTT_OPND1_PTYPE=X'41'
NEXTT_OPTYPE=X'41'
OPND1_PTYPE=X'41'
NOOP(CURR,OPND1)
FINISH
FINISH
FINISH
REPEAT
!
! 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)
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)>>4#0 AND FOLD NOOP INFO(K)>>4#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
IF J=K AND FOLD NOOP INFO(J)&X'80'#0 THEN CTOPOP=J
IF J=K=SUB AND OP2=2 START
IF OP1=2 THEN CTOPOP=ADD ELSE CTOPOP=SUB
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 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)
CONTINUE
FINISH
FINISH
PTR=NEXT
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 C
CURRT_FLAGS&(LOADOP1!LOADOP2!COMMUTABLE)=LOADOP1 START
J=PRELOAD PLACE(CURRT_OPND2_D)
IF J>=0 START ; ! PALCE ACCESSIBLE
I=J; K=0
WHILE I#PTR CYCLE ; ! CHECK FOR DEPTH OF NESTING
NEXTT==TRIPLES(I)
IF K<NEXTT_DPTH THEN K=NEXTT_DPTH
I=NEXTT_FLINK
REPEAT
IF K+WORDS(CURRT_OPTYPE>>4)>=12 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)
NEXT=CURRT_FLINK
IF CURRT_CNT=2 START ; ! ONLY DUPILCATES POSSIBLE
NEXTT==TRIPLES(NEXT)
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)
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
END:
! %IF CHANGES>0 %AND PARM_DCOMP#0 %THEN PRINT TRIPS(TRIPLES)
RETURN
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 *
!***********************************************************************
RECORD (RD) NAME OPND1,OPND2
RECORD (TRIPF) NAME CURRT
CURRT==TRIPLES(TRIP)
OPND1==CURRT_OPND1
OPND2==CURRT_OPND2
IF CURRT_OPERN<128 OR CURRT_FLAGS&LOAD OP2#0 START ; ! BACK VIA OPND1
IF CURRT_FLAGS&LOAD OP1#0 THENRESULT =TRIP
RESULT =PRELOAD PLACE(OPND1_D)
FINISH
IF CURRT_FLAGS&LOAD OP1#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)
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
PTR=CURRT_FLINK
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
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
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)
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
PTR=CURRT_FLINK
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
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_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