.TITLE VIRDSK - FORTRAN Disk Virtual Array Handling .IDENT /2/ ;RLW 15-Nov-85 ;----------------------------------------------------------------------------- ; ; This module provides FORTRAN disk virtual array capability for ; FORTRAN-77 running under RT-11. ; ; Robert Walraven ; Multiware, Inc. ; 139 G Street, Suite 161 ; Davis, CA 95616 ; ;----------------------------------------------------------------------------- .MCALL .ENTER .READW .WRITW .PRINT .EXIT ; NUMBUF is the number of 256-word buffers to assemble with this module. ; Supported values for NUMBUF are 2, 4, 8, and 16. ; NUMBUF = 16 ; Define the release of F77: ; ; REL = 1 F77 V5.0 ; REL = 2 F77 V5.0A ; REL = 1 ; Define F77 ADB array parameters ; A.PLYV =2 A.ASUM =100000 A.CWRD =4 A.SIZB =2 ARYREF =336 ; Counters for efficiency evaluation. Note: These counters can be picked ; up by the user's FORTRAN program as follows ; ; INTEGER*4 ACCESS, FAULT ; COMMON / VCOUNT / ACCESS, FAULT ; .PSECT VCOUNT,RW,D,GBL,REL,OVR ACCESS: .BLKW 2 ; Number of array accesses (INTEGER*4) FAULT: .BLKW 2 ; Number of block faults (INTEGER*4) ; Include release dependent stuff .IF EQ REL-1 VIRSZ$: $VIRSZ .ENDC .IF EQ REL-2 .PSECT $$OTSV,RW,D,GBL,REL,OVR QBLK$:: 0 VIRSZ$::$VIRSZ IOBKF$::0 IOBKL$::0 .ENDC ; Miscellaneous internal variables .PSECT $VHAND,D AREA: .BLKW 5 ; argument area for RT-11 EMT calls ACOUNT: .BLKW ; access counter DBLK: .RAD50 /DK FORTRAVIR/ ; Name of virtual disk file ; Error messages NOINIT: .ASCIZ /?-F-Virtual array initialization error/ NOROOM: .ASCIZ /?-F-Not enough room for virtual array disk file on DK:/ .EVEN ; Disk buffer area BUFF00: .BLKW 256. BUFF01: .BLKW 256. .IF GT NUMBUF-2 BUFF02: .BLKW 256. BUFF03: .BLKW 256. .IF GT NUMBUF-4 BUFF04: .BLKW 256. BUFF05: .BLKW 256. BUFF06: .BLKW 256. BUFF07: .BLKW 256. .IF GT NUMBUF-8. BUFF08: .BLKW 256. BUFF09: .BLKW 256. BUFF10: .BLKW 256. BUFF11: .BLKW 256. BUFF12: .BLKW 256. BUFF13: .BLKW 256. BUFF14: .BLKW 256. BUFF15: .BLKW 256. .ENDC .ENDC .ENDC BUFTBL: BUFF00 ; Table of addresses of buffers BUFF01 .IF GT NUMBUF-2 BUFF02 BUFF03 .IF GT NUMBUF-4 BUFF04 BUFF05 BUFF06 BUFF07 .IF GT NUMBUF-8. BUFF08 BUFF09 BUFF10 BUFF11 BUFF12 BUFF13 BUFF14 BUFF15 .ENDC .ENDC .ENDC ; Buffer control tables RESTBL: .REPT NUMBUF ; RESTBL+N holds current resident blk no. for block N .WORD -1 .ENDR ACCTBL: .REPT NUMBUF ; ACCTBL+N is value of access counter at last access .WORD 0 .ENDR .PSECT $VHANC,I ;======================================================================= ; $VINIT ; ; Initialize virtual array mapping ; ;======================================================================= $VINIT:: TST VIRSZ$ ; any virtual arrays? BEQ 1$ ; branch if not MOV VIRSZ$,R0 ; get size needed CLR R1 ; prepare 32-bit shift ASHC #-3,R0 ; R0 = number of blocks BIC #160000,R0 ; clear any bits passed in MOV R0,R4 ; R4 = number of blocks needed - 1 INC R4 ; add one .ENTER #AREA,#14.,#DBLK,R4 BCC 1$ .PRINT #NOINIT .EXIT 1$: $NOLXM::RETURN ;======================================================================= ; VIRTUAL ARRAY MAPPING FUNCTIONS: ; ; Map a virtual array element to a real memory address ; ; CALLING SEQUENCE: ; ; MOV ,R0 ; MOV #ADB,-(SP) ; JSR PC,VRTX$ ; for no subscript checking ; or ; JSR PC,VRTXC$ ; for subscript checking ; ; Returns materialized address in R0, all other registers ; preserved. ;======================================================================= .GLOBL $OTSV VRTBC$:: ; LOGICAL*1 element checking entry MOV (PC)+,-(SP) ; flag checking VRTB$:: ; LOGICAL*1 element entry CLR -(SP) ; flag no checking MOV #-6,-(SP) ; push BPE/64 MOV #177600,-(SP) ; push 6 bit mask BR COM ; and join common flow VRTLC$:: ; LOGICAL*2 element checking entry VRTIC$:: ; INTEGER*2 element checking entry MOV (PC)+,-(SP) ; flag checking VRTL$:: ; LOGICAL*2 element entry VRTI$:: ; INTEGER*2 element entry CLR -(SP) ; flag no checking MOV #-5,-(SP) ; push BPE/64 MOV #177400,-(SP) ; push 5 bit mask BR COM ; and join common flow VRTMC$:: ; LOGICAL*4 element checking entry VRTJC$:: ; INTEGER*4 element checking entry VRTRC$:: ; REAL*4 element checking entry MOV (PC)+,-(SP) ; flag checking VRTM$:: ; LOGICAL*4 element entry VRTJ$:: ; INTEGER*4 element entry VRTR$:: ; REAL*4 element entry CLR -(SP) ; flag no checking MOV #-4,-(SP) ; push BPE/64 MOV #177000,-(SP) ; push 4 bit mask BR COM ; and join common flow VRTDC$:: ; REAL*8 element checking entry VRTCC$:: ; COMPLEX*8 element checking entry MOV (PC)+,-(SP) ; flag checking VRTD$:: ; REAL*8 element entry VRTC$:: ; COMPLEX*8 element entry CLR -(SP) ; flag no checking MOV #-3,-(SP) ; push BPE/64 MOV #176000,-(SP) ; push 3 bit mask COM: MOV R1,-(SP) ; save R1, R2, R3, and R4 MOV R2,-(SP) MOV R3,-(SP) MOV 16(SP),R2 ; get ADB ptr SUB A.PLYV(R2),R0 ; subtract POLYA to get real elem number TST 12(SP) ; Bounds checking? BEQ 20$ ; Branch if not TST R0 ; Within lower array bounds? BMI 10$ ; Branch if not. BIT #A.ASUM,A.CWRD(R2); Assumed size array? BNE 20$ ; If so skip around upper bounds check CMP R0,A.SIZB(R2) ; within upper bound? BLE 20$ ; OK 10$: TRAP+ARYREF ; subscript out of bounds 20$: CLR R1 ; prepare for 32-bit shift ASHC 10(SP),R0 ; scale by BPE/64, and mask extension bits ADD (R2),R0 ; add base block number ASHC #-3,R0 ; convert to 256-word blocks BIC 6(SP),R0 ; R0 = block number, R1 = offset in block ADD #1,ACCESS ; count access ADC ACCESS+2 ; as two-word integer ; Scan residency table for desired block MOV #RESTBL,R2 ; R2 -> residency table MOV #NUMBUF,R3 ; R3 = buffer count 1$: CMP R0,(R2)+ ; desired block in buffer (R2)? BEQ BLKIN ; branch if it is SOB R3,1$ ; else continue search ADD #1,FAULT ; count block fault ADC FAULT+2 ; as two-word integer ; Scan access table for least recently accessed buffer MOV R4,-(SP) MOV #NUMBUF,R4 ; R4 = buffer count MOV #ACCTBL,R2 ; R2 -> access table MOV R2,R3 ; will do compares in same table 2$: CMP (R2),(R3)+ ; buffer R3 less recently accessed? BLOS 3$ ; branch if not MOV R3,R2 ; else make new pointer SUB #2,R2 ; but back it up one word 3$: SOB R4,2$ ; keep on searching SUB #ACCTBL,R2 ; correct to an index number ; Write current buffer and read desired block MOV R0,R4 ; R0 is volatile in following calls MOV R0,-(SP) ; so save it CMP RESTBL(R2),#-1 ; used buffer? BEQ 4$ ; branch if not .WRITW #AREA,#14.,BUFTBL(R2),#256.,RESTBL(R2) BCS OOPS 4$: .READW #AREA,#14.,BUFTBL(R2),#256.,R4 BCS OOPS MOV (SP)+,R0 ; restore R0 MOV R4,RESTBL(R2) ; update residency word MOV (SP)+,R4 BR BLKI ; Desired block is now resident in buffer (R2) BLKIN: SUB #RESTBL+2,R2 ; correct for buffer number BLKI: INC ACOUNT ; increment access counter BNE 2$ ; continue unless counter=0 MOV #NUMBUF,R0 ; get buffer count MOV #ACCTBL,R3 ; R3 -> access table 1$: CLR (R3)+ ; clear entry SOB R0,1$ ; continue until all clear INC ACOUNT ; set count to 1 2$: MOV ACOUNT,ACCTBL(R2) ; update accesss count for buffer (R2) ; Now set up materialize address CLR R0 ; Pick up offset ASHC #9.,R0 ; ADD BUFTBL(R2),R0 ; Add table offset MOV (SP)+,R3 ; restore registers MOV (SP)+,R2 ; MOV (SP)+,R1 ; TST (SP)+ ; dump mask CMP (SP)+,(SP)+ ; dump check flag and scale factor MOV (SP)+,(SP) ; copy up return address RETURN ; and return ; Not enough room error OOPS: .PRINT #NOROOM .EXIT .END