!!{GT:}%include "hostcodes.inc"
CONSTINTEGER YES=1,NO=0
!
! THESE CODE ARE ARBITARY BUT THE TOP DECIMAL DIGIT GIVES THE NO OF BYTES
! IN THE UNIT OF ADDRESSABILITY. BYTE ADDRESSED HOSTS BEING 1N ( also 0N) AND
! 16 BIT WORD ADDRESSED HOSTS BEING 2N ETC
CONSTINTEGER PENTIUM=4; ! PENTIUM chip Unix stack and completely swopped
constinteger MIPS=05; ! Imp on MIPS (all variants)
CONSTINTEGER RS6=06; ! imp on IBM rs6000
CONSTINTEGER M88K=07; ! Imp on all forms of 88k
! also serves for Sparc sinc there is a common b-e
CONSTINTEGER VAX=08; ! Imp on Vax using F & G formats
CONSTINTEGER UNISYS=09; ! Imp on UnisSys. Unix stack unswopped Vax reals
CONSTINTEGER EMAS=10; ! emas on 2900 (unsigned shorts)
CONSTINTEGER IBM=11; ! emas on 24 bit ibm hardware
CONSTINTEGER IBMXA=12; ! emas of XA 31 bit hardware
CONSTINTEGER WWC=13; ! WWc (Natsemi chip) completely swopped
CONSTINTEGER AMDAHL=14; ! Emas on Amdahls guess at Xa Minor differences fron IBM)
CONSTINTEGER PERQ3=15; ! ICL packaged 68k chip Unix stack but not swopped
CONSTINTEGER GOULD=16; ! Gould unswopped forward stack. Needs 4&8 byte alined
CONSTINTEGER VNS=17; ! Unix on 2900 unsigned shorts params as
! 2900. Long int available but not in Ecode
CONSTINTEGER EAMD=18; ! Amdahl via the Emachine
CONSTINTEGER DRS=19; ! Intel chip Unix stack and mostly swopped
CONSTINTEGER PERQ=20; ! Pos perq now obselete. Fully swopped forward stack
CONSTINTEGER PNX=21; ! ICL's perq2 Unix stack byte swopped (unsigned shorts)
CONSTINTEGER ACCENT=22; ! Perq 1 under accent. obsolete now
! ACCENT DIFFERS FROM PERQ ONLY IN
! ASSEMBLES SEQUENCES&SYNTAX
! AND GENERATOR
constinteger ORN=23
CONSTINTEGER UNSIGNEDSHORTS=1<<emas!1<<pnx!1<<vns
CONSTINTEGER LINTAVAIL=1<<IBM!1<<IBMXA!1<<amdahl!1<<EMAS!1<<GOULD!1<<MIPS
CONSTINTEGER LLREALAVAIL=1<<IBM!1<<IBMXA!1<<amdahl!1<<EMAS!1<<MIPS
CONSTINTEGER EMACHINE=1<<DRS!1<<PENTIUM!1<<WWC!1<<Vax!1<<GOULD!1<<PERQ3!1<<VNS!1<<EAMD!1<<ORN!1<<UniSys!1<<m88k!1<<rs6!1<<MIPS
CONSTINTEGER IBMFPFORMAT=1<<ibm!1<<ibmxa!1<<amdahl!1<<emas!1<<gould!1<<vns!1<<EAMD
constinteger VAXFPFORMAT=1<<Vax!1<<UniSys
constinteger IEEEFPFORMAT=1<<WWC!1<<PERQ3!1<<DRS!1<<PENTIUM!1<<PERQ!1<<accent!1<<m88k!1<<rs6!1<<MIPS
CONSTINTEGER BYTESWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<PNX!1<<ORN
CONSTINTEGER HALFSWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<DRS!1<<PENTIUM!1<<ORN
CONSTINTEGER WORDSWOPPED=1<<PERQ!1<<ACCENT!1<<WWC!1<<Vax!1<<DRS!1<<PENTIUM!1<<ORN
CONSTINTEGER RISKMC=1<<M88K!1<<rs6!1<<MIPS
!
! end of file hostcodes
!
CONSTINTEGER HOST=M88K
CONSTINTEGER TARGET=RS6
!
! Warning this module has the revised triples spec.
!
! In first attempt at Triple Imp considerable use was made of constant operands
! to pass information from Pass2 to GEN. Although for specialised operations like
! passing Labels this still applies, this adhocery has caused problems with arrays
! and pointers particularly in mapped records. The operands for four triples
! have thus been redefined in a more standard way.
!
! GETPTR X1 is now (ptype of passed)<<16! DIMENSION
! Opnd2 is either a 32 bit const with the size (ACC) as value or
! the ptr or arrayhead as normal operand.
!
! VMY X1 is now dim<<28!maxdim<<24!array name(where known)
! Opnd2 is either a 32 bit const with DV offset into const area or
! the arrayhead as a standard operand
!
! AINDX X1 is ELSIZE<<20 !spare
! Opnd2 is arrayhead as standard operand
! NOTE:- The Operands have been swopped for consistency with norm.
!
! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward dvs)
! Opnd2 exactly as for VMY
!
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
RECORDFORMAT PARMF(INTEGER BITS1,BITS2,TTOPUT,
BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
INTEGER LPOPUT,SP0)
RECORDFORMAT LEVELF(INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE,
NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, MAXPP, EXITLAB, CONTLAB, S3,
INTEGERARRAY AVL WSP(0:4))
IF 1<<host&unsignedshorts=0 START
RECORDFORMAT RD((INTEGER S1 OR SHORT PTYPE,BYTE XB,FLAG),
((INTEGER D OR REAL R),
INTEGER XTRA OR SHORT H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
RECORDFORMAT TAGF((SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
INTEGER S1,S2,S3),INTEGER LINK)
RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
RECORD(RD) OPND1,OPND2)
RECORDFORMAT LISTF((SHORTINTEGER PTYPE,(SHORT UIOJ OR BYTE XB,FLAG),
SHORT SNDISP,ACC,SLINK,KFORM OR INTEGER S1,S2,S3),INTEGER LINK)
FINISH ELSE START
RECORDFORMAT RD((INTEGER S1 OR HALF PTYPE,BYTE XB,FLAG),
((INTEGER D OR REAL R),
INTEGER XTRA OR HALF H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
RECORDFORMAT TAGF((HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
INTEGER S1,S2,S3),INTEGER LINK)
RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
HALFINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
RECORD(RD) OPND1,OPND2)
RECORDFORMAT LISTF((HALFINTEGER PTYPE,(HALF UIOJ OR BYTE XB,FLAG),
HALF SNDISP,ACC,SLINK,KFORM OR INTEGER S1,S2,S3),INTEGER LINK)
FINISH
RECORDFORMAT WORKAF(INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
INTEGERNAME LINE,N,S5,STRING(9)LADATE,
BYTEINTEGERARRAYNAME CC,A,LETT,
INTEGERARRAYNAME WORD,TAGS,CTABLE,
RECORD(LEVELF)ARRAYNAME LEVELINF,
INTEGERARRAY PLABS,PLINK(0:31),
RECORD(LISTF)ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
CONSTINTEGER LEAVE STACKED=2****0; ! SET LEAVE RESULT IN ESTACK
CONSTINTEGER LOADOP1=2****1; ! OPERAND 1 NEEDS LOADING
CONSTINTEGER LOADOP2=2****2; ! OPERAND 2 NEEDS LOADING
CONSTINTEGER NOTINREG=2****3; ! PREVENT REG OPTIMISNG
! OF TEMPS OVER LOOPS&JUMPS
CONSTINTEGER USE ESTACK=2****4; ! KEEP DUPLICATE IN ESTACK
CONSTINTEGER USE MSTACK=2****5; ! PUT DUPLICAT ON MSTACK
CONSTINTEGER CONSTANTOP=2****6; ! ONE OPERAND IS CONSTANT(FOR FOLDING)
CONSTINTEGER COMMUTABLE=2****7; ! OPERATION IS COMMUTABLE
CONSTINTEGER BSTRUCT=2****12; ! Proc contains inner blks or RTs
CONSTINTEGER USED LATE=2****13; ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
CONSTINTEGER ASS LEVEL=2****14; ! ASSEMBLER LEVEL OPERATION
CONSTINTEGER DONT OPT=2****15; ! DONT DUPLICATE THIS RESULT
! USED FOR BYTE PTR & OTHER SODS!
!
RECORDFORMAT EMASFHDRF(INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
! FORMAT FOR ARRAY HEADS
! %END %OF %FILE "ERCC07.TRIMP_TFORM1S"
!
! FIRST THE OPERAND FLAG CONSTANTS
!
CONSTINTEGER SCONST=0; ! CONST UPTO 64 BITS value is carried
! in opnd_d and opnd_xtra
CONSTINTEGER LCONST=1; ! CONST LONGER THAN SCONST const can be
! found elsewhere(at top of ar) by
! meanse of base&offset inf in_d and _xtra
CONSTINTEGER DNAME=2; ! NAME BY DICTIONARY NO the base and disp in
! the dictionary after adjusting by
! possible offset for item in
! in records lead to the variable
CONSTINTEGER ARNAME=3; ! NAME BY AR POINTER opnd_d the ar pointer
! this form local to pass2
! and used to identify functions
! with params before the call
! is planted
CONSTINTEGER VIAPTR=4; ! VIA TRIPLE WITHOFFSET TO POINTER
! At an offset(_xtra) from address in
! referenced triple can be found a
! pointer to the required operand
CONSTINTEGER INDNAME=5; ! INDIRECT VIA DICTIONARY base&disp
! in dictionary identify a pointer
! variable at possible offset from
! this pointer
CONSTINTEGER INDIRECT=6; ! INDIRECT VIA TRIPLE WITH OFFSET
! the refenced triple has computed
! the (32bit) address of an item
! an offset may have to be applied
! before the fetch or store
CONSTINTEGER LOCALIR=7; ! BASE DISP REF IN CURRENT STACK FRAME
! opnd_b=base<<16!offset used only for
! compiler generated temporaries
CONSTINTEGER REFTRIP=8; ! REFERENCE TO A TRIPLE the operand is the result of
! triple opnd_d
CONSTINTEGER INAREG=9; ! REGISTER OPERAND this form is local to the
! code generating pass(es)
CONSTINTEGER developped=10; ! also local to generator
CONSTINTEGER DEVADDR=11; ! ALSO LOCAL TO GENERATOR
CONSTINTEGER BTREFMASK=1<<REFTRIP!1<<INDIRECT!1<<VIAPTR
CONSTINTEGER REFER NEEDED=1<<INDIRECT!1<<VIAPTR
!
! NOW THE DEFINITIONS OF ONE OPERAND TRIPLES <128
!
CONSTINTEGER RTHD=1; ! ROUTINE-BLOCK HEADING
CONSTINTEGER RDSPY=2; ! ROUTINE ENTRY SET DISPLAY
CONSTINTEGER RDAREA=3; ! ROUTINE LEAVE DIAGNOSTIC SPACE
CONSTINTEGER RDPTR=4; ! SET DIAGNOSTIC POINTER
CONSTINTEGER RTBAD=5; ! ROUTINE-FN BAD EXIT
CONSTINTEGER RTXIT=6; ! "%RETURN"
CONSTINTEGER XSTOP=7; ! EXECUTE "%STO"
CONSTINTEGER NOTL=10; ! LOGICAL NOT
CONSTINTEGER LNEG=11; ! LOGICAL NEGATE
CONSTINTEGER IFLOAT=12; ! CONVERT INTEGER TO REAL
CONSTINTEGER MODULUS=13; ! AS USED BY IMOD&RMOD
CONSTINTEGER SHRTN=14; ! SHORTEN TO LOWER PRECISION
CONSTINTEGER LNGTHN=15; ! LENGTHEN TO HIGHER PRECISION
CONSTINTEGER JAMSHRTN=16; ! SHORTEN FOR JAM TRANSFER
CONSTINTEGER NULLT=18; ! FOR REDUNDANT TRIPLES
CONSTINTEGER PRELOAD=19; ! PREFETCH FOR OPTIMISATION REASONS
CONSTINTEGER SSPTR=21; ! STORE STACK POINTER
CONSTINTEGER RSPTR=22; ! RESTORE STACK POINTER
CONSTINTEGER ASPTR=23; ! ADVANCE STACK PTR
CONSTINTEGER DARRAY=24; ! DECLARE ARRAY(IE STORE HD)
CONSTINTEGER SLINE=25; ! UPDATE LINE NO
CONSTINTEGER STPCK=26; ! CHECK FOR ZERO STEPS
CONSTINTEGER FORPRE=27; ! PREAMBLE FOR "FOR"
CONSTINTEGER FORPOST=28; ! POSTAMBLE FOR "FOR"
CONSTINTEGER FORPR2=29; ! FOR SECOND PREAMBLE
CONSTINTEGER PRECL=30; ! PREPARATION FOR CALL
CONSTINTEGER RCALL=31; ! THE CALL
CONSTINTEGER RCRFR=32; ! RECOVER FN RESULT
CONSTINTEGER RCRMR=33; ! RECOVER MAP RESULT
CONSTINTEGER GETAD=35; ! GET ADDRESS OF NAME
CONSTINTEGER RTOI1=36; ! REAL TO INTEGER AS INT
CONSTINTEGER RTOI2=37; ! REAL TO INTEGER INTPT
CONSTINTEGER ITOS1=38; ! INTEGER TO STRING AS TOSTRING
CONSTINTEGER MNITR=39; ! %MONITOR
CONSTINTEGER PPROF=40; ! PRINT PROFILE
CONSTINTEGER RTFP=41; ! TURN RT INTO FORMAL PARAMETER
CONSTINTEGER ONEV1=42; ! ON EVENT 1 PRIOR TO TRAP
CONSTINTEGER ONEV2=43; ! ON EVENT 2 AFTER TRAP
CONSTINTEGER DVSTT=44; ! START OF DOPE VECTOR
CONSTINTEGER DVEND=45; ! END OF DV EVALUATE TOTSIZE ETC
CONSTINTEGER FOREND=46; ! END OF FOR LOOP
CONSTINTEGER DMASS=47; ! assign via bim warning to opt only
CONSTINTEGER RTOI3=48; ! real to integer as TRUNC
!
! CODES FOR USER WRITTEN ASSEMBLER. NATURALLY THESE ARE NOT
! MACHINE INDEPENDENT
!
CONSTINTEGER UCNOP=50; ! FOR CNOPS
CONSTINTEGER UCB1=51; ! ONE BYTE OPERATIONS
CONSTINTEGER UCB2=52; ! FOR 2 BYTE OPERATIONE
CONSTINTEGER UCB3=53; ! FOR 3 BYTE OPERATIONS
CONSTINTEGER UCW=54; ! FOR WORD OPERATIONS
CONSTINTEGER UCBW=55; ! FOR OPC,BYTEWORD OPERATIONE
CONSTINTEGER UCWW=56; ! FOR OPC,WORD,WORD OPERAIONS
CONSTINTEGER UCLW=57; ! FOR LONGWORD OPERATIONS
CONSTINTEGER UCB2W=58; ! FOR OPC,B1,B2,WORD OPERATIONS
CONSTINTEGER UCNAM=59; ! FOR ACESS TO NAMES FROM ASSEMBLER
!
! NOW THE BINARY OPERATIONS
!
CONSTINTEGER ADD=128; ! ADDITION
CONSTINTEGER SUB=129; ! SUBTRACTION
CONSTINTEGER NONEQ=130; ! INTEGER NONEQUIVALENCE
CONSTINTEGER ORL=131; ! LOGICAL OR
CONSTINTEGER MULT=132; ! MULTIPLICATION
CONSTINTEGER INTDIV=133; ! INTEGER DIVISION
CONSTINTEGER REALDIV=134; ! REAL DIVISION
CONSTINTEGER ANDL=135; ! LOGICAL AND
CONSTINTEGER RSHIFT=136; ! LOGICAL RIGHT SHIFT
CONSTINTEGER LSHIFT=137; ! LOGICAL LEFT SHIFT
CONSTINTEGER REXP=138; ! REAL EXPONENTIATION
CONSTINTEGER COMP=139; ! COMPARISONS
CONSTINTEGER DCOMP=140; ! FIRST PART OF DSIDED(NEEDED?)
CONSTINTEGER VMY=141; ! VECTOR MULTIPLY
CONSTINTEGER COMB=142; ! COMBINE (IE ADD OF LA) ON VMY RESULTS
CONSTINTEGER VASS=143; ! VARAIABLE ASSIGN WITH CHECKING
CONSTINTEGER VJASS=144; ! VARIABLE JAMMED ASSIGN
CONSTINTEGER IEXP=145; ! INTEGER EXPONENTIAITION
CONSTINTEGER BADJ=146; ! BASE ADJUST ARRAY INDEX
CONSTINTEGER AINDX=147; ! INDEX ARRAY(COMBINE BS&IX)
CONSTINTEGER IFETCH=148; ! NO LONGER USED
CONSTINTEGER LASS=149; ! ASSIGN LOCAL TEMPORARY
CONSTINTEGER FORCK=150; ! VALIDATE FOR
CONSTINTEGER PRECC=151; ! PRELIMINARY CONNCATENATION
CONSTINTEGER CONCAT=152; ! CONCATENATION
CONSTINTEGER IOCPC=153; ! CALL IOCP
CONSTINTEGER PASS1=154; ! PRIMARY PARAMETER ASSIGNMENT
CONSTINTEGER PASS2=155; ! PARAMETER PASSING POINTER PARAMS
CONSTINTEGER PASS3=156; ! PARAMETERPASSING ARRAY PARAMETERS
CONSTINTEGER PASS4=157; ! PASS A FORMAL PROCEDURE
CONSTINTEGER PASS5=158; ! PASS AN UNTYPE(%NAME) PARAMETER
CONSTINTEGER PASS6=159; ! PASS STRFN OR RECFN RESULT AREA
CONSTINTEGER BJUMP=160; ! BACKWARDS JUMPS
CONSTINTEGER FJUMP=161; ! FORWARD JUMPS
CONSTINTEGER REMLB=162; ! REMOVE LAB FROM LABELIST
! NEEDS TO BE TRIPLE IF COMBINED
! LABEL LIST IS USED
CONSTINTEGER TLAB=163; ! TO ENTER A LABEL
CONSTINTEGER DCLSW=164; ! DECLARE A SWITCH ARRAY
CONSTINTEGER SETSW=165; ! SET A SWITCH TO "CA"
CONSTINTEGER GOTOSW=166; ! GO TO A SWITCH LABEL
CONSTINTEGER STRASS1=167; ! STRING GENERAL ASSIGNMET
CONSTINTEGER STRASS2=168; ! STRING FIXED LENGTH ASSNMENT
CONSTINTEGER STRJT=169; ! STRING JAM TRANSFER
CONSTINTEGER AHASS=170; ! ASSIGNMENT OF ARRAYHEADS
CONSTINTEGER PTRAS=171; ! ASSIGNMENT OF POINTERS
CONSTINTEGER MAPRES=172; ! ASSIGN MAPPING FN RESULT
CONSTINTEGER FNRES=173; ! ASSIGN FN RESULT
CONSTINTEGER SCOMP=174; ! STRING COMPARISON
CONSTINTEGER SDCMP=175; ! FIRST PART OF STRING D-SIDED
CONSTINTEGER PRES1=176; ! PRE RESOLUTION 1
CONSTINTEGER PRES2=177; ! PRE RESOLUTION 2
CONSTINTEGER RESLN=178; ! STRING RESOLUTION
CONSTINTEGER RESFN=179; ! RESOLUTION FINALE
CONSTINTEGER SIGEV=180; ! SIGNAL EVENT
CONSTINTEGER RECASS=181; ! WHOLE RECORD ASSIGNMENT
CONSTINTEGER AAINC=182; ! ARRAY ADDRESS ADJUST FOR
! RECORD RELATIVE TO ABSOLUTE
CONSTINTEGER AHADJ=183; ! MODIFY HEAD FOR MAPPING
CONSTINTEGER CTGEN=184; ! CREATE TYPE GENERAL PARAMETER
CONSTINTEGER GETPTR=185; ! POINTER FOR PASSING BY NAME
CONSTINTEGER SINDX=186; ! INDEX STRING IE CHARNO
! SAME AS AINDX FOR ALL TARGETS
! BUT PNX !
CONSTINTEGER ZCOMP=187; ! COMPARISONS WITH ZERO
! GENERATED BY OPTIMISER
CONSTINTEGER CLSHIFT=188; ! CONSTANT LOGICAL SHIFT
! GENERATED BY OPTIMISER
CONSTINTEGER CASHIFT=189; ! CONSTANT ARITHMETIC SHIFT
! GENERATED BYOPTIMISER
CONSTINTEGER DVBPR=190; ! GENERATE DV ENTRY FOR BOUND PAIR
CONSTINTEGER RSTORE=191; ! REGISTER TO STORE OPERATION
CONSTINTEGER MULTX=192; ! MULTIPLY AND EXTEND PRECISION
EXTRINSIC RECORD (WORKAF) WORKA
EXTRINSIC RECORD (PARMF) PARM
EXTERNAL ROUTINE SPEC IMPABORT
IF HOST#TARGET START
EXTERNAL ROUTINE SPEC REFORMATC(RECORD (RD) NAME OPND)
FINISH
EXTERNAL ROUTINE SPEC MOVE BYTES(INTEGER L,FB,FO,TB,TO)
EXTERNAL ROUTINE SPEC FAULT(INTEGER N,DATA,IDENT)
EXTERNAL ROUTINE SPEC PRINT TRIPS(RECORD (TRIPF) ARRAY NAME TRIPLES)
CONST BYTE INTEGER ARRAY BYTES(0:7)=0(3),1,2,4,8,16;
CONST BYTE INTEGER ARRAY WORDS(0:7)=0(3),1,1,1,2,4;
EXTERNAL ROUTINE CTOP(INTEGER NAME 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 *
!***********************************************************************
ROUTINE SPEC EXTRACT(RECORD (RD) NAME OPND)
INTEGER FN SPEC DEBYTESWOP(INTEGER VAL)
CONST INTEGER UTRUNCMASK=X'00000800',BTRUNCMASK=X'00000013'
INTEGER K,TYPEP,PRECP,OP,MAXD,SVAL,SVAL1,SVAL2,C,D,JJ,KK,TRUNCMASK,LB,UB,MP
STRING (255) STRVAL,STRVAL1,STRVAL2
LONG REAL LR
IF 1<<HOST&LINTAVAIL#0 THEN START
LONG INTEGER VAL,VAL1,VAL2
FINISH ELSE START
INTEGER VAL,VAL1,VAL2
FINISH
IF 1<<HOST&LLREALAVAIL#0 THEN START
LONG LONG REAL RVAL,RVAL1,RVAL2
FINISH ELSE START
LONG REAL RVAL,RVAL1,RVAL2
FINISH
SWITCH UISW,URSW(10:48),BISW,BRSW(0:47)
ON EVENT 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'
if opnd1_ptype&x'8'#0 then return; ! Foreign constants can not be folded
EXTRACT(OPND1)
VAL1=VAL; RVAL1=RVAL; STRVAL1=STRVAL
SVAL1<-VAL1
IF OP<128 START; ! UNARY
RETURN UNLESS 10<=OP<=48
TRUNCMASK=UTRUNCMASK
IF TYPEP=2 THEN ->URSW(OP) ELSE ->UISW(OP)
FINISH
OP=OP-128
RETURN IF OP>47
if opnd2_ptype&8#0 then return
EXTRACT(OPND2)
VAL2=VAL; RVAL2=RVAL; STRVAL2=STRVAL
SVAL2<-VAL2
TRUNCMASK=BTRUNCMASK
IF TYPEP=2 THEN ->BRSW(OP) ELSE ->BISW(OP)
UISW(10): ! ¬
VAL1=¬VAL1
INTEND:
IF 1<<HOST&LINTAVAIL#0 AND PRECP=6 THEN START
OPND1_D<-VAL1>>32
OPND1_XTRA<-VAL1
FLAG=0
FINISH ELSE START
SVAL<-VAL1
IF SVAL=VAL1 OR 1<<OP&TRUNCMASK=0 THEN FLAG=0 AND OPND1_D=SVAL
! 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 ELSE IF PRECP=6 THEN START
LR=RVAL1; ! may be rounding
MOVE BYTES(8,ADDR(LR),0,ADDR(OPND1_D),0)
FINISH ELSE START
OPND1_FLAG=LCONST
OPND1_D=WORKA_ARTOP
OPND1_XTRA=INTEGER(ADDR(RVAL1))
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 precp=4 and 0<=val1<=255 then precp=3 and ->int end
IF PRECP=5 and 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
RETURN UNLESS MOD(RVAL1)<X'7FFFFFFE'
VAL1=INT(RVAL1)
PRECP=5
->INTEND
URSW(37): ! INTPT
RETURN UNLESS MOD(RVAL1)<X'7FFFFFFE'
VAL1=INTPT(RVAL1)
PRECP=5
->INTEND
UISW(38): ! TOSTRING
STRVAL1=TOSTRING(VAL1)
->STREND
URSW(48): ! TRUNC coded without using itself as it
! it is not provided in the older compilers
RETURN UNLESS MOD(RVAL1)<x'7ffffffe'
IF RVAL>=0 THEN VAL1=INTPT(RVAL1) ELSE VAL1=-INTPT(MOD(RVAL1))
PRECP=5
->INTEND
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):RETURN IF 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=XTRA>>24&15; ! MAX DIMENSION
C=XTRA>>28; ! DIMENSION
D=OPND2_D&X'FFFF'; ! DV POINTER
IF TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT OR 1<<TARGET&EMACHINE#0 START
LB=DEBYTESWOP(WORKA_CTABLE(D+3*C+1))
UB=DEBYTESWOP(WORKA_CTABLE(D+3*C))
MP=DEBYTESWOP(WORKA_CTABLE(D+3*C-1))
IF VAL1<LB OR VAL1>UB THEN FAULT(50,VAL1,XTRA&X'FFFF')
VAL1=VAL1*MP 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=AMDAHL OR TARGET=IBMXA START
IF VAL1<WORKA_CTABLE(D+3*C) OR VAL1>WORKA_CTABLE(D+3*C+1) THEN FAULT(50,VAL1,XTRA&X'FFFF')
VAL1=VAL1*WORKA_CTABLE(D+3*C+2)
->INTEND
FINISH
RETURN
BISW(18): ! BADJ ADUST ARRAY BASE
IF TARGET=PERQ OR 1<<TARGET&EMACHINE#0 OR TARGET=ACCENT OR TARGET=PNX START
D=XTRA>>24&15; ! TOTAL NO OF DIMENSIONS
KK=VAL2; ! DV DISP
RETURN UNLESS KK>0
JJ=DEBYTESWOP(WORKA_CTABLE(KK));! adjustment
VAL1=VAL1+JJ
FINISH
->INT END
BISW(46):
BISW(47): ! scomp & sdcomp
BRSW(46):
BRSW(47): ! scomp & sdcomp
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 TYPEP=5 THEN ->SCOMP
IF (MASK&8#0 AND VAL1=VAL2) OR (MASK&4#0 AND VAL1<VAL2) OR (MASK&2#0 AND VAL1>VAL2) THEN MASK=15 ELSE C
MASK=0
if op=12{dsided} then opnd1=opnd2
RETURN
RCOMP:
IF (MASK&8#0 AND RVAL1=RVAL2) OR (MASK&4#0 AND RVAL1<RVAL2) OR (MASK&2#0 AND RVAL1>RVAL2) THEN C
MASK=15 ELSE MASK=0
if op=12{dsided} then opnd1=opnd2
RETURN
SCOMP:
IF (MASK&8#0 AND STRVAL1=STRVAL2) OR (MASK&4#0 AND STRVAL1<STRVAL2) OR (MASK&2#0 AND C
STRVAL1>STRVAL2) THEN MASK=15 ELSE MASK=0
if op=47{dsided} then opnd1=opnd2
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
RETURN IF RVAL2=0; ! AVOID DIV BY ZERO
RVAL1=RVAL1/RVAL2; ->REAL END
BISW(10): ! '**' WITH 2 INTEGER OPERANDS
BRSW(10): ! '**' WITH AT LEAST 1 REAL
RETURN UNLESS OPND2_PTYPE&7=1 AND-77<=VAL2<=75
! RVAL1=RVAL1**VAL2
!
! avoid exponentiation in case a support routine reqd
!
RVAL2=1
rval2=rval2*rval1 for jj=1,1,imod(val2)
if val2<0 then rval1=1.0/rval2 else rval1=rval2
->REALEND
BISW(17): ! '****' WITH 2 INTEGER OPERAND
RETURN UNLESS 0<=VAL2<=63
VAL2=1
WHILE SVAL2>0 CYCLE
VAL2=VAL2*VAL1
SVAL2=SVAL2-1
REPEAT
VAL1=VAL2; ->INT END
BISW(24): ! CONCAT
RETURN IF 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
FINISH ELSE IF TYPE=1 THEN START
IF 1<<HOST&LINTAVAIL#0 AND PREC=6 THEN VAL=LENGTHENI(OPND_D)<<32!(OPND_XTRA&(LENGTHENI(-1)>>32)) ELSE C
VAL=OPND_D
RVAL=VAL
FINISH ELSE START
IF PREC=5 THEN RVAL=OPND_R ELSE IF PREC=6 THEN START
MOVE BYTES(8,ADDR(OPND_D),0,ADDR(LR),0)
RVAL=LR
FINISH ELSE MOVE BYTES(16,ADDR(WORKA_A(0)),OPND_D,ADDR(RVAL),0)
FINISH
END
INTEGER FN DEBYTESWOP(INTEGER VAL)
!***********************************************************************
!* ITEMS IN THE THE CONST TABLE MAY BE BYTE SWOPPED. DEBYTESWOP BY *
!* BYTE SWOPPING AGAIN. PDS PRAYS THERE WILL NEVER BE ARCHITECTURE *
!* WHERE THIS IS NOT TRUE! *
!***********************************************************************
RECORD (RD) OPND
OPND=0
OPND_PTYPE=X'51'
OPND_D=VAL
IF HOST#TARGET THEN REFORMATC(OPND)
RESULT=OPND_D
END
END
EXTERNAL ROUTINE TRIP OPT(RECORD (TRIPF) ARRAY NAME TRIPLES, INTEGER inptr)
!***********************************************************************
!* SCANS A TRIPLES LIST FOR POSSIBLE OPTIMISATIONS *
!***********************************************************************
INTEGER CHANGES,DUPS,DUPTNO,PTR,I,J,K,VAL,XVAL,CURR,NEXT,OP1,OP2,CTOPOP,REVOP,APTYPE,FOLD AGAIN
BYTE INTEGER ARRAY NAME A
RECORD (TRIPF) NAME CURRT,NEWT,NEXTT
RECORD (RD) NAME OPND1,OPND2,POPND,ROPND
ROUTINE SPEC SWOP OPERANDS(RECORD (TRIPF) NAME CURRT)
INTEGER FN SPEC POWEROF2(INTEGER VAL)
INTEGER FN SPEC PRELOAD PLACE(INTEGER TRIP)
ROUTINE SPEC INDOPT(RECORD (RD) NAME OPND)
ROUTINE SPEC VMYOPT(INTEGER CURR)
INTEGER FN SPEC SAME OPND(RECORD (RD) NAME OPND1,OPND2,integer ASSN)
ROUTINE SPEC INVERT DIV(RECORD (TRIPF) NAME CURRT)
ROUTINE SPEC CHECK DUPS(INTEGER STRIPNO,STRIPNO)
ROUTINE SPEC PROPAGATE CASS(INTEGER STRIPNO, RECORD (RD) NAME N,C)
ROUTINE SPEC DUPLICATE TRIP(INTEGER TRIPNO,DTRIPNO,FLAGBITS)
ROUTINE SPEC DEC USE(INTEGER TRIPLE NO)
ROUTINE SPEC DELETE TRIPLE(INTEGER TRIPLE NO)
IF TARGET=AMDAHL OR TARGET=IBM OR TARGET=IBMXA START
! ON IBM VMY OF 0 ALWAYS ZERO
CONST BYTE INTEGER ARRAY 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,32,X'89',{**,COMP,DCOMP,VMY,COMB} C
0,0,2,0,0,{=,<-,****,BADJ,INDEX} C
0{IFETCH},0(3),
X'40'{CONCAT},0(*)
FINISH ELSE IF TARGET=EMAS START
! INDEX IS NOT NECESSARILY A NOOP WHEN INDEX IS 0
!
CONST BYTE INTEGER ARRAY 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,0,{=,<-,****,BADJ,INDEX} C
0{IFETCH},0(3),
X'40'{CONCAT},0(*)
FINISH ELSE START
CONST BYTE INTEGER ARRAY 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,{=,<-,****,BADJ,INDEX} C
0{IFETCH},0(3),
X'40'{CONCAT},0(*)
FINISH
! 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
!
A==WORKA_A
CHANGES=0; ! NO CHANGES AS YET
DUPS=0; ! NO DUPLICATES YET
if parm_dcomp#0 then printstring("Optimising triples ") and print trips(triples)
!
! LOOK FOR REGISTER TO STORE OPERATIONS ON EMACHINES (xcept VNS and risk)
!
PTR=inptr
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 AND (NEXTT_OPND1_FLAG=DNAME OR C
NEXTT_OPND1_FLAG=INDNAME or NEXTT_OPND1_FLAG=arname) AND NEXTT_OPND2_FLAG=REFTRIP AND CURRT_PUSE=PTR AND CURRT_CNT=1 THEN C
CONTINUE
CONTINUE UNLESS ADD<=CURRT_OPERN<=ANDL; ! lshift & rshift also possible on pnx
IF CURRT_FLAGS&COMMUTABLE#0 AND SAME OPND(CURRT_OPND2,NEXTT_OPND1,NO)=YES THEN C
SWOP OPERANDS(CURRT) ELSE START
CONTINUE UNLESS SAME OPND(CURRT_OPND1,NEXTT_OPND1,NO)=YES
FINISH
NEXTT_X1=CURRT_OPERN
NEXTT_OPERN=RSTORE
NEXTT_PUSE=0
NEXTT_FLAGS<-DONT OPT!CURRT_FLAGS&(¬LOAD OP1); ! THIS AVOIDS A USELESS PRELOAD
NEXTT_opnd2=CURRT_opnd2
triples(NEXTT_BLINK)_opern=NULLT
changes=changes+1
REPEAT
IF CHANGES>0 AND PARM_DCOMP#0 THEN PRINT TRIPS(TRIPLES)
WORKA_OPTCNT=WORKA_OPTCNT+CHANGES
RETURN
INTEGER FN 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
CHANGES=CHANGES+1
END
INTEGER FN PRELOAD PLACE(INTEGER TRIP)
!***********************************************************************
!* LOOK FOR FIRST TRIPLE IN THE CHAIN THAT LEADS TO TRIP *
!* CAN BE VERY COMPILCATED. RETURN -1 IF NOT SIMPLE *
!***********************************************************************
CONST INTEGER 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 THEN RESULT=TRIP
RESULT=PRELOAD PLACE(OPND1_D)
FINISH
IF 1<<CURRT_OPND1_FLAG&TRIPREFS=0 OR OPND1_D=CURRT_BLINK THEN RESULT=PRELOAD PLACE(OPND2_D)
!
! BOTH OPERANDS ARE LOADED TRIPLES
!
IF CURRT_BLINK=OPND2_D THEN RESULT=PRELOADPLACE(OPND1_D)
RESULT=-1; ! TOO COMPLICATED
END
ROUTINE INDOPT(RECORD (RD) NAME OPND)
!***********************************************************************
!* OPND IS AN INDIRECT OFFSET. TRY TO SUBSUME PART OF THE EXPRESSION*
!* INTO THE OFFSET, REALLY GUNNING FOR IMP REFERENCES TO PAG0 ON IBM*
!***********************************************************************
INTEGER COP,X,VAL,OP,LIMIT
RECORD (TRIPF) NAME RTRIP
RECORD (RD) NAME COPND
IF TARGET=IBM OR TARGET=AMDAHL OR TARGET=IBMXA THEN LIMIT=4096 ELSE IF TARGET=EMAS THEN C
LIMIT=X'7FFFFFFF' ELSE LIMIT=1<<16
RTRIP==TRIPLES(OPND_D)
RETURN UNLESS RTRIP_CNT=1 AND RTRIP_FLAGS&CONSTANTOP#0
OP=RTRIP_OPERN
RETURN UNLESS OP=ADD OR OP=SUB
RETURN UNLESS RTRIP_OPTYPE&7=1 AND RTRIP_OPTYPE>>4<6
IF RTRIP_OPND1_FLAG<=1 THEN START
COP=1; ! CONSTANT IS OP 1
COPND==RTRIP_OPND1; ! DEFINED BY COPND
ELSE
COP=2; ! CONSTANT IS OPERAND 2
COPND==RTRIP_OPND2
FINISH
X=OPND_XTRA; ! CURRENT OFFSET
IF X<0 THEN X=0
VAL=COPND_D
IF OP=ADD AND LIMIT>X+VAL>=0 THEN COPND_D=0 AND OPND_XTRA=X+VAL AND RETURN
! THE ZERO ADD WILL BE ELAIMINATED
IF OP=SUB AND LIMIT>X-VAL>=0 AND COP=2 THEN COPND_D=0 AND OPND_XTRA=X-VAL
END
ROUTINE VMYOPT(INTEGER CURR)
!***********************************************************************
!* ANALYSES A VMY AND REPACES WITH A CONSTANT MULTIPLY IF POSSIBLE *
!***********************************************************************
RECORD (TRIPF) NAME CURRT
RECORD (RD) NAME OPND2
INTEGER C,D,VALUE,APTYPE,DV,I,J,DVNAME
CURRT==TRIPLES(CURR)
OPND2==CURRT_OPND2
C=CURRT_X1>>28; ! CURRENT DIMENSION
D=CURRT_X1>>24&15; ! MAX DIMENSION
DV=0
IF OPND2_FLAG=SCONST THEN DV=OPND2_D; ! DOPE VECTOR IF CONST
IF (TARGET=PNX OR TARGET=PERQ OR TARGET=ACCENT) AND C=1 THEN VALUE=1 AND ->TOMULT
APTYPE=-1; ! ARRAY PTYPE
DVNAME=CURRT_X1&X'FFFF'
IF DVNAME>0 THEN APTYPE=WORKA_ASLIST(WORKA_TAGS(DVNAME))_PTYPE
IF TARGET=EMAS START
IF DV>0 START
I=3*(D+1-C)
IF WORKA_CTABLE(DV+I)=0 THEN VALUE=WORKA_CTABLE(DV+I+1) AND ->TOMULT
FINISH
IF APTYPE>>8=2 {ARR=2,NAM=0} AND C=1 AND APTYPE&7<=2 AND APTYPE&255#X'41' THEN VALUE=1 AND ->TOMULT
FINISH
IF TARGET=IBM OR TARGET=AMDAHL OR TARGET=IBMXA START
IF C=1=D AND CURRT_OPND1_FLAG=REFTRIP THEN IBMVMY(CURR)
IF OPND1_FLAG=SCONST AND OPND1_D=0 THEN VALUE=1 AND ->TOMULT
! ANY VMY OF 0 =0 ON IBMS
IF DV>0 THEN VALUE=WORKA_CTABLE(DV+3*C+2) AND ->TOMULT
IF C=1 START
IF APTYPE&7<=2 THEN VALUE=BYTES(APTYPE>>4&7) AND ->TOMULT
IF APTYPE&X'0C00'=0 START; ! NAM=0
IF DVNAME>0 THEN VALUE=WORKA_ASLIST(WORKA_TAGS(DVNAME))_ACC AND ->TOMULT
FINISH
FINISH
FINISH
RETURN
TOMULT: ! CHANGE VMY TO INTEGER MULT
CURRT_OPERN=MULT
CURRT_FLAGS=CURRT_FLAGS!CONSTANT OP
OPND2_PTYPE=CURRT_OPTYPE; ! SOME M-CS HAVE 16 BIT OPERATIONS
OPND2_FLAG=SCONST
OPND2_D=VALUE
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)
IF CURRT_CNT=0 START
PRINTSTRING("dec use???
")
PRINT TRIPS(TRIPLES)
MONITOR
FINISH
CURRT_CNT<-CURRT_CNT-1
IF CURRT_CNT=1 THEN DUPS=DUPS-1
IF CURRT_CNT=0 AND CURRT_OPERN#RSTORE AND CURRT_OPERN#NULLT THEN DELETE TRIPLE(TRIPLE NO)
END
ROUTINE DELETE TRIPLE(INTEGER TRIPLE NO)
RECORD (TRIPF) NAME DELT
DELT==TRIPLES(TRIPLE NO)
IF 1<<DELT_OPND1_FLAG&BTREFMASK#0 THEN DEC USE(DELT_OPND1_D)
IF DELT_OPERN>=128 AND 1<<DELT_OPND2_FLAG&BTREFMASK#0 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,FLAGBITS)
!***********************************************************************
!* 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)
MASTER_FLAGS=MASTER_FLAGS!FLAGBITS
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 1<<OPND1_FLAG&BTREFMASK#0 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 1<<OPND2_FLAG&BTREFMASK#0 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 INVERT DIV(RECORD (TRIPF) NAME CURRT)
!***********************************************************************
!* DIVISION BY A REAL CONSTANT HAS BEEN FOUND *
!* SO INVERT IT AND CHANGE TO MULTIPLY. USE CTOP FOR OPERATIONS *
!* THIS WILL FAIL IF NOT ENOUGH PRECISION ON HOST FOR TARGET *
!***********************************************************************
INTEGER OP,PREC,FLAG,J
RECORD (RD) WOPND,COPND
LONG REAL LR
COPND=CURRT_OPND2; ! THE CONST TO BE INVERTED
PREC=CURRT_OPTYPE>>4; ! PRECISION
WOPND_S1=COPND_S1
!
! SET UP WOPND AS REAL ONE IN GIGTH PRECISION
!
IF PREC=5 THEN WOPND_R=1.0 ELSE IF PREC=6 THEN START
LR=1.0
MOVE BYTES(8,ADDR(LR),0,ADDR(WOPND_D),0)
FINISH ELSE START
WOPND_PTYPE=X'61'
WOPND_D=0
WOPND_XTRA=1
OP=IFLOAT
CTOP(OP,J,0,WOPND,COPND); ! FLOAT LONG 1 TO REAL
RETURN IF OP#0; ! NO CAN DO
FINISH
OP=REAL DIV
CTOP(OP,J,0,WOPND,COPND)
RETURN IF OP#0
CURRT_OPERN=MULT
CURRT_OPND2=WOPND
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,WORKT
RECORD (RD) AOPND,DOPND1,DOPND2,WOPND1,WOPND2
CONST INTEGER LMAX=4
INTEGER ARRAY LABS(0:LMAX)
INTEGER OP,NEXT,LPTR,I,J,CTRIPNO,OPERN,F,C11,C12,C21,C22,W12,W22,LABP
DUPT==TRIPLES(TRIPNO)
DOPND1=DUPT_OPND1; DOPND2=DUPT_OPND2
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 THEN RETURN
IF OPERN=PRECC OR OPERN=CONCAT OR OPERN=PRES1 OR OPERN=PRES2 THEN RETURN
IF OPERN=PRECL OR PASS1<=OPERN<=PASS6 THEN RETURN
if opern=getptr and dupt_optype=X'61' then return
! two word pointers are tricky things to store and pickup
F=DUPT_FLAGS
LPTR=0; LABP=0
WHILE STRIPNO>0 CYCLE
CURRT==TRIPLES(STRIPNO)
EXIT IF CURRT_FLAGS&ASS LEVEL#0
OP=CURRT_OPERN
IF OP=FJUMP AND LPTR<=LMAX START
J=CURRT_OPND1_D
I=J&X'FFFF'; ! THE LAB NO
IF J<0 AND I>WORKA_NNAMES THEN LABS(LPTR)=I AND LPTR=LPTR+1
FINISH
IF OP=TLAB START
LABP=USED LATE; ! FLAG OPERAND IF DUPLICATE FOUND
J=CURRT_OPND1_D&X'FFFF'; ! THE LAB NO
FOR I=0,1,LPTR-1 CYCLE
->JSEEN IF J=LABS(I)
REPEAT
EXIT; ! CAN NOT NORMALLY PASS LABES
JSEEN: ! THE FIRST JUMP TO THIS LAB HAS
! BEEN PASSED. THERE ARE NO BACK JUMPS
! TO INTERNAL LABELS FIRST REFERENCED
! VIA A FORWARD JUMP
FINISH
EXIT IF OP=RTXIT OR OP=RCALL
EXIT IF OP=SETSW OR OP=AHASS OR OP=PTRAS OR OP=LASS
IF OP=VASS OR OP=VJASS or strass1<=op<=strjt OR OP=DMASS OR OP=RSTORE START; ! ASSIGNMENT
AOPND=CURRT_OPND1; ! DEST OF ASSIGNMENT
IF AOPND_FLAG=INDIRECT AND (DOPND1_FLAG=INDIRECT OR DOPND2_FLAG=INDIRECT) START
! MAPPED ARRAYS MAKE AY ARRAY OR MAP ASSIGNMENT
! DIFFICULT TO CHECK OUT. ONLY SAFE CASE
! IS TO DIFFERENT ARRAYS BUT NOT
! IF EITHER ARE ARRAYNAMES
EXIT
FINISH ELSE START
EXIT IF SAME OPND(AOPND,DOPND1,yes)=YES
EXIT IF OPERN>=128 AND SAME OPND(AOPND,DOPND2,yes)=YES
FINISH
FINISH
if op=getad or op=getptr Start
aopnd=currt_opnd1
if same opnd(aopnd,dopnd1,yes)=yes then exit
if opern>=128 and same opnd(aopnd,dopnd2,yes)=yes then exit
finish
CTRIPNO=STRIPNO
STRIPNO=CURRT_FLINK
IF OP=OPERN AND (OP#VMY OR DUPT_X1=CURRT_X1) START
C11=SAME OPND(DOPND1,CURRT_OPND1,NO)
IF OPERN<128 START
IF C11=YES THEN DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
CONTINUE
FINISH
! NOW BINARY ONES
C22=SAME OPND(DOPND2,CURRT_OPND2,NO)
C12=NO; C21=NO
IF F&COMMUTABLE#0 START
C12=SAME OPND(DOPND1,CURRT_OPND2,NO)
C21=SAME OPND(DOPND2,CURRT_OPND1,NO)
FINISH
IF C11=YES=C22 OR C21=YES=C12 START
DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
CONTINUE
FINISH
!
! now check for distributed common expressions ie (a+b) %AND (a+x+b). The latter
! is changes to (a+b+x) and the common element eliminated
!
IF C12!C11!C22!C21=YES START
WORKT==TRIPLES(CURRT_PUSE)
WOPND1=WORKT_OPND1; WOPND2=WORKT_OPND2
IF OP=WORKT_OPERN AND WORKT_CNT=1 AND F&COMMUTABLE#0 START
W22=SAME OPND(DOPND2,WOPND2,NO)
W12=SAME OPND(DOPND1,WOPND2,NO)
IF C12=YES=W22 OR C22=YES=W12 OR C21=YES=W12 OR C11=YES=W22 START
IF C12=YES OR C22=YES START
WORKT_OPND2=CURRT_OPND1
CURRT_OPND1=WOPND2
FINISH ELSE START
WORKT_OPND2=CURRT_OPND2
CURRT_OPND2=WOPND2
FINISH
DUPLICATE TRIP(TRIPNO,CTRIPNO,LABP)
CONTINUE
FINISH
FINISH
FINISH
FINISH
REPEAT
END
ROUTINE PROPAGATE CASS(INTEGER STRIPNO, RECORD (RD) NAME NOPND,COPND)
!***********************************************************************
!* CHECK STARTING FROM STRIPNO FOR DUPLICATES OF TRIPNO *
!* MAY BE MORE THAN ONE *
!***********************************************************************
RECORD (TRIPF) NAME CURRT
RECORD (RD) AOPND
CONST INTEGER LMAX=4
INTEGER ARRAY LABS(0:LMAX)
INTEGER OP,NEXT,LPTR,I,J,CTRIPNO,LABP
LPTR=0;
WHILE STRIPNO>0 CYCLE
CURRT==TRIPLES(STRIPNO)
EXIT IF CURRT_FLAGS&ASS LEVEL#0
OP=CURRT_OPERN
IF OP=FJUMP AND LPTR<=LMAX START
J=CURRT_OPND1_D
I=J&X'FFFF'; ! THE LAB NO
IF J<0 AND I>WORKA_NNAMES THEN LABS(LPTR)=I AND LPTR=LPTR+1
FINISH
IF OP=TLAB START
J=CURRT_OPND1_D&X'FFFF'; ! THE LAB NO
FOR I=0,1,LPTR-1 CYCLE
->JSEEN IF J=LABS(I)
REPEAT
EXIT; ! CAN NOT NORMALLY PASS LABES
JSEEN: ! THE FIRST JUMP TO THIS LAB HAS
! BEEN PASSED. THERE ARE NO BACK JUMPS
! TO INTERNAL LABELS FIRST REFERENCED
! VIA A FORWARD JUMP
FINISH
EXIT IF OP=RTXIT OR OP=RCALL
EXIT IF OP=SETSW OR OP=PTRAS
IF OP=VASS OR OP=STRASS2 OR OP=VJASS OR OP=DMASS OR OP=RSTORE OR OP=GETAD OR OP=GETPTR START
! ASSIGNMENT
AOPND=CURRT_OPND1; ! DEST OF ASSIGNMENT
EXIT IF SAME OPND(AOPND,NOPND,yes)=YES
FINISH
IF SAME OPND(CURRT_OPND1,NOPND,NO)=YES START
CHANGES=CHANGES+1
IF OP<128 OR CURRT_FLAGS&CONSTANTOP#0 THEN FOLD AGAIN=YES
CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
CURRT_OPND1=COPND
FINISH
IF OP>=128 AND SAME OPND(CURRT_OPND2,NOPND,NO)=YES START
CHANGES=CHANGES+1
IF CURRT_FLAGS&CONSTANTOP#0 THEN FOLD AGAIN=YES
CURRT_FLAGS=CURRT_FLAGS!CONSTANTOP
CURRT_OPND2=COPND
FINISH
STRIPNO=CURRT_FLINK
REPEAT
END
INTEGER FN SAME OPND(RECORD (RD) NAME OPND1,OPND2,integer ASSN)
!***********************************************************************
!* ARE THESE OPERANDS THE SAME ? *
!* If assn=yes then allow for possible overlapping assignments *
!* in variant records *
!***********************************************************************
INTEGER F,I,B1,B2
! printstring(" same opnd"); write(opnd1_flag,2); write(opnd2_flag,2); newline
F=OPND1_FLAG
if f=3 start { ar pointer }
result=no unless f=opnd2_flag
b1=opnd1_d; b2=opnd2_d
if a(b1)=a(b2) and a(b1+1)=a(b2+1) and a(b1+2)=2 and a(b2+2)=2 c
and a(b1+3)=2 and a(b2+3)=2 then result=yes
result=no
finish
IF F=2 OR F=5 START
result=no unless f=opnd2_flag
RESULT=NO UNLESS OPND1_D=OPND2_D AND OPND1_PTYPE&X'3000'=0
IF ASSN=NO AND OPND1_PTYPE#OPND2_PTYPE THEN RESULT=NO
IF OPND1_XTRA=OPND2_XTRA THEN RESULT=YES
B1=BYTES(OPND1_PTYPE>>4&15)
B2=BYTES(OPND2_PTYPE>>4&15)
i=IMOD(OPND1_XTRA&X'FFFF'-OPND2_XTRA&X'FFFF')
IF ASSN=YES AND (i<=B1 or i<=B2) THEN RESULT=YES
RESULT=NO
FINISH
RESULT=NO UNLESS OPND1_S1&X'FFFF00FF'=OPND2_S1&X'FFFF00FF'
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 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
END OF FILE