PDP-10 Archive: regutl.bli from BB-D480F-SB_FORTRAN10

Trailing-Edge - PDP-10 Archives - BB-D480F-SB_FORTRAN10_V10 - regutl.bli

There are 12 other files named regutl.bli in the archive. Click here to see a list.

!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1974, 1985
!ALL RIGHTS RESERVED.
!
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
!ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
!INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
!COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
!OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
!TRANSFERRED.
!
!THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
!AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
!CORPORATION.
!
!DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
!SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

!AUTHORS: NORMA ABEL AND SARA MURPHY/HPW/TFV/AHM/TJK

MODULE REGUTL(RESERVE(0,1,2,3),SREG=#17,VREG=#15,FREG=#16,DREGS=4,GLOROUTINES)=
BEGIN

GLOBAL BIND REGUTV = #10^24 + 0^18 + #2364;	! Version Date: 6-Jun-84


%(

***** Begin Revision History *****

17	-----	-----	CREATE MODULE
18	-----	-----	TAKE LASTONE OUT AND PUR IT BACK IN UTIL
19	-----	-----	MAKE ALODIMCONSTS ALLOCATE CONSTANTS FOR PROTECTED
			ARRAYS WHEN "DEBUG" SWITCH NOT SET
20	-----	-----	MODIFY ALODIMCONSTS TO ALLOCATE CONSTS FOR
			ARRAY DIMENSIONS WHEN EITHER THE "BOUNDS" SWITCH
			OR THE "DEBUG" SWITCH IS SET (WE NO LONGER PROTECT
			INDIVIDUAL ARRAYS - ONLY ALL ARRAYS)
21	-----	-----	CHANGE REF TO THE FLAG "DEBUG" TO REF TO "DBGDIMN"

***** Begin Version 7 *****

22	1274	TFV	20-Oct-81	------
	Rewrite NXTTMP, its arg is now the size of the .Qnnnn variable to 
	allocate.  Write NEWQTMP to generate a new .Qnnnn variable.

1552	AHM	6-Jun-82
	Make NEWQTMP set the  IDPSECT and IDPSCHARS  fields of the  .Q
	temp being  created to  PSDATA  so that  we can  generate  the
	address of the .Q temp in HSDDESC in OUTMOD.

***** End V7 Development *****

2006	TJK	6-Oct-83
	Add ENDSMZTRIP to see if the current statement (pointed to  by
	CSTMNT) ends a MAYBEZTRIP DO-loop.


***** Begin Version 10 *****

2227	TJK	21-Oct-83
	Add ENDSBBLOCK to see if the current statement (pointed to  by
	CSTMNT) ends a basic block.  Returns one of several values  to
	indicate how the block is ended  (if it is ended).  Also  made
	ENDSMZTRIP non-global and fixed some comments.

2364	TJK	6-Jun-84
	Make ENDSMZTRIP global for use by ALCIOLST.

***** End V10 Development *****

***** End Revision History *****

)%

SWITCHES NOLIST;
REQUIRE FIRST.BLI;
REQUIRE TABLES.BLI;
SWITCHES LIST;

EXTERNAL
%2006%	BASE CSTMNT,	! Pointer to current statement being processed
	QANCHOR,	! Pointer to start of linked .Q list
	BASE	LASTQ,	! Pointer to the last .Q used by the current statement
%2227%	QLOC,		! Next location in .Q space to be used by the
			! current statement
	QMAX,		! Maximum size of .Q space for all statements
	QCNT,		! Value to use for .Qnnnn
	CORMAN;		! Routine to get space for the entry

GLOBAL ROUTINE ENDSMZTRIP =	![2364] Made global

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine looks to see if the current statement (e.g.,  the
!	statement node pointed to by CSTMNT) terminates a DO-loop with
!	the MAYBEZTRIP flag set.
!
! FORMAL PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	CSTMNT	points to the current statement node.
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! ROUTINE VALUE:
!
!	TRUE	if the current statement terminates some MAYBEZTRIP DO-loop
!	FALSE	if the current statement terminates no MAYBEZTRIP DO-loop
!
! SIDE EFFECTS:
!
!	NONE
!
!--


![2006] Routine added in this edit
BEGIN
	REGISTER BASE LAB;	! LAB points to the stmnt number table entry
	REGISTER BASE LINK;	! LINK points to the DO-node links
	REGISTER BASE CURDO;	! CURDO points to the DO-nodes

	IF F77					! Only check if compiling F77
	THEN IF (LAB = .CSTMNT[SRCLBL]) NEQ 0	! and statement is labeled
	THEN
	BEGIN	! Labeled F77 statement

		! We're compiling F77 and  this statement is  labeled.
		! Look for a MAYBEZTRIP DO-loop terminated by it,  and
		! return  immediately  with  TRUE  if  we  find   one.
		! Otherwise fall through and return FALSE.

		LINK = .LAB[SNDOLNK];	! Set LINK to first link (if any)

		UNTIL .LINK EQL 0	! Loop until end of list
		DO
		BEGIN	! For each DO statement

			CURDO = .LINK[LEFTP];	! CURDO points to DO-node
			IF .CURDO[MAYBEZTRIP]	! Is DO-node MAYBEZTRIP?
			THEN RETURN TRUE;	! Yes, found a MAYBEZTRIP loop
			LINK = .LINK[RIGHTP];	! Otherwise move to next link

		END;	! For each DO statement

	END;	! Labeled F77 statement

	RETURN FALSE;	! We didn't find a MAYBEZTRIP DO-node

END;	! of ENDSMZTRIP

GLOBAL ROUTINE ENDSBBLOCK =	![2227] Routine added in this edit

!++
! FUNCTIONAL DESCRIPTION:
!
!	This routine looks to see if the current statement (i.e.,  the
!	statement node pointed to by CSTMNT) is the last statement  in
!	a basic block.  CSTMNT must not be zero.  The routine  returns
!	one of several values to indicate  how the block is ended  (if
!	it is ended).
!
!
!	A basic block is terminated after (i.e., CSTMNT points to):
!
!		1.  A STATEMENT FUNCTION statement
!
!		2.  A CALL  statement  (since any  CALL  statement  is
!		    assumed to clobber all registers)
!
!		3.  A LOGICAL IF statement whose consequent is a  CALL
!		    statement
!
!		4.  A DO statement (since  control may be  transferred
!		    to the  following statement  from the  end of  the
!		    loop)
!
!		5.  A statement which terminates at least one  DO-loop
!		    whose MAYBEZTRIP flag  is set (i.e.,  the loop  is
!		    potentially zero-trip,  and control  may  transfer
!		    directly to the statement following the loop)
!
!		6.  The last statement node in the encoded source tree
!
!
!	A basic block is terminated before (i.e., CSTMNT[SRCLINK] points to):
!
!		1.  A STATEMENT FUNCTION statement
!
!		2.  An ENTRY statement
!
!		3.  A labeled  statement  whose  label  is  referenced
!		    other  than  as  a  DO-loop  terminator  (i.e.,  a
!		    statement which  has control  transferred to  it);
!		    note that FORMAT statements  do not appear in  the
!		    encoded source tree
!
!
! FORMAL PARAMETERS:
!
!	NONE
!
! IMPLICIT INPUTS:
!
!	CSTMNT	points to the current statement node.  CSTMNT must not
!		be  zero.    The   statement  node   pointed   to   by
!		CSTMNT[SRCLINK]   may    also    be    examined,    if
!		CSTMNT[SRCLINK] isn't zero.
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! ROUTINE VALUE:
!
!	0	if the current statement isn't the last statement in a
!		basic block.
!
!	1	if the current  statement is the  last statement in  a
!		basic block, for  at least one  reason other than  the
!		current statement being a DO statement.
!
!	2	if the current  statement is the  last statement in  a
!		basic block,  for the  sole  reason that  the  current
!		statement is a DO statement.
!
!	If the current statement  is a DO statement  then return 1  if
!	and only if the  next statement is  a labeled statement  whose
!	label is referenced other than as a DO-loop terminator.   This
!	is the only other condition  for basic block termination  when
!	the current statement is a DO statement.  In such a case don't
!	return 2  because the  the  DO-variable might  not be  in  its
!	allocated register upon a branch to the labeled statement.
!
!
! SIDE EFFECTS:
!
!	NONE
!
!--


BEGIN
	REGISTER BASE NEXTSTMNT;	! NEXTSTMNT points to the next stmnt
	REGISTER BASE TMPBASE;		! TMPBASE is a temporary pointer

	IF .CSTMNT[SRCID] EQL SFNID	! Is curr stmnt a STATEMENT FUNCTION?
	THEN RETURN 1;			! Yes, end basic block normally

	IF .CSTMNT[SRCID] EQL CALLID	! Is curr stmnt a CALL?
	THEN RETURN 1;			! Yes, end basic block normally

	IF .CSTMNT[SRCID] EQL IFLID	! Is curr stmnt a LOGICAL IF?
	THEN
	BEGIN	! LOGICAL IF case

		TMPBASE = .CSTMNT[LIFSTATE];	! TMPBASE points to consequent
		IF .TMPBASE[SRCID] EQL CALLID	! Is consequent a CALL?
		THEN RETURN 1;			! Yes, end basic block normally

	END;	! LOGICAL IF case

	IF (NEXTSTMNT = .CSTMNT[SRCLINK]) EQL 0	! Is this the last statement of
						! the current program unit
						! (i.e., the END statement)?
	THEN RETURN 1;				! Yes, end basic block normally

	IF .NEXTSTMNT[SRCID] EQL SFNID	! Is next stmnt a STATEMENT FUNCTION?
	THEN RETURN 1;			! Yes, end basic block normally

	IF .NEXTSTMNT[SRCID] EQL ENTRID	! Is next stmnt an ENTRY?
	THEN RETURN 1;			! Yes, end basic block normally

	! See if the  next statement is  labeled.  If it  is, look  at
	! SNREFNO minus  1 (since  the actual  label is  counted as  a
	! reference), and  if  this  is greater  than  the  number  of
	! DO-loops terminated  by  the  label,  then  control  may  be
	! transferred to this  statement.  In this  case, the  current
	! statement is the  last statement of  the basic block.   Note
	! that FORMAT statements do not  appear in the encoded  source
	! tree.

	IF (TMPBASE = .NEXTSTMNT[SRCLBL]) NEQ 0		  ! Next stmnt labeled?
	THEN IF .TMPBASE[SNREFNO]-1 GTR .TMPBASE[SNDOLVL] ! Yes, check the use
	THEN RETURN 1;	! Control may be transferred to this label, so
			! end basic block normally

	! Now call ENDSMZTRIP, which will  return TRUE if the  current
	! statement ends at  least one  MAYBEZTRIP (i.e.,  potentially
	! zero-trip) DO-loop.   In this  case we  terminate the  basic
	! block after the  current statement, since  control could  be
	! transferred directly  to  the  following  statement  in  the
	! zero-trip case.

	IF ENDSMZTRIP()	! Does curr stmnt end at least one MAYBEZTRIP DO-loop?
	THEN RETURN 1;	! Yes, end basic block normally

	! If we  made  it this  far,  then  the only  reason  left  to
	! terminate the basic block is  if the current statement is  a
	! DO statement.  In this case,  control may be transferred  to
	! the following statement from the end of the loop, so we must
	! end the basic block.  However, we may be able to access  the
	! DO-variable from a register, so we return a special value to
	! indicate this.

	IF .CSTMNT[SRCID] EQL DOID	! Is curr stmnt a DO?
	THEN RETURN 2;			! Yes, end basic block and indicate why

	! If we made it to here, then there is no reason to  terminate
	! the basic block after the current statement.

	RETURN 0;	! Continue basic block

END;	! of ENDSBBLOCK

GLOBAL ROUTINE MAKRC0(VTYPE)=
%(***************************************************************************
	ROUTINE TO MAKE A REGCONTENTS NODE FOR REG 0 HAVING TYPE "VTYPE".
	 THESE NODES WILL BE SUBSTITUTED FOR THE LHS OF ALL STMNT
	FNS (SUBSTITUTION IS DONE DURING REG ALLOC PASS).
***************************************************************************)%
BEGIN
	EXTERNAL NAME,CORMAN;	!USED TO GET SOME FREE CORE

	OWN PEXPRNODE REGC0;

	NAME<LEFT>_EXSIZ;	!NUMBER OF WDS IN AN EXPRESSION NODE
	REGC0_CORMAN();		!GET FREE STORAGE FOR THE NODE

	REGC0[VALTYPE]_.VTYPE;
	REGC0[OPRCLS]_REGCONTENTS;
	REGC0[INREGFLG]_1;
	REGC0[TARGTAC]_RETREG;	!THE REG USED FOR RETURNING FN VALS (REG 0)
	REGC0[TARGADDR]_RETREG;
	RETURN .REGC0		!RETURN A PTR TO THE NODE
END;

GLOBAL ROUTINE ALODIMCONSTS=
%(***************************************************************************
	ROUTINE TO ALLOCATE CORE FOR ALL CONSTANTS THAT OCCUR IN
	SPECIFICATIONS OF DIMENSION INFORMATION FOR 
	ARRAYS  WHEN THE "BOUNDS" SWITCH OR THE "DEBUG" SWITCH IS SET.
***************************************************************************)%
BEGIN
	EXTERNAL SYMTBL;
	EXTERNAL ALDIM1;
	REGISTER BASE SYMPTR;

	IF NOT (.FLGREG<BOUNDS> OR .FLGREG<DBGDIMN>) THEN RETURN;	!WILL ALLOCATE THE DIM CONSTS IF
					! THE USER SPECIFIED ARRAY BOUNDS CHECKING TO BE DONE
					! OR DEBUGGING INFO TO BE PASSED TO FORDDT


	%(***WALK THRU THE SYMBOL TABLE AND FOR EACH ENTRY WHICH IS
		AN ARRAY NAME, PROCESS THE DIMENSION INFO FOR THAT ARRAY.
		THIS IS ECESSARY BECAUSE THERE IS NO WAY TO DIRECTLY WALK
		THRU THE DIMENSION TABLE
	****)%
	DECR I FROM SSIZ-1 TO 0
	DO
	BEGIN
		SYMPTR_.SYMTBL[.I];
		UNTIL .SYMPTR EQL 0	!LOOK AT EACH SYMBOL THAT HASHED
					! TO ENTRY "I"
		DO
		BEGIN
			IF .SYMPTR[OPRSP1] EQL ARRAYNM1	!IF THIS AN ENTRY FOR AN ARRAY NAME
			THEN
			 ALDIM1(.SYMPTR[IDDIM]);	! ALLOCATE ALL CONSTS IN ITS DIM TABLE ENTRY
			SYMPTR_.SYMPTR[CLINK]
		END
	END
END;

GLOBAL ROUTINE ALDIM1(DIMPTR)=
%(***************************************************************************
	ROUTINE TO GO THRU A DIMENSION TABLE ENTRY ALLOCATING CORE FOR ALL CONSTANTS
	USED IN THAT ENTRY. THIS ROUTINE IS CALLED:
		1. WHEN THE USER HAS SPECIFIED THE "DEBUG" SWITCH
			INDICATING THAT ALL DIMENSION TABLE INFORMATION
			SHOULD BE OUTPUT.
		2. WHEN THE USER HAS SPECIFIED THAT THIS PARTICULAR ARRAY
		   SHOULD BE "PROTECTED".
***************************************************************************)%
BEGIN
	EXTERNAL ALOCONST;	!ROUTINE TO SET FLAG IN CONST TABLE
				! ENTRY INDICATING THAT CORE SHOULD BE ALLOCATED
				! FOR THIS CONST
	MAP BASE DIMPTR;	!PTR TO THE DIMENSION TABLE ENTRY
	REGISTER DIMSUBENTRY DIMLSTPTR;	!PTR TO THE SUBENTRY FOR A GIVEN DIMENSION

	IF NOT .DIMPTR[ADJDIMFLG]	!IF THIS ARRAY HAS NO ADJUSTABLE DIMENSIONS
	THEN ALOCONST(.DIMPTR[ARAOFFSET]);	! THEN THE "OFFSET" WILL BE CONST - ALLOCATE CORE FOR IT


	DIMLSTPTR_DIMPTR[FIRSTDIM];	!PTR TO SUBENTRY FOR 1ST DIMENSION

	DECR CT FROM (.DIMPTR[DIMNUM] - 1) TO 0	!LOOK AT THE SUBENTRY FOR EACH DIMENSION
	DO
	BEGIN
		IF NOT .DIMLSTPTR[VARLBFLG]	!IF THE LOWER BOUND IS A CONST
		THEN ALOCONST(.DIMLSTPTR[DIMLB]);	! ALLOCATE CORE FOR IT
		IF NOT .DIMLSTPTR[VARUBFLG]	!IF THE UPPER BOUND IS A CONST
		THEN ALOCONST(.DIMLSTPTR[DIMUB]);
		IF NOT .DIMLSTPTR[VARFACTFLG]	!IF THE FACTOR FOR THIS DIMENSION IS A CONST
		THEN ALOCONST(.DIMLSTPTR[DIMFACTOR]);

		DIMLSTPTR_.DIMLSTPTR+DIMSUBSIZE
	END
END;

GLOBAL ROUTINE ALOCONST(CNODE)=
%(***************************************************************************
	ROUTINE TO SET A FLAG INDICATING THAT THIS CONSTANT SHOULD HAVE CORE
	ALLOCATED FOR IT.
	THIS SHOULD PROBABLY BE MADE A MACRO AT SOME POINT.
***************************************************************************)%
BEGIN
	MAP BASE CNODE;

	CNODE[CNTOBEALCFLG]_1;
	.CNODE
END;

GLOBAL ROUTINE NEWQTMP=
BEGIN

%1274%	! Written by TFV on 20-Oct-81
	! Create a new .Q variable entry

	REGISTER PEXPRNODE QVAR;	! Pointer to entry

	NAME<LEFT> = IDSIZ;		! Use a symbol table like entry
	QVAR = CORMAN();		! Get space for new .Q variable

	QVAR[OPRCLS] = DATAOPR;		! Data operator OPRCLS
	QVAR[OPERSP] = TEMPORARY;	! Specific operator is temporary
	QVAR[IDADDR] = .QLOC;		! Set address to offset in .Q space
%1552%	QVAR[IDPSECT] = QVAR[IDPSCHARS] = PSDATA; ! Temps live in the lowseg

	QVAR[IDSYMBOL] = SIXBIT'.Q0000' +	! Make the .Qnnnn name
		(.QCNT<9,3>)^18 +
		(.QCNT<6,3>)^12 +
		(.QCNT<3,3>)^6 +
		(.QCNT<0,3>);

	QCNT = .QCNT + 1;	! Increment QCNT

	RETURN .QVAR;

END;	! NEWQTMP

GLOBAL ROUTINE NXTTMP(SIZE)=
BEGIN
%1274%	! Rewritten by TFV on  20-Oct-81	
	! Get or create the next .Qnnnn variable
	! They are kept as a linked list, the IDADDR field points to 
	! the offset into .Q space	

	REGISTER
		BASE	CURRQ,	! Pointer to the current .Q variable we created or reused
		NEXTQ;		! Pointer to the next .Q variable in the .Q list

	LABEL	FINDIT;		! Used when we are searching down the .Q list

	IF .LASTQ EQL 0
	THEN
	BEGIN	! This is the first .Q variable for this statement

		IF .QANCHOR EQL 0
		THEN
		BEGIN	! First ever - create it

			CURRQ = NEWQTMP();
			QANCHOR  = .CURRQ;	! First ever created

		END	! First ever - create it

		ELSE	CURRQ = .QANCHOR;	! Start at beginning of .Q list

	END	! This is the first .Q variable for this statement
	ELSE
FINDIT:
	BEGIN	! Search down .Q list to find a .Q variable at QLOC

		WHILE (CURRQ = .LASTQ[CLINK]) NEQ 0 DO
		BEGIN

			IF .CURRQ[IDADDR] EQL .QLOC THEN LEAVE FINDIT;	! One exists, we are done

			IF .CURRQ[IDADDR] GTR .QLOC
			THEN
			BEGIN	! There is none, create a new one and link it in

				NEXTQ = .CURRQ;		! Insert before CURRQ
				CURRQ = NEWQTMP();	! Make a new .Q variable
				LASTQ[CLINK] = .CURRQ;	! Last points to new .Q variable
				CURRQ[CLINK] = .NEXTQ;	! New points to next .Q variable

				LEAVE FINDIT;		! We create a new one, we are done

			END;	! There is none, create a new one and link it in

			LASTQ = .CURRQ;		! Look at next exntry in .Q list
		END;	! WHILE (CURRQ = .LASTQ[CLINK] NEQ 0 DO

		! We walked off the end of the list - create a new .Q and link it at the end

		CURRQ = NEWQTMP();	! Create it
		LASTQ[CLINK] = .CURRQ;	! Link it in

	END;	! FINDIT - Search down .Q list to find a .Q variable at QLOC

	QLOC = .QLOC + .SIZE;		! QLOC points after this entry

	IF .QLOC GTR .QMAX THEN QMAX = .QLOC;	! Update QMAX if it grew

	LASTQ = .CURRQ;		! LASTQ is now the one we just created or reused
	RETURN .LASTQ;		! Return the pointer to it

END;	! NXTTMP

END
ELUDOM