!*
!* Communications record format - extant from CHOPSUPE 22B onwards *
!*
RECORDFORMAT COMF(INTEGER OCPTYPE,SLIPL,SBLKS,SEPGS,NDISCS,DLVNADDR, C
(INTEGER GPCTABSIZE,GPCA OR INTEGER DCUTABSIZE,DCUA), C
INTEGER SFCTABSIZE,SFCA,SFCK,DIRSITE, C
DCODEDA,SUPLVN,TOJDAY,DATE0,DATE1,DATE2, C
TIME0,TIME1,TIME2,EPAGESIZE,USERS,CATTAD,SERVAAD, C
BYTEINTEGER NSACS,RESV1, C
(BYTEINTEGER SACPORT1,SACPORT0 OR BYTEINTEGER C
OCP1 SCU PORT,OCP0 SCU PORT), BYTEINTEGER C
NOCPS,SYSTYPE,OCPPORT1,OCPPORT0,INTEGER ITINT,CONTYPEA, C
(INTEGER GPCCONFA OR INTEGER DCUCONFA), C
INTEGER FPCCONFA,SFCCONFA,BLKADDR,RATION, C
(INTEGER SMACS OR INTEGER SCUS), C
INTEGER TRANS,LONGINTEGER KMON, C
INTEGER DITADDR,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, C
SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, C
COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,TSLICE,FEPS, C
MAXCBT,PERFORMAD,BYTEINTEGER DAPNO,DAPBLKS,DAPUSER,DAPSTATE, C
INTEGER DAP1,SP1,SP2,SP3,SP4, C
LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ, C
HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3, C
SDR4,SESR,HOFFBIT,BLOCKZBIT,BLKSHIFT,BLKSIZE,END)
!
!-----------------------------------------------------------------------
! PON & POFF etc. declarations
RECORDFORMAT PARMF(INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6)
CONSTLONGINTEGER NONSLAVED=X'2000000000000000'
CONSTINTEGER PCELLSIZE=36; ! PARM cell size
CONSTINTEGER MARGIN=48; ! margin of unformatted cells
RECORDFORMAT PDOPEF(INTEGER CURRMAX, MAXMAX, FIRST UNALLOC, C
LAST UNALLOC, NEXTPAGE, S1, S2, S3, S4)
EXTERNALINTEGER PARMASL=0,MAINQSEMA=-1
RECORDFORMAT PARMXF(INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6,LINK)
CONSTRECORD (PARMXF)ARRAYNAME PARM=PARM0AD
CONSTRECORD (PDOPEF)NAME PARMDOPE=PARM0AD
EXTERNALLONGINTEGER PARMDES
OWNLONGLONGREAL GETNEWPAGE
CONSTRECORD (COMF)NAME COM=X'80C00000'
RECORDFORMAT STOREF(INTEGER FLAGLINK,BFLINK,REALAD)
CONSTRECORD (STOREF)ARRAYNAME STORE=STORE0AD
CONSTINTEGERNAME STORESEMA=STORE0AD+8;! use STORE(0)_REALAD as SEMA
CONSTSTRINGNAME DATE=X'80C0003F'
CONSTSTRINGNAME TIME=X'80C0004B'
CONSTINTEGER TRANSIZE=1024*EPAGESIZE
CONSTINTEGER LOCSN1=LOCSN0+MAXPROCS
RECORDFORMAT SERVF(INTEGER P, L)
! L is link in circular chain of
! services which constitute a queue
! P is pointer to circular list
! of parameters for this service
! 2**31 bit of P is inhibit
! 2**30 of P is inter OCP lockout
CONSTRECORD (SERVF)ARRAYNAME SERVA=SERVAAD
! Local controllers & user services inhibited initially
EXTERNALINTEGER KERNELQ=0, RUNQ1=0, RUNQ2=0
RECORDFORMAT PROCF(STRING (6) USER, C
BYTEINTEGER INCAR,CATEGORY, WSN, RUNQ, ACTIVE, C
INTEGER ACTW0, LSTAD, LAMTX, STACK, STATUS)
OWNRECORD (PROCF)ARRAYFORMAT PROCAF(0:MAXPROCS)
OWNRECORD (PROCF)ARRAYNAME PROCA
IF MONLEVEL&2#0 THEN START
EXTERNALLONGINTEGERSPEC KMON
FINISH
EXTERNALSTRING (15) FNSPEC STRINT(INTEGER N)
EXTERNALSTRING (8) FNSPEC STRHEX(INTEGER N)
EXTERNALSTRING (8) FNSPEC HTOS(INTEGER VALUE,PLACES)
EXTERNALROUTINESPEC PKMONREC(STRING (20)TEXT,RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC OPMESS(STRING (63) S)
ROUTINESPEC MONITOR(STRING (63) S)
EXTERNALROUTINESPEC DUMP TABLE(INTEGER T, A, L)
ROUTINESPEC ELAPSED INT(RECORD (PARMF)NAME P)
SYSTEMROUTINESPEC MOVE(INTEGER L,F,T)
SYSTEMROUTINESPEC ETOI(INTEGER A, L)
ROUTINESPEC PDISC(RECORD (PARMF)NAME P)
EXTERNALROUTINESPEC HOOT(INTEGER NHOOTS)
EXTERNALROUTINESPEC WAIT(INTEGER MSECS)
EXTERNALINTEGERFNSPEC HANDKEYS
EXTERNALINTEGERFNSPEC REALISE(INTEGER PUBVIRTADDR)
EXTERNALROUTINESPEC SLAVESONOFF(INTEGER ONOFF)
EXTERNALINTEGERFNSPEC SAFE IS READ(INTEGER ISAD,INTEGERNAME VAL)
EXTERNALINTEGERFNSPEC SAFE IS WRITE(INTEGER ISAD,INTEGER VAL)
IF MULTIOCP=YES THEN START
EXTERNALROUTINESPEC RESERVE LOG
EXTERNALROUTINESPEC RELEASE LOG
FINISH
!-----------------------------------------------------------------------
ROUTINE PUTONQ(INTEGER SERVICE)
RECORD (PROCF)NAME PROC
RECORD (SERVF)NAME SERV, SERVQ
INTEGERNAME RUNQ
SERV==SERVA(SERVICE)
IF LOCSN0<SERVICE<=LOCSN1 THEN START
PROC==PROCA(SERVICE-LOCSN0)
IF PROC_RUNQ=1 C
THEN RUNQ==RUNQ1 ELSE RUNQ==RUNQ2
IF RUNQ=0 THEN SERV_L=SERVICE ELSE START
SERVQ==SERVA(RUNQ)
SERV_L=SERVQ_L
SERVQ_L=SERVICE
FINISH
RUNQ=SERVICE UNLESS PROC_STATUS&3#0 AND RUNQ#0
! priority procs on front
FINISH ELSE START
IF KERNELQ=0 THEN SERV_L=SERVICE ELSE START
SERVQ==SERVA(KERNELQ)
SERV_L=SERVQ_L
SERVQ_L=SERVICE
FINISH
KERNELQ=SERVICE
FINISH
END
!-----------------------------------------------------------------------
EXTERNALINTEGERFN PPINIT(INTEGERFN NEW EPAGE)
CONSTINTEGER INIT EPAGES=SERVASIZE//(EPAGESIZE*1024)+1
INTEGERARRAY REALADS(0:INIT EPAGES)
INTEGER I, J, K, CELLS, VI
LONGINTEGER L
*LSQ_(LNB +5)
*ST_GETNEWPAGE; ! store away FN param
PROCA==ARRAY(COM_PROCAAD,PROCAF)
FOR J=INIT EPAGES,-1,0 CYCLE
I=NEW EPAGE
REALADS(J)=I
REPEAT
VI=X'80000000'!(I+X'01000000')
IF MAXPROCS#COM_MAXPROCS OR EPAGESIZE#COM_EPAGESIZE C
OR STORE0AD#COM_STOREAAD THEN C
PRINTSTRING("Incompatable components!!!
")
L=PARMPTSIZE*8-1
L=X'4110000080000001'!L<<39!I
IF MULTIOCP=YES THEN L=L!NONSLAVED;! non slaved in duals
! page table at beginning of PPSEG
LONG INTEGER(PSTVA+8*PPSEG)=L
FOR I=0,1,INIT EPAGES CYCLE
K=REALADS(I)
FOR J=0,1,EPAGESIZE-1 CYCLE
INTEGER(VI+4*J+EPAGESIZE*4*I)=X'80000001'+K+1024*J
REPEAT
REPEAT
PARMDOPE_CURRMAX=1024*EPAGESIZE*(INITEPAGES+1) C
-PARMPTSIZE*4-SERVASIZE
PARMDOPE_MAXMAX=1024*PARMPTSIZE-PARMPTSIZE*4-SERVASIZE
CELLS=PARMDOPE_CURRMAX//PCELLSIZE-1; ! no of cells now avaiable
PARMDOPE_FIRSTUNALLOC=CELLS-MARGIN+1
PARMDOPE_LAST UNALLOC=CELLS
PARMDOPE_NEXTPAGE=EPAGESIZE*(INIT EPAGES+1)
CELLS=CELLS-MARGIN; ! margin of "MARGIN" cells for trying
! to obtain further epage
FOR I=1,1,CELLS-1 CYCLE
PARM(I)_LINK=I+1
REPEAT
PARM(CELLS)_LINK=1
PARMASL=CELLS
J=PARM0AD
I=PARMDOPE_CURRMAX!X'18000000'
PARMDES=LONGINTEGER(ADDR(I)); ! descrptr to PP area
RESULT =PARM0AD
END
!-----------------------------------------------------------------------
EXTERNALROUTINE SEMALOOP(INTEGERNAME SEMA,INTEGER PARM)
!***********************************************************************
!* Loop till a sema comes free. MAXCOUNT is large enough so that *
!* it is only invoked when another OCP has gone down holding a sema *
!* PARM = 0 - INCT done before call & release is by TDEC *
!* = 1 - no INCT before call & release is by TDEC *
!* = 2 - sema release is by ST -1 so no TDECs to be done *
!***********************************************************************
CONSTINTEGER MAXCOUNT=5; ! instructions per cycle
EXTERNALLONGINTEGER SEMATIME=0
INTEGER I,J,K
IF PARM=0 START ; *TDEC_(SEMA); FINISH
FOR K=1,1,4 CYCLE
*LSS_(5); *ST_J
FOR I=1,1,COM_INSPERSEC*(500//MAXCOUNT) CYCLE
*INCT_(SEMA)
*JCC_7,<ON>
IF MONLEVEL&4#0 THEN START
*LSS_(5); *IRSB_J
*IMYD_1; *IAD_SEMATIME; *ST_SEMATIME
FINISH
RETURN
ON: UNLESS PARM>1 START ; *TDEC_(SEMA); FINISH
REPEAT
SEMA=-1; ! free before messge-may be IOCP
! sema that is held !
IF MULTI OCP=YES START
*LSS_(3); *USH_-26
*AND_3; *ST_I; ! OCP port
PRINTSTRING("Sema forced free at ". C
STRHEX(ADDR(SEMA))." (OCP".STRINT(I).")
")
FINISH ELSE PRINTSTRING("Sema forced free at ". C
STRHEX(ADDR(SEMA))."
")
REPEAT
END
!-----------------------------------------------------------------------
ROUTINE MORE PPSPACE
!***********************************************************************
!* Called when PARM ASL is empty and attemps to grab a free epage *
!* and use to extend the (paged) parameter passing area *
!* if no page available it tries to use one of the small no of cells*
!* not formatted into the original list. This gives us a fair *
!* chance of finding a free epage before disaster strikes *
!***********************************************************************
INTEGER I, J, REALAD, PTAD, CELLS, FIRST, CMAX
LONGLONGREAL X
*LSS_(3); *ST_I; ! are we in system error routine
! ie system error ints masked
IF I&1#0 THEN ->TRY MARGIN; ! if so do not try to get page
CMAX=PARMDOPE_CURRMAX
IF CMAX>=PARMDOPE_MAXMAX THEN ->FAIL
X=GET NEW PAGE; ! 4 word RT parameter !!
*PRCL_4
*LD_X
*LXN_X+12
*RALN_5
*CALL_(DR )
*ST_I; ! 0 if no page avaialbe
IF I=-1 THEN ->TRY MARGIN
REALAD=I!X'80000001'
PTAD=X'80000000'!PPSEG<<18+4*PARMDOPE_NEXTPAGE
!
! Extend PARM area by 1 epage by adding entries into page table
!
!
FOR I=0,1,EPAGESIZE-1 CYCLE
INTEGER(PTAD+4*I)=REALAD+1024*I
REPEAT
!
! Adjust param area descriptor and format up new bit of parmlist
!
CMAX=CMAX+EPAGESIZE*1024
PARMDOPE_CURRMAX=CMAX
CELLS=CMAX//PCELLSIZE-1
FIRST=PARMDOPE_FIRST UNALLOC
PARMDOPE_FIRST UNALLOC=CELLS-MARGIN+1
PARMDOPE_LAST UNALLOC=CELLS
PARMDOPE_NEXTPAGE=PARMDOPE_NEXTPAGE+EPAGESIZE
CELLS=CELLS-MARGIN
FOR I=FIRST,1,CELLS-1 CYCLE
PARM(I)_LINK=I+1
REPEAT
PARM(CELLS)_LINK=FIRST
PARMASL=CELLS
INTEGER(ADDR(PARMDES))=X'18000000'!CMAX
RETURN
TRY MARGIN:
!
! No epage available just now, use one of margin cells
!
I=PARMDOPE_FIRST UNALLOC
IF I>PARMDOPE_LAST UNALLOC THEN ->FAIL
PARMDOPE_FIRST UNALLOC=I+1
PARM(I)_LINK=I
PARMASL=I
RETURN
FAIL:
MONITOR("PARM ASL empty")
END
!-----------------------------------------------------------------------
EXTERNALROUTINE PON(RECORD (PARMF)NAME P)
RECORD (SERVF)NAME SERV,SERVQ
RECORD (PARMXF)NAME ACELL, SCELL, NCELL
INTEGER SERVICE, NEWCELL, SERVP, I
SERVICE=P_DEST>>16
IF MONLEVEL&2#0 AND (SERVICE>MAXSERV OR SERVICE=0)C
THEN PKMONREC("Invalid PON:",P) AND RETURN
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<PSEMAGOT>
SEMALOOP(MAINQSEMA,0)
PSEMAGOT:
FINISH
IF PARMASL=0 THEN MORE PPSPACE
ACELL==PARM(PARMASL); ! ACELL =ASL HEADCELL
NEWCELL=ACELL_LINK
NCELL==PARM(NEWCELL); ! NCELL mapped onto NEWCELL
IF NEWCELL=PARMASL THEN PARMASL=0 C
ELSE ACELL_LINK=NCELL_LINK
NCELL<-P; ! copy parameters in
SERV==SERVA(SERVICE)
SERVP=SERV_P&X'3FFFFFFF'
IF SERVP=0 THEN NCELL_LINK=NEWCELL ELSE START
SCELL==PARM(SERVP)
NCELL_LINK=SCELL_LINK
SCELL_LINK=NEWCELL
FINISH
I=SERV_P&X'C0000000'
SERV_P=I!NEWCELL
IF I=0 AND SERV_L=0 START ; ! q if not xecuting or inhbtd
IF SERVICE>=LOCSN0 THEN PUTONQ(SERVICE) ELSE START
IF KERNELQ=0 THEN SERV_L=SERVICE ELSE START
SERVQ==SERVA(KERNELQ)
SERV_L=SERVQ_L
SERVQ_L=SERVICE
FINISH
KERNELQ=SERVICE
FINISH
FINISH
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
!-----------------------------------------------------------------------
EXTERNALROUTINE FASTPON(INTEGER CELL)
!***********************************************************************
!* Can be used when record already in param table to avoid copy *
!* cell is no of entry in PARM holding the record *
!***********************************************************************
INTEGER SERVICE, SERVP, I
RECORD (SERVF)NAME SERV,SERVQ
RECORD (PARMXF)NAME CCELL, SCELL
CCELL==PARM(CELL)
SERVICE=CCELL_DEST>>16
SERV==SERVA(SERVICE)
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<SSEMAGOT>
SEMALOOP(MAINQSEMA,0)
SSEMAGOT:
FINISH
SERVP=SERV_P&X'3FFFFFFF'
IF SERVP=0 THEN CCELL_LINK=CELL ELSE START
SCELL==PARM(SERVP)
CCELL_LINK=SCELL_LINK
SCELL_LINK=CELL
FINISH
I=SERV_P&X'C0000000'
SERV_P=I!CELL
IF I=0 AND SERV_L=0 THEN START
IF SERVICE>=LOCSN0 THEN PUTONQ(SERVICE) ELSE START
IF KERNELQ=0 THEN SERV_L=SERVICE ELSE START
SERVQ==SERVA(KERNELQ)
SERV_L=SERVQ_L
SERVQ_L=SERVICE
FINISH
KERNELQ=SERVICE
FINISH
FINISH
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
!-----------------------------------------------------------------------
EXTERNALROUTINE DPON(RECORD (PARMF)NAME P, INTEGER DELAY)
!***********************************************************************
!* As for PON except for a delay of "DELAY" seconds. Zero delays *
!* are allowed. ELAPSED INT is used to kick DPONPUTONQ *
!***********************************************************************
RECORD (PARMF) POUT
RECORD (PARMXF)NAME ACELL, NCELL
INTEGER SERVICE, NEWCELL
SERVICE=P_DEST>>16
IF MONLEVEL&2#0 AND SERVICE>MAXSERV C
THEN PKMONREC("Invalid DPON:",P) AND WRITE(DELAY,4) C
AND RETURN
IF DELAY<=0 THEN PON(P) AND RETURN
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<PSEMAGOT>
SEMALOOP(MAINQSEMA,0)
PSEMAGOT:
FINISH
IF PARMASL=0 THEN MORE PPSPACE
ACELL==PARM(PARMASL)
NEWCELL=ACELL_LINK
NCELL==PARM(NEWCELL); ! onto cell in freelist
IF NEWCELL=PARMASL THEN PARMASL=0 C
ELSE ACELL_LINK=NCELL_LINK
NCELL<-P
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
POUT_DEST=X'A0002'
POUT_SRCE=0
POUT_P1=X'C0000'!NEWCELL
POUT_P2=DELAY
PON(POUT)
END
!-----------------------------------------------------------------------
EXTERNALROUTINE DPONPUTONQ(RECORD (PARMF)NAME P)
!***********************************************************************
!* Scond part of DPON. The delay has elapsed and P_DACT has the *
!* number of a PPCELL set up ready for fastponning *
!***********************************************************************
IF MONLEVEL&2#0 AND KMON&1<<12#0 THEN C
PKMONREC("DPONPUTONQ:",P)
FASTPON(P_DEST&X'FFFF')
END
!-----------------------------------------------------------------------
EXTERNALINTEGERFN NEWPPCELL
!***********************************************************************
!* Provide a PP cell for use elsewhere than in PON-POFF area *
!***********************************************************************
INTEGER NEWCELL
RECORD (PARMXF)NAME ACELL
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<PSEMAGOT>
SEMALOOP(MAINQSEMA,0)
PSEMAGOT:
FINISH
IF PARMASL=0 THEN MORE PPSPACE
ACELL==PARM(PARMASL)
NEWCELL=ACELL_LINK
IF NEWCELL=PARMASL THEN PARMASL=0 C
ELSE ACELL_LINK=PARM(NEWCELL)_LINK
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
RESULT =NEWCELL
END
!-----------------------------------------------------------------------
!%EXTERNALROUTINE POFF(%RECORD(PARMF)%NAME P)
!!***********************************************************************
!!* Remove a set of paramaters from their queue and copy them *
!!* into the parameter record. The service no is in P_DEST and an *
!!* empty or inhibited queue is notified by returning a zero P_DEST *
!!***********************************************************************
!%RECORD(SERVF)%NAME SERV
!%RECORD(PARMXF)%NAME ACELL, CCELL, SCELL
!%INTEGER SERVICE, CELL, SERVP
! SERVICE=P_DEST>>16
! %IF MONLEVEL&2#0 %AND(SERVICE<0 %OR SERVICE>MAXSERV) %C
! %THEN PKMONREC("Invalid POFF:",P) %AND P_DEST=0 %AND %RETURN
! %IF MULTIOCP=YES %THEN %START
! *INCT_MAINQSEMA
! *JCC_8,<SSEMAGOT>
! SEMALOOP(MAINQSEMA,0)
!SSEMAGOT:
! %FINISH
! SERV==SERVA(SERVICE)
! SERVP=SERV_P
! %IF SERVP<=0 %START
! P_DEST=0
! %IF MULTI OCP=YES; !*TDEC_MAINQSEMA !%FINISH
! %RETURN
! %FINISH
! SCELL==PARM(SERVP)
! CELL=SCELL_LINK
! CCELL==PARM(CELL)
! P<-CCELL; ! copy parameters out
! %IF CELL=SERV_P %THEN SERV_P=0 %ELSE SCELL_LINK=CCELL_LINK
! %IF PARMASL=0 %THEN CCELL_LINK=CELL %ELSE %START
! ACELL==PARM(PARMASL)
! CCELL_LINK=ACELL_LINK
! ACELL_LINK=CELL
! %FINISH
! PARMASL=CELL
! %IF MULTIOCP=YES %START; !*TDEC_MAINQSEMA; !%FINISH
!%END
!-----------------------------------------------------------------------
EXTERNALROUTINE SUPPOFF(RECORD (SERVF)NAME SERV,RECORD (PARMF)NAME P)
!***********************************************************************
!* A more efficient POFF for supervisor *
!* assumes vital checks have been done *
!***********************************************************************
CONSTLONGINTEGER PARMDR=X'1800002400000000'+PARM0AD
CONSTLONGINTEGER LINKDR=X'2B00000900000020';! WORD UNSC BCI
RECORD (PARMXF)NAME ACELL, CCELL, SCELL
INTEGER CELL, SERVP
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<PSEMAGOT>
SEMALOOP(MAINQSEMA,0)
PSEMAGOT:
FINISH
! SERVP=SERV_P&X'3FFFFFFF'
! SCELL==PARM(SERVP)
! CELL=SCELL_LINK
! CCELL==PARM(CELL)
! P<-CCELL
*LCT_SERV+4; *LSS_(CTB +0)
*AND_X'3FFFFFFF'; *ST_SERVP; ! SERVP=SERV_P&X'3FFFFFFF'
*IMY_X'24'; *IAD_PARM0AD
*ST_SCELL+4; ! SCELL==PARM(SERVP)
*LD_LINKDR; *LSS_(DR +SCELL+4)
*ST_B ; ! CELL=SCELL_LINK
*IMYD_X'24'; *IAD_PARMDR
*ST_CCELL; ! CCELL==PARM(CELL)
*SLD_P; *MV_L =32; ! P<-CCELL
! %IF CELL=SERVP %THEN SERV_P=SERV_P&X'C0000000' %C
ELSE SCELL_LINK=CCELL_LINK
*LD_TOS
*CPB_SERVP; *JCC_7,8
*LSS_(CTB +0); *NEQ_SERVP
*ST_(CTB +0); ! SERV_P=SERV_P&X'C0000000'
*J_5
*LSS_(DR +CCELL+4)
*ST_(DR +SCELL+4); ! SCELL_LINK=CCELL+LINK
! %IF PARMASL=0 %THEN CCELL_LINK=CELL %ELSE %START
! ACELL==PARM(PARMASL)
! CCELL_LINK=ACELL_LINK
! ACELL_LINK=CELL
! %FINISH
! PARMASL=CELL
*LSS_PARMASL; *JAF_4,5; ! USES XNB!
*STB_(DR +CCELL+4); *J_11; ! CCELL_LINK=CELL
*IMY_X'24'; *IAD_PARM0AD
*ST_ACELL+4; ! ACELL==PARM(PARMASL)
*LSS_(DR +ACELL+4); *ST_(DR +CCELL+4);! CCELL_LINK=ACELL_LINK
*STB_(DR +ACELL+4); ! ACELL_LINK=CELL
*STB_PARMASL
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
!-----------------------------------------------------------------------
EXTERNALROUTINE RETURN PPCELL(INTEGER CELL)
!***********************************************************************
!* Returns a cell suplied for other purposes via NEWPPCELL *
!***********************************************************************
RECORD (PARMXF)NAME ACELL, CCELL
CCELL==PARM(CELL)
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<PSEMAGOT>
SEMALOOP(MAINQSEMA,0)
PSEMAGOT:
FINISH
IF PARMASL=0 THEN CCELL_LINK=CELL ELSE START
ACELL==PARM(PARMASL)
CCELL_LINK=ACELL_LINK
ACELL_LINK=CELL
FINISH
PARMASL=CELL
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
!-----------------------------------------------------------------------
EXTERNALROUTINE INHIBIT(INTEGER SERVICE)
!***********************************************************************
!* Inhibit a service by setting top bit in SERV_P *
!***********************************************************************
RECORD (SERVF)NAME SERV
IF MONLEVEL&2#0 AND (SERVICE<0 OR SERVICE>MAXSERV) C
THEN PRINT STRING("Invalid INHIBIT: ".STRINT(SERVICE)."
") AND RETURN
SERV==SERVA(SERVICE)
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<SSEMAGOT>
SEMALOOP(MAINQSEMA,0)
SSEMAGOT:
FINISH
SERV_P=SERV_P!X'80000000'
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
!-----------------------------------------------------------------------
EXTERNALROUTINE UNINHIBIT(INTEGER SERVICE)
!***********************************************************************
!* Uninhibit a service by unsetting top bit in P_SERV and adding *
!* any service calls to appropiate queue *
!***********************************************************************
RECORD (SERVF)NAME SERV
IF MONLEVEL&2#0 AND (SERVICE<0 OR SERVICE>MAXSERV) C
THEN PRINT STRING("Invalid UNINHIBIT: ".STRINT(SERVICE)."
") AND RETURN
SERV==SERVA(SERVICE)
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<SSEMAGOT>
SEMALOOP(MAINQSEMA,0)
SSEMAGOT:
FINISH
SERV_P=SERV_P&X'7FFFFFFF'
IF SERV_L=0 AND 0<SERV_P<X'FFFF' THEN PUTONQ(SERVICE)
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
EXTERNALROUTINE PINH(INTEGER PROCESS,MASK)
!***********************************************************************
!* Inhibit a group of services for a process with one claiming *
!* of the relevant sema. Needed for duals. *
!* Mask controls:- 2**0 set = inhibit processes LOCSN0 *
!* 2**1 set = inhibit processes LOCSN1 etc *
!***********************************************************************
RECORD (SERVF)NAME SERV
INTEGER I,SERVICE
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<GOT>
SEMALOOP(MAINQSEMA,0)
GOT:
FINISH
FOR I=0,1,3 CYCLE
IF MASK&(1<<I)#0 START
SERVICE=PROCESS+LOCSN0+I*MAXPROCS
SERV==SERVA(SERVICE)
SERV_P=SERV_P!X'80000000'
FINISH
REPEAT
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
EXTERNALROUTINE PUNINH(INTEGER PROCESS,MASK)
!***********************************************************************
!* Uninhibit service for a process. The converse of PINH(q.v) *
!***********************************************************************
RECORD (SERVF)NAME SERV
INTEGER I,SERVICE
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<GOT>
SEMALOOP(MAINQSEMA,0)
GOT:
FINISH
FOR I=0,1,3 CYCLE
IF MASK&(1<<I)#0 START
SERVICE=PROCESS+LOCSN0+I*MAXPROCS
SERV==SERVA(SERVICE)
SERV_P=SERV_P&X'7FFFFFFF'
IF SERV_L=0 AND 0<SERV_P<X'FFFF' THEN PUT ON Q (SERVICE)
FINISH
REPEAT
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
!-----------------------------------------------------------------------
EXTERNALROUTINE CLEAR PARMS(INTEGER SERVICE)
!***********************************************************************
!* Throw away all cells queuing for service en block *
!* also print discarded cells for information *
!***********************************************************************
RECORD (SERVF)NAME SERV
INTEGER CELL, SERVP
SERV==SERVA(SERVICE)
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<SSEMAGOT>
SEMALOOP(MAINQSEMA,0)
SSEMAGOT:
FINISH
SERVP=SERV_P&X'3FFFFFFF'
IF SERVP=0 START
IF MULTI OCP=YES START ; *TDEC_MAINQSEMA; FINISH
RETURN
FINISH
IF MONLEVEL&2#0 THEN START
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH ; ! dont hold during o-p
CELL=SERVP
UNTIL CELL=SERVP CYCLE
CELL=PARM(CELL)_LINK
PKMONREC("PARM cleared:",PARM(CELL))
REPEAT
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<SSEMAGOT2>
SEMALOOP(MAINQSEMA,0)
SSEMAGOT2:
FINISH
FINISH
SERV_P=SERV_P&X'C0000000'
IF PARMASL#0 THEN CELL=PARM(SERVP)_LINK C
AND PARM(SERVP)_LINK=PARM(PARMASL)_LINK C
AND PARM(PARMASL)_LINK=CELL
PARMASL=SERVP
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
END
!-----------------------------------------------------------------------
IF SSERIES=NO START ; ! not S series protem
ROUTINE HAMMING(INTEGER ONOFF)
!***********************************************************************
!* On 2960 &2970 can turn off hamming reporting in OCP or SMAC *
!* on 2980 can only do it in SMAC. This routine cycles round *
!* all the SMACs setting & usetting right bit(different on 2972&76) *
!***********************************************************************
INTEGER I,J,K,SMAC
FOR SMAC=0,1,15 CYCLE
IF 1<<SMAC&COM_SMACS#0 START ; ! this SMAC exists
J=COM_SESR!SMAC<<COM_SMACPOS
I=COM_HOFFBIT
K=¬I
I=I&ONOFF
*LB_J
*LSS_(0+B )
*AND_K
*OR_I
*ST_(0+B )
FINISH
REPEAT
END
FINISH
OWNINTEGER STORE RETRY COUNT=0, WAIT COUNT=1, RFLAGS=0, ERRORS OFF=X'C02'
OWNSTRING (23) REPORT SE=""
IF SSERIES=YES START
OWNINTEGERARRAY OCP RETRY COUNT(0:3)
CONSTINTEGER OCP MASK=X'400'
FINISH ELSE START
OWNINTEGERARRAY OCP RETRY COUNT(2:3)
OWNINTEGER SAC0 RETRY COUNT,SAC1 RETRY COUNT
CONSTINTEGER OCP MASK=X'100'
FINISH
EXTERNALROUTINE TURN ON ER(RECORD (PARMF)NAME P)
!***********************************************************************
!* Turns on error reporting after time lapse *
!***********************************************************************
INTEGER I, J, MYPORT
IF SSERIES=YES START
CONSTSTRING (9)ARRAY OMESS(0:3)="No OCPs","OCP0","OCP1","Both OCPS"
RECORD (PARMF) Q
FINISH ELSE START
CONSTSTRING (9)ARRAY OMESS(0:3)="No OCPs","OCP2","OCP3","Both OCPS";
CONSTSTRING (9)ARRAY SMESS(1:3)="SAC0","SAC1","Both SACS"
FINISH
CONSTINTEGER LAPSED MINS=20
!
! In duals in is difficult to clear the inh photot bit since it
! is set in the failing OCP but se goes to the good OCP
! so clear it here as a precaution
!
UNLESS REPORT SE="" START ; ! SCU/SAC/DCU syserr to report
OPMESS(REPORT SE)
REPORT SE=""
FINISH
IF SSERIES=NO AND BASIC PTYPE=4 START
*LSS_(X'4012'); *AND_X'FEFFFFFF'; *ST_(X'4012')
FINISH
IF RFLAGS#0 START
IF RFLAGS&1#0 THEN OPMESS("Retry:-no dump in SSN+1")
IF RFLAGS&4#0 THEN OPMESS("Unrecovered H-W errors")
IF RFLAGS&2#0 THEN START
OPMESS("Hamming reporting off")
WAIT COUNT=10*LAPSED MINS
ERRORS OFF=ERRORS OFF!2
FINISH
IF SSERIES=NO AND RFLAGS&X'18'#0 START ; ! one or both SACs off
OPMESS("Reporting off ".SMESS(RFLAGS>>3&3))
WAITCOUNT=10*LAPSED MINS
ERRORS OFF=ERRORS OFF!RFLAGS&X'18'
FINISH
IF RFLAGS&X'C00'#0 START ; ! one or both OCPs off
IF SSERIES=YES START ; ! reporting always on
OPMESS("Recovered H-W errors")
OCP RETRY COUNT(0)=0
OCP RETRY COUNT(1)=0
FINISH ELSE START
OPMESS("Reporting off ".OMESS(RFLAGS>>10&3))
WAITCOUNT=10*LAPSED MINS
ERRORS OFF=ERRORS OFF!RFLAGS&X'C00'
FINISH
FINISH
RFLAGS=0
FINISH
IF WAITCOUNT#0 THEN START
IF P_DEST&15=1 THEN WAITCOUNT=WAITCOUNT-1 C
ELSE WAITCOUNT=0
IF WAITCOUNT=0 START
IF SSERIES=NO AND ERRORS OFF&2#0 START ; ! turn hamming on
OPMESS("Hamming reporting on")
STORE RETRY COUNT=0
HAMMING(0)
ERRORS OFF=ERRORS OFF&(¬2)
FINISH
IF SSERIES=NO AND ERRORS OFF&X'18'#0 START ; ! turn SAC reporting back on
OPMESS("Reporting on ".SMESS(ERRORS OFF>>3&3))
IF ERRORS OFF&8#0 THEN SAC0 RETRY COUNT=0
IF ERRORS OFF&X'10'#0 THEN SAC1 RETRY COUNT=0
ERRORS OFF=ERRORS OFF&(¬X'18')
FINISH
*LSS_(3); *USH_-26
*AND_3; *ST_MYPORT
IF ERRORS OFF&(OCP MASK<<MYPORT)#0 START
OPMESS("Reporting on OCP".TOSTRING(MYPORT+'0'))
OCP RETRY COUNT(MYPORT)=0
I=COM_INHSSR
J=I>>16; I=I&X'FFFF'
J=J!!(-1)
*LB_I; *LSS_(0+B )
*AND_J; *ST_(0+B )
IF MULTIOCP=YES AND COM_NOCPS>1 START
ERRORS OFF=ERRORS OFF!!(OCP MASK<<MYPORT)
IF ERRORS OFF#0 THEN WAITCOUNT=1
FINISH ELSE ERRORS OFF=0
ELSE
IF ERRORS OFF & (OCP MASK<<(MYPORT!!1)) # 0 THEN WAITCOUNT=1
FINISH
FINISH
FINISH
END
EXTERNALROUTINE ELAPSED INT(RECORD (PARMF)NAME P)
!**********************************************************************
!* *
!* ELAPSED INTERVAL TIMER *
!* *
!* Act 0 = call from RTC interrupt handler (currently once per sec) *
!* ACT 1 = Q/unQ nominee for kick every n seconds *
!* ACT 2 = Q nominee for once-off kick in n seconds *
!* *
!* Where : P_P1 is routine to be kicked *
!* : P_P2 is (a) seconds to elapse before kick (0<P_P2<X8000) *
!* or (b) unQ nominee (P_P2 = -1,act 1 only) *
!* : P_P3 is parameter returned to kicked routine in P_P1 *
!***********************************************************************
ROUTINESPEC QUEUE
ROUTINESPEC UNQUEUE(INTEGER N)
INTEGERFNSPEC SLOT(INTEGER N)
RECORDFORMAT QF(INTEGER DEST,KLOKTIKS,PARM,PROCNO,STRING (7)USER, C
INTEGER P5,P6,LINK)
RECORD (QF)NAME Q
SWITCH ACT(0:2)
INTEGER I, SRCE, PROCNO
INTEGERNAME HEAD
HEAD==COM_ELAP HEAD
SRCE=P_SRCE
I=P_DEST&X'FFFF'
IF MONLEVEL&2#0 AND 1<<10&KMON# 0 THEN C
PKMONREC("ELAPSED INT:",P)
->ACT(I) IF 0<=I<=2
IF MONLEVEL&2#0 AND I>2 THEN C
PKMONREC("ELAPSED INT rejects:",P)
RETURN
ACT(0): ! RTC interrupt
P_SRCE=P_DEST
I=HEAD
WHILE I>0 CYCLE
Q==PARM(I)
I=Q_LINK
IF Q_DEST#0 START
Q_KLOKTIKS=Q_KLOKTIKS-1
IF Q_KLOKTIKS&X'FFFF'=0 START
P_DEST=Q_DEST
P_P1=Q_PARM
!
! Check user process has not logged off and if so cancel request
!
PROCNO=Q_PROCNO
IF PROCNO=0 OR Q_USER=PROCA(PROCNO)_USER THEN C
PON(P) ELSE Q_KLOKTIKS=0
IF Q_KLOKTIKS=0 THEN UNQUEUE(Q_DEST) C
ELSE Q_KLOKTIKS=Q_KLOKTIKS!Q_KLOKTIKS>>16
FINISH
FINISH
REPEAT
RETURN
ACT(1): ! request timer interrupt
IF P_P2<0 THEN UNQUEUE(P_P1) AND RETURN
ACT(2): ! one time only
RETURN IF X'7FFF'<P_P2<1
IF I=1 THEN P_P2=P_P2<<16+P_P2
QUEUE
RETURN
ROUTINE QUEUE
INTEGER CELL,PROCNO
CELL=SLOT(P_P1)
UNLESS CELL=0 START ; ! already Q'd
IF I=2 START ; ! ok if once-off
Q==PARM(CELL); ! update parms
Q_KLOKTIKS=P_P2
Q_PARM=P_P3
FINISH
RETURN
FINISH
CELL=NEWPPCELL
Q==PARM(CELL)
Q_P6=0
Q_LINK=HEAD
PARM(HEAD)_P6=CELL
HEAD=CELL
Q_DEST=P_P1
Q_KLOKTIKS=P_P2
Q_PARM=P_P3
PROCNO=P_P1>>16-LOCSN0
IF PROCNO<0 THEN PROCNO=0 ELSE PROCNO=PROCNO&(MAXPROCS-1)
Q_PROCNO=PROCNO
Q_USER=PROCA(PROCNO)_USER IF PROCNO>0
END
ROUTINE UNQUEUE(INTEGER N)
INTEGER I
RECORD (QF)NAME Q
I=SLOT(N)
RETURN IF I=0; ! not Q'd
Q==PARM(I)
IF Q_P6=0 THEN HEAD=Q_LINK ELSE PARM(Q_P6)_LINK=Q_LINK
IF Q_LINK#0 THEN PARM(Q_LINK)_P6=Q_P6
RETURN PPCELL(I)
END
INTEGERFN SLOT(INTEGER DEST)
INTEGER I, J
I=HEAD
WHILE I>0 CYCLE
Q==PARM(I)
RESULT =I IF Q_DEST=DEST
I=Q_LINK
REPEAT
RESULT =0
END
END
IF MULTIOCP=YES START
EXTERNALROUTINE HALT OTHER OCP
!***********************************************************************
!* Halt other OCP whilst this OCP does SYSERR recovery etc. *
!***********************************************************************
INTEGER I,J,HISPORT
*LSS_(3); *USH_-26
*AND_3; *NEQ_1
*ST_HISPORT
IF SSERIES=YES START
IF HISPORT=COM_OCPPORT0 THEN J=COM_OCP0 SCU PORT C
ELSE J=COM_OCP1 SCU PORT
J=J<<22
I=X'40086016'!J
*LB_I; *LSS_X'2988DEAF'; *ST_(0+B )
*LB_X'601D'; *LSS_(16); *USH_-24; *USH_22; *ST_(0+B ); ! cross reporting off
I=X'400C601D'!J
*LB_I; *LSS_J; *ST_(0+B )
FINISH ELSE START
IF BASIC PTYPE<=3 THEN START
*LSS_0; *ST_(X'6009'); ! suppress BSE
I=X'42086011'!HISPORT<<20
*LB_I; *LSS_X'80010000'
*ST_(0+B ); ! clear slaves and suspend
FINISH ELSE START
I=X'42000004'!HISPORT<<20
*LB_I; *LSS_4; ! ACC value for record inwd 9
*ST_(0+B ); ! suspend
*LSS_(X'4013'); *AND_X'FFFF7FFB'; *ST_(X'4013'); ! clear MULT & DD
FINISH
FINISH
END
INTEGERFN GET BSEIP(INTEGER FPN)
!***********************************************************************
!* After a broadcast sytem error this gets the parameter *
!* from the failing OCP *
!***********************************************************************
INTEGER I
IF SSERIES=NO START
IF BASIC PTYPE<=3 START ; ! 2960S & 70S
I=X'42086301'!FPN<<20
*LB_I; *LSS_(0+B ); ! get parameter
*ST_I
*ADB_1; *LSS_(0+B ); ! clear out int
RESULT =I
FINISH
I=X'42000003'!FPN<<20
*LB_I; *LSS_(0+B )
*EXIT_-64
FINISH
END
ROUTINE SEND MPINT TO SELF(INTEGER MYPORT)
!***********************************************************************
!* Used after a broadcast catastrophic error to single up *
!***********************************************************************
INTEGER I
IF SSERIES=YES START
*LSS_(16); *USH_-24; *ST_MYPORT; ! SCU port
I=X'40046016'!MYPORT<<22
*LB_I; *LSS_X'2988D0D0'; *ST_(0+B )
FINISH ELSE START
IF BASIC PTYPE<=3 START
I=(MYPORT!!1)<<20!X'420C6009'
*LB_I
*LSS_0; *ST_(0+B ); ! clear his bcast error bit
! also mpint to me
FINISH ELSE START
*LSS_(X'4012'); *OR_X'200'
*ST_(X'4012'); ! set mpis bit
FINISH
FINISH
END
EXTERNALROUTINE RESTART OTHER OCP(INTEGER PARAM)
!***********************************************************************
!* PARAM=0 this OCP will continue also *
!* PARAM=1 this OCP will stop(IDLE_DEAD) tell other OCP via mp int *
!* that it is now on its own as a single system *
!* PARAM=2 (SSERIES only) tell other OCP via SGSE to recover DCU1s *
!* & (optionally) transfer DCU1 control to this OCP *
!***********************************************************************
INTEGER I,HISPORT
*LSS_(3); *USH_-26
*AND_3; *NEQ_1; *ST_HISPORT
IF SSERIES=YES START
IF HISPORT=COM_OCPPORT0 THEN HISPORT=COM_OCP0 SCU PORT C
ELSE HISPORT=COM_OCP1 SCU PORT
HISPORT=HISPORT<<22
IF PARAM=0 START ; ! reset cross reporting
I=X'400C601D'!HISPORT
*LB_I; *LSS_(16); *USH_-24; *USH_22; *ST_(0+B )
*LB_X'601D'; *LSS_HISPORT; *ST_(0+B )
FINISH
I=X'40006016'!HISPORT
*LB_I; *LSS_X'2988A0CA'; *ST_(0+B ); ! restart
IF PARAM#0 START ; ! send mp int
I=X'40046011'!HISPORT
IF PARAM=2 THEN I=I!X'20000';! or SGSE
*LB_I; *LSS_(0+B )
FINISH
FINISH ELSE START
IF BASIC PTYPE<=3 THEN START
I=X'42016011'!HISPORT<<20!PARAM<<18
*LB_I; *LSS_X'80010000'
*ST_(0+B ); ! clear slaves&continue
! gives mp int if param=1
IF PARAM=0 START
*LSS_1; *ST_(X'6009'); ! reset bcast se ints
FINISH
FINISH ELSE START
*LSS_(X'4013'); *OR_X'8004'; *ST_(X'4013'); ! reset MULT & DD
I=X'42000005'!HISPORT<<20
*LB_I; *LSS_5; ! ACC for wd9 in dumps only
*ST_(0+B ); ! restart
IF PARAM#0 START
*LSS_(X'4012')
*OR_X'100'
*ST_(X'4012'); ! send mp int to him
FINISH
FINISH
FINISH
END
INTEGERFN OTHER OCP CHECK(INTEGER MYPORT)
!***********************************************************************
!* Check IPC for timeout: usually means that the other OCP has stopped *
!***********************************************************************
INTEGER I,ISAD
I=MYPORT!!1
IF SSERIES=YES START
IF I=COM_OCPPORT0 THEN I=COM_OCP0 SCU PORT C
ELSE I=COM_OCP1 SCU PORT
ISAD=X'400C6016'!I<<22
I=X'2988A0CA'
FINISH ELSE START
IF BASIC PTYPE<=3 START
ISAD=X'42016011'!I<<20
I=X'80010000'
FINISH ELSE START
ISAD=X'42000000'!I<<20
I=0
FINISH
FINISH
RESULT =SAFE IS WRITE(ISAD,I)
END
EXTERNALROUTINE CHECK OTHER OCP
!***********************************************************************
!* Report & configure off incommunicado OCP *
!***********************************************************************
INTEGER I,MYPORT
*LSS_(3); *USH_-26; *AND_3; *ST_MYPORT
I=OTHER OCP CHECK(MYPORT)
UNLESS I=0 START
OPMESS("OCP".STRINT(MYPORT!!1)." stopped???".TOSTRING(17))
SEND MPINT TO SELF(MYPORT)
FINISH
END
EXTERNALROUTINE CLOCK TO THIS OCP
!***********************************************************************
!* Establish clock control in this OCP *
!***********************************************************************
INTEGER I,J,K,MY OCP PORT
LONGINTEGER WORK
IF SSERIES=NO AND BASIC PTYPE=4 AND 5<=COM_OCPTYPE<=6 START
! 2972 and 2976 change port in clock IS regs
*LSS_(3); *USH_-26; *AND_3; *ST_MY OCP PORT
K=MY OCP PORT<<20
COM_CLKX=COM_CLKX&X'FF0FFFFF'!K
COM_CLKY=COM_CLKY&X'FF0FFFFF'!K
COM_CLKZ=COM_CLKZ&X'FF0FFFFF'!K
K=X'80000000'>>MY OCP PORT
*LSS_(X'4012'); *OR_K; *ST_(X'4012');! open clock int path
K=MY OCP PORT<<20
*LSS_(X'4013'); *AND_X'FFFFF'; *OR_K; *ST_(X'4013')
FINISH
!
! Set & start clock in this OCP (except for 2980 which has clock in SAC)
!
IF SSERIES=YES OR COM_OCPTYPE#4 START
WORK=LENGTHENI(COM_TOJDAY)*86400+(COM_SECSFRMN+2)
WORK=WORK*1000000
*LSD_WORK; *USH_-1; *STUH_B ; *ST_J
K=COM_CLKX
*LB_K; *LSS_WORK; *ST_(0+B )
K=COM_CLKY
*LB_K; *LSS_J; *ST_(0+B )
K=COM_CLKZ
*LB_K; *LSS_13; *ST_(0+B )
FINISH ELSE START ; ! 2980
I=X'80000000'>>COM_SACPORT0
*LSS_(X'4012'); *OR_I; *ST_(X'4012')
FINISH
IF SSERIES=YES START
*LSS_(16); *USH_-24; *ST_(X'600F')
FINISH ELSE IF BASIC PTYPE<=3 START
*LSS_(3); *USH_-26; *AND_3; *ST_(X'600F')
FINISH
END
FINISH
IF SSERIES=YES START
EXTERNALINTEGER DCU RFLAG=0
EXTERNALROUTINE DCU1 RECOVERY(INTEGER PARAM)
!***********************************************************************
!* PARAM=0 this OCP is about to crash or be configured out so direct *
!* DCU1 interrupts to the other OCP *
!* PARAM=-1 called to recover all DCU1s leaving control with this OCP *
!* PARAM=n called to recover DCU1 n leaving control with this OCP *
!***********************************************************************
EXTERNALINTEGERFNSPEC PINT
INTEGERARRAY SSNP1(0:17)
LONGINTEGER L
INTEGER I,J,K
INTEGER SSNP1AD,SCU PORT,OTHER SCU PORT,AWORDA,HWNO,INTS,FMN,CAA
*STLN_J
SSNP1AD=J>>18<<18+1<<18; ! SSN+1
FOR I=0,1,17 CYCLE ; ! save SSN+1
SSNP1(I)=INTEGER(SSNP1AD+4*I); ! lest PINT overwrites it
REPEAT
*LSS_(16); *USH_-24; *ST_SCU PORT
IF SCU PORT=COM_OCP0 SCU PORT THEN OTHER SCU PORT=COM_OCP1 SCU PORT C
ELSE OTHER SCU PORT=COM_OCP0 SCU PORT
FOR I=1,1,INTEGER(COM_DCUCONFA) CYCLE
K=INTEGER(COM_DCUCONFA+4*I)
HWNO=K>>8&255
IF K>>24#0 AND (PARAM=HWNO OR PARAM<=0) START
FMN=K&255
CAA=X'80000000'!((K>>16)&255)<<18
AWORDA=INTEGER(CAA)
*LB_AWORDA; *LSD_X'080000000'; *ST_(0+B )
! send external flag - abandons I/O & enters primitive state
INTS=0
WAIT(100)
FOR J=1,1,100 CYCLE
K=PINT; ! take peripheral int.
EXIT IF K=0
IF K>>24=HWNO THEN INTS=INTS+1; ! interrupt for this DCU1
EXIT IF INTS>1; ! max 2 outstanding
! outstanding I/Os recovered by normal timeout mechanism
REPEAT
J=X'20000010'!FMN<<22
*LB_J; *LSS_X'00200000'; *ST_(0+B ); ! isolate CC
IF PARAM=0 THEN K=OTHER SCU PORT ELSE K=SCU PORT
J=X'20000011'!FMN<<22
*LB_J; *LSS_K; *USH_16; *ST_(0+B )
J=X'20000010'!FMN<<22
*LB_J; *LSS_X'00180000'; *ST_(0+B ); ! reset & de-isolate
WAIT(10)
J=REALISE(CAA)
L=LENGTHENI(J+32)<<32!J!X'080000001'
*LSD_L; *LB_AWORDA; *ADB_X'20'; *ST_(0+B );! reset stream area base
WAIT(10)
*LB_AWORDA; *LSD_X'013000000'; *ST_(0+B ); ! restart DCU1 control program
WAIT(10)
! GDC to reconnect streams later
UNLESS PARAM<=0 THEN DCU RFLAG=PARAM AND EXIT
DCU RFLAG=-1
FINISH
REPEAT
FOR I=0,1,17 CYCLE ; ! restore SSN+1
INTEGER(SSNP1AD+4*I)=SSNP1(I)
REPEAT
END
FINISH
EXTERNALROUTINE MONITOR(STRING (63)S)
INTEGER I
IF MULTIOCP=YES AND COM_NOCPS>1 THEN HALT OTHER OCP
*LSS_(3); *OR_1; *ST_(3); ! mask se int as for se
! this is for IOCP & PRINT
PRINTSTRING(S)
MONITOR
STOP
END
EXTERNALROUTINE STOP ALIAS "S#STOP"
INTEGER I, W0, W1, W2, W3, W4, W5
CONSTINTEGER RESTACK=X'80180000'
CONSTINTEGER SEG10=X'80280000'; ! for commcn with dump routine
CONSTINTEGER LCSTACK=0
*STSF_I
W1=I>>18<<18
UNLESS W1<0 OR W1=LCSTACK START
*OUT_28; ! can happen
FINISH
IF MULTIOCP=YES AND COM_NOCPS>1 THEN HALT OTHER OCP
I=COM_LSTL
*LB_I; *LSS_(0+B ); *ST_W2
I=COM_LSTB
*LB_I; *LSS_(0+B ); *ST_W3
*LSS_(3)
*ST_W0
W0=-(W0>>26&3); ! dummy syserr
! = - OCP port no. for duals
*LXN_SEG10
*LSQ_(XNB +0)
*ST_(XNB +10) ; ! syserr to oldse bit
*LSQ_W0
*ST_(XNB +0)
!
! Now if supervisor stop seg 10 is set up as if we have had a dummy
! system error. A tape dump will then look ok to the dump analyser
!
IF SSERIES=YES AND MULTI OCP=YES AND COM_NOCPS>1 START
*LSS_(3); *USH_-26; *AND_3; *ST_I
UNLESS I=COM_OCPPORT0 START ; ! other OCP has DCU1s
I=X'40000000'!COM_OCP0 SCU PORT<<22!X'6014'
*LB_I; *LSS_X'80'; *ST_(0+B ); ! so remote activate into 'RESTART'
CYCLE ; *IDLE_X'F0F0'; REPEAT
FINISH
FINISH
HOOT(15)
W4=0; W5=RESTACK
*ACT_W2; ! dump to tape via RESTART
CYCLE ; *IDLE_X'DEAD'; REPEAT
END ; ! STOP
EXTERNALROUTINE SYSERR(INTEGER STK, IP)
!***********************************************************************
!* Called after recovered and unrecovered system errors *
!* IP=sytem error interupt parameter. STACK =interupted SSN *
!***********************************************************************
ROUTINESPEC PRINT PHOTO
ROUTINESPEC RESUME(INTEGER MODE)
IF SSERIES=YES START
CONSTSTRING (19)ARRAY FCODE(0:3)="SOFTWARE ERROR",
"IRRECOVERABLE ERROR","OCP LOGGING INT.","RECOVERABLE ERROR"
OWNBYTEINTEGERARRAY DEPTH(0:31)=0(*)
OWNINTEGER SGSE FLAG=0
LONGINTEGER L
INTEGER EFLAG,DCU2 FLAG
FINISH ELSE START
ROUTINESPEC RECONSTRUCT P4REGS
ROUTINESPEC STORE ERROR(INTEGER FC)
CONSTSTRING (19)ARRAY FCODE(0:4)="SOFTWARE ERROR",
"IRRECOVERABLE ERROR","SUCCESSFUL RETRY","UNSUCCESSFUL RETRY",C
"SAC ERROR"
CONSTSTRING (7)ARRAY CONT(0:3)="NOTHING"," SFC "," FPC2 "," GPC ";
CONSTINTEGER MIN SAC PORT=0,MAX SAC PORT=1
INTEGER SACREG,TRUNK,CONTYPE,REGPHOTO OFFSET
OWNBYTEINTEGERARRAY DEPTH(0:3)=0(*)
FINISH
SWITCH FAILURE(0:3)
INTEGER I, J, K, FSTK, FC, FPN, ACT0, ACT1, ACT2, ACT3, C
PHOTOAD, REGAD, OCPTYPE, MYPORT, CHECK
CONSTINTEGER ERR COUNT=8
STRING (12)BCAST
INTEGERNAME RETRY COUNT
CONSTINTEGER UNDUMPSEG=X'80280000',LCSTACK=0,RESTACK=X'80180000'
IF SSERIES=YES THEN FPN=IP&X'3F' ELSE FPN=IP>>29
->RECURSIVE IF DEPTH(FPN)#0
DEPTH(FPN)=1
OCPTYPE=COM_OCPTYPE; ! referenced often so put in local
*LSS_(3); *USH_-26
*AND_3; *ST_MYPORT
! bits 2-5 now relevant? (see PSD 2.5.1)
FSTK=STK
BCAST=""
CHECK=0
IF MULTIOCP=YES AND COM_NOCPS>1 THEN START
IF SSERIES=YES START
! if error is cross reported get failing stack from other OCP
IF FPN=COM_OCP0 SCU PORT OR FPN=COM_OCP1 SCU PORT START
*LSS_(16); *USH_-24; *ST_I; ! my SCU port
UNLESS I=FPN START
I=X'400C0000'!FPN<<22
*LB_I; *LSS_(0+B ); *ST_FSTK; ! his LNB
FSTK=FSTK>>18<<18
BCAST=" X reported "
FINISH
FINISH
IF BCAST="" THEN CHECK=OTHER OCP CHECK(MYPORT)
IF CHECK=0 THEN HALT OTHER OCP
FINISH ELSE START
IF FPN=MYPORT!!1 START ; ! SE has been broadcast
IP=GET BSEIP(FPN)
BCAST=" Broadcast "
FINISH ELSE START
UNLESS MIN SAC PORT<=FPN<=MAX SAC PORT C
THEN CHECK=OTHER OCP CHECK(MYPORT)
!
! sac failure will still be pending. can not try to check other OCP
! since the sac error will cause safe is op to fail
!
IF CHECK=0 THEN HALT OTHER OCP
FINISH
FINISH
FINISH
!
! 2980 has different failure code to 2970&2960. Transpose FC to 70 mode
!
! for S series: 0=S/W, 1=H/W, 2=logging, 3=H/W recoverable
!
FC=IP>>27&3
IF SSERIES=NO START
IF BASIC PTYPE=4 THEN FC=(X'1320'>>(4*FC))&15
SACREG=0
TRUNK=0
FINISH
I=COM_LSTL
*LB_I ; *LSS_(0+B )
*ST_ACT0
I=COM_LSTB
*LB_I ; *LSS_(0+B )
*ST_ACT1
ACT2=0
ACT3=STK
IF SSERIES=NO AND MIN SAC PORT<=FPN<=MAX SAC PORT START
IF ERRORS OFF&(8<<FPN)#0 START ; ! reporting off
I=X'44000000'!FPN<<20; ! read & clear syserr
*LB_I; *ADB_X'200'
*LSS_(0+B )
RESUME(2)
FINISH
K=4
FINISH ELSE K=FC
NEWLINE
PRINT STRING( C
"SYSTEM ERROR INTERRUPT OCCURRED ".DATE." ".TIME)
IF MULTI OCP=YES AND CHECK#0 START
PRINTSTRING("
(OCP".STRINT(MYPORT!!1)." STOPPED??? (".STRHEX(CHECK)."))")
FINISH
PRINTSTRING("
PARAMETER ".STRHEX(IP).BCAST."
FAILING PORT NUMBER ".STRINT(FPN)."
".FCODE(K)."
ACR LEVEL ".STRINT(IP>>20&15))
IF SSERIES=YES START
PRINTSTRING("
OLD STACK=".STRHEX(FSTK))
I=MYPORT
IF MULTI OCP=YES AND BCAST#"" THEN I=I!!1
I=INTEGER(X'8000017C'+I<<18)
FINISH ELSE START
PRINTSTRING("
OLD STACK=".STRHEX(FSTK))
I=INTEGER(X'8000017C'+FPN<<18)
FINISH
IF I>0 THEN PRINTSTRING(" USER=".PROCA(I)_USER)
NEWLINE
!
! Work out if there was a dump in SSN+1 and/or a photo. Ip is different
! for different members of the range. When there is no dump in SSN+1
! try to obtain regs from photo so diagnostics are sensible.
!
REGAD=-1; PHOTOAD=-1
IF SSERIES=YES OR BASIC PTYPE<=3 START ; ! S series or P2/P3
IF IP&X'20000'=0 AND (SSERIES=YES OR BCAST="") THEN REGAD=STK+X'40000'
IF IP&X'40000'=0 START
IF SSERIES=YES START
I=MYPORT
IF BCAST#"" THEN I=I!!1; ! photo in failing OCP
PHOTOAD=X'81000100'+X'100'*I
FINISH ELSE START
PHOTOAD=X'81000100'
IF BASIC PTYPE=2 THEN REGPHOTOOFFSET=X'30' ELSE REGPHOTOOFFSET=X'300'
FINISH
! NB P3 has photo in SMAC1 option
! but EMAS does not enable it so
! can forget it. P2 hasnt option
FINISH
IF SSERIES=NO AND BASIC PTYPE#2 AND FPN=3 AND PHOTOAD#-1 THEN PHOTOAD=PHOTOAD+X'700'
FINISH ELSE START ; ! P4s (incl 2972 &2976)
IF IP&X'30000'=X'10000' AND BCAST="" THEN C
REGAD=STK+X'40000'
UNLESS IP&X'30000'=0 START ; ! phot with SSN dump on P4s
PHOTOAD=X'81000100'
REGPHOTO OFFSET=X'580'
IF IP&X'30000'=X'30000' THEN PHOTOAD=X'81400100'
IF COM_NOCPS>1 AND FPN=3 THEN PHOTOAD=PHOTOAD+4*X'600'
FINISH
FINISH
IF REGAD=-1 THEN PRINT STRING(" *****NO")
PRINT STRING(" DUMP IN SSN+1
")
IF PHOTOAD=-1 THEN PRINTSTRING("No photograph
") ELSE IF SSERIES=NO THEN PRINTSTRING("PHOTO SMAC".STRINT(PHOTOAD>>22&1)."
")
IF SSERIES=NO AND BASIC PTYPE=4 AND IP&X'18'=X'18' AND PHOTOAD#-1 C
THEN RECONSTRUCT P4REGS; ! system error timeout on P4's
IF SSERIES=NO AND REGAD=-1 AND PHOTOAD#-1 START
IF BCAST="" START
PRINTSTRING("SSN+1 SET UP FROM PHOTO !
")
MOVE(64,PHOTOAD+REGPHOTO OFFSET,STK+X'40000')
ELSE
J=INTEGER(PHOTOAD+REGPHOTO OFFSET);! LNB OF BCASTER
IF J<0{PUBLIC} THEN I=J>>18<<18+X'40000' ELSE START ;! LOCAL SEGMENT
J=(J>>18)+1; ! SEGNO OF BCASTERS SSN+1
K=INTEGER(PHOTOAD+X'150');! REALADDR OF SEGTABLE EX PHOTO
K=K+X'81000000'; ! VIRTAD OF SEGTABLE
I=INTEGER(K+8*J+4); ! REAL ADDR OF SSN+1
I=I&X'0FFFFFF0'+X'81000000';! PUBLIC VIRTUAL ADDR OF BCASTERS SSN+1
FINISH
printstring("SSN+1 (".strhex(i).") set up from broadcast OCP photo !
")
move(64,photoad+regphoto offset,I)
FINISH
FINISH
!
! First deal with SAC errors. All are fully recoverable provided
! the SAC sys int reg can be read and cleared. Otherwise the int
! remains pending and will screw SAFE IS OP Etc.
!
IF SSERIES=NO AND MIN SAC PORT<=FPN<=MAX SAC PORT START
I=X'44000000'!FPN<<20
*LB_I; *ADB_X'200'
*LSS_(0+B ); *ST_SACREG
PRINTSTRING("
SAC SYS INT=".STRHEX(SACREG))
IF SAFE IS READ(I,J)=0 THEN C
PRINTSTRING("
SAC PER INT=".STRHEX(J))
IF SAFE IS READ(I+X'400',J)=0 THEN C
PRINTSTRING("
SAC STATUS =".STRHEX(J))
IF SACREG>>16#0 THEN START
J=X'80000000'
FOR I=0,1,15 CYCLE
IF SACREG&J#0 THEN EXIT
J=J>>1
REPEAT
TRUNK=I
CONTYPE=BYTEINTEGER(COM_CONTYPEA+TRUNK)
PRINTSTRING("
TRUNK ".STRINT(TRUNK)." HAS ".CONT(CONTYPE)." ON IT")
I=X'40000000'!FPN<<20!TRUNK<<16
IF SAFE IS READ(I,J)=0 THEN C
PRINTSTRING("
TRUNK ADDR REG - 0XX=".STRHEX(J))
IF SAFE IS READ(I+X'800',J)=0 THEN C
PRINTSTRING("
TRUNK CONTROL REG - 8XX=".STRHEX(J))
IF SAFE IS READ(I+X'C00',J)=0 THEN C
PRINTSTRING("
TRUNK STATUS REG - CXX=".STRHEX(J))
IF SAFE IS READ(I+X'D00',J)=0 THEN C
PRINTSTRING("
TRUNK DIAG STATUS REG - DXX=".STRHEX(J)."
")
FINISH
IF SACREG&2#0 THEN STORE ERROR(0); ! bit 30 = SMAC fail
IF BASIC PTYPE=4 START ; ! engineers say print photo area
IF OCPTYPE=4 START ; ! 2980 only
PRINTSTRING("
Photograph area")
! SAC0 dump at X900, SAC1 dump at XD00 - but print everything anyway
DUMPTABLE(-1,X'81000100',X'1400')
FINISH
FINISH
IF FPN=0 THEN RETRY COUNT==SAC0 RETRY COUNT C
ELSE RETRY COUNT==SAC1 RETRY COUNT
RETRY COUNT=RETRY COUNT+1
IF RETRY COUNT>=ERR COUNT THEN RFLAGS=RFLAGS!(8<<FPN)
REPORT SE="SAC SYSERROR PT ".HTOS(FPN<<4!TRUNK,2); !report later
RESUME(2); ! will not return
FINISH ELSE IF SSERIES=YES START
EFLAG=0
IF FC>0 AND (IP>>11&X'1F'=1 OR IP>>11&X'1F'=2) START
! store/SCU transmission fail or store MBF
! DCUs left isolated so must recover them
! (also need to abandon bad store pages - recovered SBF not reported)
EFLAG=1
FINISH ELSE UNLESS FPN=COM_OCP0 SCU PORT OR C
FPN=COM_OCP1 SCU PORT THEN EFLAG=2
! must be a DCU fail so recover all DCUs
UNLESS EFLAG=0 START
PRINT PHOTO
DCU2 FLAG=0
FOR I=1,1,INTEGER(COM_DCUCONFA) CYCLE
J=INTEGER(COM_DCUCONFA+4*I)
IF J>>24=0 START ; ! DCU2
K=X'20000010'!(J&255)<<22
*LB_K; *LSS_X'00200000'; *ST_(0+B ); ! isolate
*LSS_X'00180000'; *ST_(0+B ); ! reset & de-isolate
DCU2 FLAG=1
FINISH
REPEAT
! recover DCU1s in controlling OCP
IF MULTI OCP=YES AND MYPORT#COM_OCPPORT0 START
SGSE FLAG=2
RESTART OTHER OCP(2); ! send him a syserr
*LSS_(16); *USH_-24; *ST_J
J=X'40086016'!J<<22; ! halt me
*LB_J; *LSS_X'2988DC1C'; *ST_(0+B )
! wait for him to restart me
FINISH ELSE DCU1 RECOVERY(-1)
UNLESS DCU2 FLAG=0 START ; ! DCU2
WAIT(10000); ! 10 secs for DCU2 initialise
! now go thru the unit table & reserve streams etc.
K=UT VA
CYCLE
EXIT IF INTEGER(K+64)=0; ! no more entries
INTEGER(K+16)=0; ! clear flags
L=K&X'0FFFFFFFF'!LENGTHENI(X'B0000001')<<32
*PRCL_4
*LSS_1; ! reserve stream
*SLSD_0; ! dummy TCB descriptor
*ST_TOS
*LD_L; ! descriptor to UT
*RALN_8
*CALL_(DR )
! ignore response
K=K+64; ! next UT entry
REPEAT
FINISH
IF EFLAG=1 THEN REPORT SE="SCU fail recovered" C
ELSE REPORT SE="DCU fmn ".STRINT(FPN)." recovered"
DCU RFLAG=-1; ! reconnect DCU1 streams later
FINISH
FINISH
->FAILURE(FC)
FAILURE(2): ! error recovered by h-ware
IF IP&X'20000'#0 THEN RFLAGS=RFLAGS!1
IF SSERIES=NO AND IP&X'C000'#0 THEN START
STORE ERROR(FC)
STORE RETRY COUNT=STORE RETRY COUNT+1
IF STORE RETRY COUNT>=ERR COUNT START
RFLAGS=RFLAGS!2
HAMMING(-1)
FINISH
FINISH ELSE START
UNLESS SSERIES=YES AND EFLAG#0 THEN PRINT PHOTO
IF SSERIES=YES THEN RETRY COUNT==OCP RETRY COUNT(MYPORT) C
ELSE RETRY COUNT==OCP RETRY COUNT(FPN)
RETRY COUNT=RETRY COUNT+1
IF RETRY COUNT>=ERR COUNT START
IF SSERIES=YES THEN RFLAGS=RFLAGS!OCP MASK<<MYPORT C
ELSE RFLAGS=RFLAGS!OCP MASK<<FPN
IF SSERIES=NO START
! must leave reporting on for S series for proper DCU recovery
J=COM_INHSSR
K=J>>16; J=J&X'FFFF'
*LB_J; *LSS_(0+B )
*OR_K; *ST_(0+B ); ! shut up error reporting
FINISH
FINISH
FINISH
RESUME(2); ! will not return
FAILURE(1): ! unrecoverable h-ware
IF SSERIES=NO AND IP&X'C000'#0 START ; ! hard store error
STORE ERROR(FC); ! might help engineers !
FINISH
FAILURE(3): ! retry also failed
! for S series this is a retryable H/W failure but we will just
! treat it as a failure protem
PRINT PHOTO
RESUME(1); ! does not return
FAILURE(0): ! software(may really be h-w
IF SSERIES=YES AND MULTI OCP=YES AND COM_NOCPS>1 AND C
FC=0 AND IP>>11&X'1F'=12 AND SGSE FLAG#0 START
! SGSE from other OCP is a request to recover DCU1s &
! possibly transfer control to the other OCP
! (although could be a CSE from the SCP - hence SGSE FLAG)
IF SGSE FLAG=1 START
sgse flag=0
PRINTSTRING("SGSE to switch DCU1 control
")
DCU1 RECOVERY(0)
RESTART OTHER OCP(0)
CYCLE ; *IDLE_X'F0F1'; REPEAT
FINISH ELSE START
sgse flag=0
PRINTSTRING("SGSE to recover DCU1s
")
DCU1 RECOVERY(-1)
RESTART OTHER OCP(0)
*LSS_(16); *USH_-24; *ST_J
J=X'40086016'!J<<22; ! halt me
*LB_J; *LSS_X'2988DC1D'; *ST_(0+B )
! wait for him to restart me
RESUME(2); ! & continue
FINISH
FINISH
PRINT PHOTO
IF PRODUCTION=YES OR COM_SLIPL<0 THEN RESUME(1) ELSE RESUME(0);! continue or crash
RECURSIVE:
I=X'DEADDEAD'; J=I; K=I; ! footprint for dumps
CYCLE ; *IDLE_X'DEAD'; REPEAT
ROUTINE RESUME(INTEGER MODE)
!***********************************************************************
!* MODE=0 system must crash *
!* MODE=1 unrecovered h-w fault. In duals single up *
!* in singles crash unless in user *
!* MODE=2 recovered both OCPs to run on *
!***********************************************************************
INTEGER I,J
SWITCH SW(0:2)
->SW(MODE)
SW(2): ! restart both OCPs
IF MULTIOCP=YES AND COM_NOCPS>1 START
IF CHECK=0 THEN RESTART OTHER OCP(0) ELSE C
CHECK OTHER OCP; ! configure off if dead
FINISH
DEPTH(FPN)=0
*ACT_ACT0; ! resume interrupted process
SW(1): ! OCP has had h-w error
DEPTH(FPN)=0; ! in case configured back
! after repairs by enginrs
IF MULTIOCP=YES AND CHECK=0 AND COM_NOCPS>1 START
IF SSERIES=YES START
*LSS_(16); *USH_-24; *ST_I
IF FPN=I START ; ! I have died
IF MYPORT=COM_OCPPORT0 THEN DCU1 RECOVERY(0); ! DCU1s to him
RESTART OTHER OCP(1)
CYCLE ; *IDLE_X'F0F2'; REPEAT
FINISH ELSE START ; ! he has died
IF MYPORT=COM_OCPPORT0 START ; ! I control DCU1s
SEND MPINT TO SELF(MYPORT)
*ACT_ACT0
FINISH ELSE START ; ! he has DCU1s
SGSE FLAG=1
RESTART OTHER OCP(2); ! send him a syserr
J=X'40086016'!I<<22; ! halt me
*LB_J; *LSS_X'2988DC1A'; *ST_(0+B )
!
! wait for him to restart me after
! transferring DCU1 control
!
HALT OTHER OCP
SEND MPINT TO SELF(MYPORT); ! I carry on &
*ACT_ACT0; ! he gets configured off (at last!!)
FINISH
FINISH
FINISH ELSE IF FPN=MYPORT START
RESTART OTHER OCP(1); ! yo're on your own mate!
CYCLE ; *IDLE_X'F0F3'; REPEAT
FINISH ELSE START ; ! He has died I'm ok
SEND MPINT TO SELF(MYPORT)
*ACT_ACT0
FINISH
finish else if sseries=yes and sgse flag#0 start
! if we reach here with sgse set then there has been another
! syserr during DCU recovery.
if sgse flag=1 start ; ! request was to switch DCU1 control
sgse flag=0
dcu1 recovery(0); ! last ditch attempt to keep going
restart other ocp(0)
finish
cycle ; *idle_x'f0f5'; repeat
else
!
! If the old stack was a user stack we can use OUT 28 to pass
! control to the local controller. This may keep system running
!
UNLESS STK<0 OR STK=LCSTACK START
RFLAGS=RFLAGS!4
INTEGER(STK!X'40044')=IP; ! store seip inword 17 of SSN+1
*OUT_28; ! to local controller
FINISH
FINISH
SW(0): ! crash necessary
LONGLONGREAL(UNDUMPSEG+40)=LONGLONGREAL(UNDUMPSEG)
INTEGER(UNDUMPSEG)=IP
INTEGER(UNDUMPSEG+4)=FSTK
I=INTEGER(FSTK!X'40000'); ! old LNB from SSN+1
IF SSERIES=NO AND (REGAD=-1 OR (BCAST#"" AND PHOTOAD#-1)) C
THEN I=INTEGER(PHOTOAD+REGPHOTO OFFSET)
*LSS_I
*ST_(LNB +0) ; ! to frig %MONITOR
IF MULTIOCP=YES AND BCAST#"" START ; ! must switch LST base
IF SSERIES=YES THEN I=INTEGER(X'80000000'+4*95+(MYPORT!!1)<<18) C
ELSE I=INTEGER(X'80000000'+4*95+FPN<<18);! failing proc from IST
IF I#0 START ; ! there was a process
J=PROCA(I)_LSTAD
I=COM_LSTB
*LSS_J; *LB_I; *ST_(0+B )
FINISH
FINISH
PRINTSTRING("Disaster
")
MONITOR UNLESS SSERIES=YES AND BCAST#""
IF SSERIES=YES AND MULTI OCP=YES AND COM_NOCPS>1 AND C
MYPORT#COM_OCPPORT0 START ; ! other OCP has DCU1s
IF CHECK#0 OR (BCAST#"" AND HANDKEYS=0) START
CYCLE ; *IDLE_X'DEAD'; REPEAT ; ! preserve failing OCP state in H/W dump
FINISH
I=X'40000000'!COM_OCP0 SCU PORT<<22!X'6014'
*LB_I; *LSS_X'80'; *ST_(0+B ); ! remote activate into 'RESTART'
CYCLE ; *IDLE_X'F0F4'; REPEAT
FINISH
ACT3=RESTACK
*ACT_ACT0; ! enter 'RESTART'
CYCLE ; *IDLE_X'DEAD'; REPEAT
END
IF SSERIES=NO START
ROUTINE STORE ERROR(INTEGER FC)
!***********************************************************************
!* Print out an error report for all SMACs. If recovered error *
!* read and rewrite data. Mark page as flawed by setting top *
!* bit of the real address. Page may be discarded *
!***********************************************************************
INTEGER I,J,K,STATUS,ENGSTATUS,CONFIG,AD,DR,SMAC
PRINTSTRING("
&& STORE ERROR SMAC STATUS REPORT AT ". C
STRING(ADDR(COM_TIME0)+3)." on ". C
STRING(ADDR(COM_DATE0)+3)." SEIP = ".STRHEX(IP)."
SMAC DATAREG ADDRESS STATUS ENGSTATUS CONFIGN")
FOR SMAC=0,1,15 CYCLE
IF COM_SMACS&1<<SMAC#0 START
NEWLINE; WRITE(SMAC,2)
J=COM_SDR3!SMAC<<COM_SMACPOS
*LB_J; *LSS_(0+B ); *ST_STATUS
J=COM_SESR!SMAC<<COM_SMACPOS
*LB_J; *LSS_(0+B ); *ST_ENGSTATUS
J=COM_SDR4!SMAC<<COM_SMACPOS
*LB_J; *LSS_(0+B ); *ST_CONFIG
IF BASIC PTYPE=4 AND OCPTYPE=4 START
! must be read in a different order for 2980!!
J=COM_SDR1!SMAC<<COM_SMACPOS
*LB_J; *LSS_(0+B ); *ST_DR
J=COM_SDR2!SMAC<<COM_SMACPOS
*LB_J; *LSS_(0+B ); *ST_AD
FINISH ELSE START
J=COM_SDR2!SMAC<<COM_SMACPOS
*LB_J; *LSS_(0+B ); *ST_AD
J=COM_SDR1!SMAC<<COM_SMACPOS
*LB_J; *LSS_(0+B ); *ST_DR
FINISH
PRINTSTRING(" ".STRHEX(DR)." ".STRHEX(AD)." ".STRHEX(STATUS). C
" ".STRHEX(ENGSTATUS)." ".STRHEX(CONFIG))
AD=AD&X'3FFFFFF'
IF AD#0 AND DR#0 START
!
! AD has real address of failing word . Mark page as flwed by
! setting top bit in "REALAD" field of store array
!
J=AD&(¬(1024*EPAGESIZE-1))
FOR I=0,1,COM_SEPGS-1 CYCLE
IF STORE(I)_REALAD=J THEN STORE(I)_REALAD C
=J!X'80000000' AND EXIT
REPEAT
!
! Read out and rewrite data for recovered errors only !!!
!
IF FC=2 START
AD=(AD+X'01000000')!X'80000000'
IF BASIC PTYPE=4 AND OCPTYPE=4 START
*LXN_AD
*LSQ_(XNB +0)
FINISH ELSE START
*LXN_AD
*LSD_(XNB +0)
FINISH
*ST_(XNB +0)
*ST_J; ! double/quad word at failing addrss
PRINTSTRING(" ".STRHEX(J).STRHEX(K))
IF BASIC PTYPE=4 AND OCPTYPE=4 THEN C
PRINTSTRING(STRHEX(STATUS).STRHEX(ENGSTATUS))
FINISH
FINISH
FINISH
REPEAT
NEWLINES(2)
END
ROUTINE RECONSTRUCT P4REGS
!***********************************************************************
!* After certain timeouts the registers on a P4 must be dug *
!* out of the photo as per 4.2.4G section 7.1.8 *
!***********************************************************************
RECORDFORMAT REGFORM (INTEGER LNB,PSR,PC,SSR,SF,IT,IC,CTB,C
XNB,B,DR0,DR1,ACC0,ACC1,ACC2,ACC3)
RECORD (REGFORM)NAME REGS
INTEGER B,I,J
B=PHOTOAD-X'100'; ! base address for digging
REGS==RECORD(PHOTOAD+REGPHOTOOFFSET)
!
I=INTEGER(B+4*X'C0')
STK=(I&X'7FFE0000')<<1
FSTK=STK
REGS_LNB=STK!(I&X'FFFF')<<2
REGS_PSR=REGS_PSR!INTEGER(B+4*X'52')
REGS_PC=INTEGER(B+4*X'D4')&X'FFFC0000'! C
INTEGER(B+4*X'D2')>>15<<1
REGS_SSR=INTEGER(B+4*X'54')
REGS_SF=STK!(INTEGER(B+4*X'C4')&X'FFFF')<<2
I=INTEGER(B+4*X'C6')
REGS_CTB=(I&X'7FFE0000')<<1!(I&X'FFFF')<<2
I=INTEGER(B+4*X'C2')
REGS_XNB=(I&X'7FFE0000')<<1!(I&X'FFFF')<<2
REGS_B=INTEGER(B+4*X'82')
REGS_DR0=INTEGER(B+4*X'8E')
REGS_DR1=INTEGER(B+4*X'90')
REGS_ACC0=INTEGER(B+4*X'200')
REGS_ACC1=INTEGER(B+4*X'202')
REGS_ACC2=INTEGER(B+4*X'204')
REGS_ACC3=INTEGER(B+4*X'206')
END
FINISH
ROUTINE PRINT PHOTO
!***********************************************************************
!* Prints the photograph and other bits not required *
!* in single byte error reporting *
!***********************************************************************
ROUTINESPEC DUMP SLAVES(INTEGER PHOTOAD,OCP TYPE)
IF SSERIES=YES START
CONSTSTRING (15)ARRAY SW SEMESS(0:12)= C
"Masked VS int",
"Masked PE int",
"Masked SC int",
"Masked OUT int",
"SSN is odd",
"ACS is zero",
"Nature code 6?",
"Nature code 7?",
"Illegal VS cond",
"ST format error",
"IST unavailable",
"Nature code 11?",
"Software SEI"
CONSTSTRING (15)ARRAY HW SEMESS(0:31)= C
"Rem OCP photo",
"Store/SCU fail",
"Store MBF",
"Nature code 3?",
"Nature code 4?",
"Nature code 5?",
"MIB",
"ACT Q overflow",
"Sched decode",
"Sched SPFN err",
"Sched RR err",
"Sched RTC/IT",
"Mcode detec err",
"Mcode IC err",
"Mcode PC err",
"Mcode SAD err",
"Nature code 16?",
"Clock/DCM fail",
"Engine error",
"Sched IB err",
"SAU error",
"Engine timeout",
"Mprog hamming",
"Comms fail",
"Operator entry",
"Illegal ACT",
"SAU H/W rec",
"Nature code 27?",
"UIP fail",
"Multiplier fail",
"Nature code 30?",
"SEI CR fails"
FINISH ELSE START
CONSTHALFINTEGERARRAY PHOTOL(0:6)=0,X'700',X'1440',X'700',X'1400',X'800'(2);
!
! The following arrays decode the bottom 16 bits of the system error
! parameter to text. Semess has the text: swptr&hwptr has arrays of pointers
! this technique is needed as hardware errors are nonsta äard
! ocptypes signify 2=2960,3=2970,4=2980,5=2972,6=2976
!
CONSTSTRING (15)ARRAY SEMESS(0:41)="",
"ILLEGAL VSI",
"MASKED VS INT",
"MASKED PE INT",
"MASKED SC INT",
"MASKED OUT INT",
"MASKED XCDE INT",
"SSN ERROR",
"SEG TABLE ERROR",
"SOFTWARE SE INT",
"ACTIVATE ACS=0",
"SPARE AS YET",
"STORE FAIL",
"HAMMING ERROR",
"STORE TIMEOUT",
"OCP TIMEOUT",
"ANY TIMEOUT",
"SAC TIMEOUT",
"AGU DATA ERROR",
"AGU CNTRL ERROR",
"ARU DATA ERROR",
"ARU CNTRL ERROR",
"INSTRN PARITY",
"AGU FN PARITY",
"STK SLAVE FAIL",
"INSN SLAVE FAIL",
"SMAC0 FAIL",
"TRANSLATN FAIL",
"FETCH FAIL",
"MODIFY FAIL",
"OPERAND FAIL",
"STRING FAIL",
"WRITE FAIL",
"SYSTEM TIMEOUT",
"UNDOCMTD ERROR?",
"DECODER P E",
"ENGINE ERROR",
"DATA P'TY ERROR",
"SAU ERROR",
"MPROG DET ERROR",
"DISPLMNT FAIL",
"PHOTO FAILED"
CONSTBYTEINTEGERARRAY SWSEPTR(16:25)=C
1,2,3,4,5,6,7,8,9,10; ! near enough range standard!
CONSTBYTEINTEGERARRAY HWSEPTR(2:6,16:30)=C
12, 12, 12, 12, 12,
13, 13, 26, 26, 26,
35, 14, 27, 27, 27,
38, 15, 28, 28, 28,
14, 16, 40, 40, 40,
15, 17, 24, 24, 24,
36, 18, 29, 29, 29,
37, 19, 30, 30, 30,
39, 20, 21, 21, 21,
34, 21, 31, 31, 31,
34, 22, 32, 32, 32,
34, 23, 16, 16, 16,
34, 24, 33, 33, 33,
34, 25, 35, 35, 35,
34, 34, 34, 34, 34;
FINISH
INTEGER I,J
IF SSERIES=YES START
I=IP>>11&X'1F'
IF FC=0 THEN PRINTSTRING(SW SEMESS(I)) ELSE C
PRINTSTRING(HW SEMESS(I))
NEWLINE
FINISH ELSE START
IF FC=0 THEN START ; ! SOFTWARE ERROR
FOR I=16,1,25 CYCLE
IF IP&X'80000000'>>I#0 THEN C
PRINTSTRING(SEMESS(SWSEPTR(I))) AND NEWLINE
REPEAT
FINISH ELSE START ; ! HARDWARE ERRORS
FOR I=16,1,30 CYCLE
IF IP&X'80000000'>>I#0 THEN C
PRINTSTRING(SEMESS(HWSEPTR(OCPTYPE,I))) AND NEWLINE
IF BASIC PTYPE=2 AND I=21 AND IP&X'400'#0 THEN START
IF IP&X'440'=X'400' THEN START
PRINTSTRING("(DURING IPC TO PORT")
WRITE(IP>>3&7,1)
PRINTSTRING(" )")
ELSE
PRINTSTRING("(HICCUP)")
FINISH
NEWLINE
FINISH
REPEAT
FINISH
FINISH
IF PHOTOAD=-1 THEN RETURN ; ! NO PHOTO TAKEN
UNLESS SSERIES=YES OR FC=2 OR C
(FC#0 AND CHECK=0 AND (STK>LCSTACK OR COM_NOCPS>1)) C
THEN RETURN ; ! PRINT PHOTO ONLY IS SYSTEM
! IS LIKELY TO RUN ON. OTHERWISE
! LEAVE BUFFER SPACE FOR DIAGS
! but always print S series miniphoto
PRINTSTRING("Photograph area")
IF SSERIES=YES OR (OCPTYPE=2 AND IP&X'10000'=0) THEN J=128 ELSE J=PHOTOL(OCPTYPE)
DUMP TABLE(-1,PHOTOAD,J)
DUMP SLAVES(PHOTOAD,OCP TYPE)
RETURN UNLESS SSERIES=YES OR FC=2
! uninhibit photos - except for 2960 where photodump takes yonks!
IF SSERIES=YES START
*LSS_(X'6011'); *AND_X'FFFD'; *ST_(X'6011')
FINISH ELSE IF BASIC PTYPE=3 START
*LSS_(X'6011'); *AND_X'FFFE'; *ST_(X'6011')
FINISH ELSE IF BASIC PTYPE=4 START
*LSS_(X'4012'); *AND_X'FEFFFFFF'; *ST_(X'4012')
FINISH
*LDTB_X'18000000'; *LDB_J
*LDA_PHOTOAD; *MVL_L =DR ,0,0
!
!
ROUTINE DUMP SLAVES(INTEGER START ADDR, OCP TYPE)
IF BASIC PTYPE=4 THEN START
STRING (14) FNSPEC SLAVE TITLE(INTEGER TYPE)
ROUTINESPEC DUMP BLOCK SLAVE(INTEGER TYPE)
INTEGERFNSPEC TRANSFORM(INTEGER LOCAL AD)
ROUTINESPEC PHEX CONTENTS(INTEGER FROM, LENGTH)
INTEGERNAME LW, RW
LONGINTEGER L
INTEGERARRAY STACK CAMS(0:7)
INTEGER PSTBA, LSTBA, SEG, CAMAD, CAM, LINE, START, I, J, K, FLAG
CONSTINTEGER TOP14BITS=X'FFFC0000'
CONSTINTEGER PUBLIC=X'80000000'
CONSTINTEGER RA0=X'81000000'
constinteger store fail=x'0000c000'
CONSTSTRING (2) STAR="* "
RETURN IF OCP TYPE<4; ! APPLIES TO P4'S ONLY *****
return if (fc=1 or fc=3) and ip&store fail#0
! avoid the possibility of another multi-bit fail
PSTBA=INTEGER(START ADDR+X'148')+RA0; !VA OF PSTB
LSTBA=INTEGER(START ADDR+X'150')+RA0; ! VA OF LST
I=ADDR(L)
LW==INTEGER(I)
RW==INTEGER(I+4)
! INSTRUCTION SLAVE
SEG=INTEGER(START ADDR+X'190')&TOP14BITS;! PD SEG
START=START ADDR+X'1A0'; ! FRAME 3 (CAMS)
DUMP BLOCK SLAVE(0); ! INSTRUCTION SLAVE
! STACK SLAVE
PRINTSTRING(SLAVE TITLE(2))
I=INTEGER(START ADDR+X'200')<<1; ! SSN/LNB
SEG=I&TOP14BITS
START=START ADDR; ! FRAME 0
FOR K=0,1,7 CYCLE
L=LONGINTEGER(START)>>24; ! LNWN VALIDS/CAMS
STACK CAMS(K)=RW
START=START+8
REPEAT
K=0
FOR CAM=0,1,15 CYCLE
IF CAM<8 THEN CAMAD=STACK CAMS(K)>>14 C
ELSE CAMAD=STACK CAMS(K)
CAMAD=CAMAD&X'3FFF0'!SEG
PHEX CONTENTS(CAMAD,16)
PRINTSTRING(STRHEX(CAMAD))
NEWLINE
IF CAM=7 THEN K=0 ELSE K=K+1
REPEAT
! OPERAND SLAVE
START=START ADDR+X'380'; ! FRAME 7
DUMP BLOCK SLAVE(1); ! OPERAND SLAVE
! ATU SLAVE
PRINTSTRING(SLAVE TITLE(3))
CAM=0
START=START ADDR+X'288'; ! FRAME 5 (CAMS)
WHILE CAM#16 CYCLE
K=INTEGER(START+16); ! SEGS PAGED
FOR LINE=0,1,7 CYCLE
CAM=CAM+1
CAMAD=INTEGER(START)&X'FFFFF800'
I=7-LINE
J=K>>I&1; ! SEG PAGED IF SET
IF CAMAD&PUBLIC#0 THEN SEG=PSTBA ELSE SEG=LSTBA
SEG=SEG+CAMAD>>15&X'FFF8'
PHEX CONTENTS(SEG,8); ! SEGMENT TABLE ENTRY
IF J=1 AND FLAG=0 START ;! GET PAGE TABLE ENTRIES IF SEGMENT PAGED
I=RA0+INTEGER(SEG+4)&X'FFFFFF8'+CAMAD>>8&X'3F8'
! EVEN/ODD PAIR OF PTE'S
PHEX CONTENTS(I,8); ! PAGE TABLE ENTRY
FINISH ELSE PRINTSTRING(STAR)
PRINTSTRING(STRHEX(CAMAD))
NEWLINE
START=START+8
REPEAT
IF CAM=8 THEN START=START ADDR+X'300'
! FRAME 6
REPEAT
INTEGERFN TRANSFORM(INTEGER LOCAL AD)
!***********************************************************************
!* TAKES A LOCAL ADDRESS AND CHANGES IT INTO A PUBLIC ONE *
!***********************************************************************
LONGINTEGER SEGT ENTRY
INTEGER I,PTAD,SEG,PTENTRY
I=LOCAL AD>>18<<3+LSTBA
*LDTB_X'18000008'; *LDA_I
*VAL_(LNB +1); *JCC_3,<INVALID>
SEGT ENTRY=LONG INTEGER(I)
->INVALID UNLESS SEGT ENTRY>>31&1#0;! UNLESS AVAILABLE
PTAD=SEGT ENTRY&X'0FFFFFF0'+RA0
IF SEGT ENTRY<<1>0 THEN RESULT =LOCAL AD&X'3FFFF'+PTAD
! UNPAGED SEGS
PTAD=PTAD+4*(LOCAL AD>>10&255)
*LDTB_X'18000004'; *LDA_PTAD
*VAL_(LNB +1); *JCC_3,<INVALID>
PTENTRY=INTEGER(PTAD)
->INVALID UNLESS PTENTRY<0; ! UNLESS PAGE AVAILABLE
RESULT =PTENTRY&X'0FFFFFF0'+LOCAL AD&X'3FF'+RA0
INVALID: ! PAGE NOT AVAILABLE
RESULT =0
END
ROUTINE PHEX CONTENTS(INTEGER FROM, LENGTH)
INTEGER I
IF FROM>0 THEN FROM=TRANSFORM(FROM)
->INVALID IF FROM=0
*LDTB_X'18000000'
*LDB_LENGTH
*LDA_FROM
*VAL_(LNB +1)
*JCC_3,<INVALID>
FOR I=0,4,LENGTH-4 CYCLE
PRINTSTRING(STRHEX(INTEGER(FROM+I))." ")
REPEAT
FLAG=0
RETURN
INVALID:
PRINTSTRING(STAR)
FLAG=1
END ; ! OF PHEX CONTENTS
STRING (14) FN SLAVE TITLE(INTEGER TYPE)
CONSTSTRING (12) ARRAY NAME(0:3)= C
"INST","OPER","STACK","ATU"
RESULT ="
".NAME(TYPE)." SLAVE
"
END ; ! OF SLAVE TITLE
ROUTINE DUMP BLOCK SLAVE(INTEGER TYPE)
INTEGER CAM, CAMAD, LINE, I
PRINTSTRING(SLAVE TITLE(TYPE))
FOR CAM=0,1,3<<TYPE+TYPE CYCLE
I=INTEGER(START)
IF TYPE=0 THEN CAMAD=SEG!I&X'3FFC0' ELSE CAMAD=I
FOR LINE=0,1,3 CYCLE
PHEX CONTENTS(CAMAD,16)
IF LINE=0 THEN PRINTSTRING(STRHEX(CAMAD))
CAMAD=CAMAD+16
NEWLINE
REPEAT
START=START+8
REPEAT
END ; ! OF DUMP BLOCK SLAVE
FINISH
END ; ! OF DUMP SLAVES
END
END
!-----------------------------------------------------------------------
IF SSERIES=NO START ; ! but need some sort of DCU dump
CONSTINTEGER RFB=X'400',AFB=X'800',AFA=X'100', C
CLEAR RFB AND AFA=X'500'
OWNINTEGER NORFBS=0
INTEGERFN WAIT ARFB(INTEGER PTS,RFB OR AFB,CMD)
!***********************************************************************
!* WAIT FOR RFB OR AFB ON SPECIFIED TRUNK. ARRANGE FOR TIME OUT *
!***********************************************************************
INTEGER I,Q,ISA
ISA=PTS!X'40000E00'
Q=100
AGN:
*LB_ISA
*LSS_(0+B )
*ST_I
Q=Q-1
->AGN UNLESS Q=0 OR I&RFB OR AFB#0
IF Q=0 START
IF NORFBS<25 THEN C
PRINTSTRING("NO R/AFB ".HTOS(CMD,8)." ".HTOS(I,8)."
")
NORFBS=NORFBS+1
FINISH
RESULT =I
END
ROUTINE INTO DCM(INTEGER PTS)
CONSTINTEGER WAITLOOP=100
INTEGER I,ISA,J
ISA=X'40000800'!PTS
*LB_ISA; *LSS_(0+B ); ! THIS CLEARS STOGGLE IF SET !!
*LSS_3; *LB_ISA; *ST_(0+B ); ! SUSPEND
FOR I=1,1,WAITLOOP CYCLE ; REPEAT
!
! NOW INTO DIRECT CONTROL MODE
!
ISA=X'40000D00'!PTS
*LB_ISA
*LSS_X'400'; *ST_(0+B )
ISA=X'40000800'!PTS
*LSS_3; *LB_ISA; *ST_(0+B )
ISA=X'40000E00'!PTS
FOR I=1,1,WAITLOOP CYCLE ; REPEAT
*LB_ISA; *LSS_(0+B ); *ST_I
J=0
WHILE I&RFB#0 AND J<WAITLOOP CYCLE ;! TRUNK CYCLE OUTSTANDING
*LB_ISA; *LSS_AFA; *ST_(0+B )
*LB_ISA; *LSS_(0+B ); *ST_I
J=J+1
REPEAT
END
ROUTINE OUT OF DCM(INTEGER PTS)
INTEGER ISA
ISA=X'40000E00'!PTS
*LB_ISA; *LSS_X'1E12'; *ST_(0+B )
*SBB_X'100'; ! B TO D00
*LSS_0; *ST_(0+B ); ! UNSET DCM
END
EXTERNALINTEGERFN CONTROLLER DUMP(INTEGER CONTYPE,PT)
ROUTINESPEC WRITE16(INTEGER REG)
ROUTINESPEC DWRITE16(INTEGER REGDATA)
IF SFC FITTED=YES THEN START
INTEGERFNSPEC READ32(INTEGER REG)
FINISH
INTEGERFNSPEC DREAD16(INTEGER REG)
INTEGERFNSPEC READ16(INTEGER REG)
ROUTINESPEC PRINT(INTEGER AD,N,PL)
ROUTINESPEC SEQREG(INTEGER F,S,L,SH,PL,INTEGERFN GET)
ROUTINESPEC PRINT BFUNS(INTEGER F,L)
ROUTINESPEC SQPRINT(INTEGER F,L)
ROUTINESPEC CHANGE STREAM(INTEGER STRM)
ROUTINESPEC PSTRMS(INTEGER FIRST,LAST)
INTEGERFNSPEC READSPAD(INTEGER SPAD)
CONSTSTRING (4)ARRAY CNAMES(1:3)="SFC ","DFC ","GPC ";
INTEGERARRAY DAT(0:7),ATUS(0:127)
CONSTHALFINTEGERARRAY BFUNS(0:46)=X'9180',X'9181',X'9182',X'9183',
X'91D0',X'91D1',X'91D2',X'91D3',
X'91D4',X'91D5',X'91D6',X'91D7',
X'9380',X'9388',X'9389',X'938A',
X'938B',X'938C',X'938D',X'938E',
X'938F',X'9390',0,0,
X'9740',X'9340',X'9400',X'9000',
X'9500',X'9100',X'9580',X'9180',
X'9600',X'9200',X'9640',X'9240',
X'9680',X'9280',X'96C0',X'92C0',
X'9700',X'9300',X'9780',X'9380',
X'97C0',X'93C0',X'FFFF';
CONSTINTEGERARRAY SSPAD(0:8)=X'6001',X'F810',X'3921',X'6000'(2),
X'800097C0',X'800093C0',X'3921'(2);
SWITCH SW(1:3)
STRING (4) CNAME
INTEGER I,RES,PTS,J,K,L,R388,MPLDREG,CONFUSED,RESULT
RESULT =-1 UNLESS 1<=CONTYPE<=3
RESULT=0
CNAME=CNAMES(CONTYPE)
IF MULTIOCP=YES THEN RESERVE LOG
PRINTSTRING("
&& DUMP OF ".CNAME.HTOS(PT,2)." ".DATE." ".TIME)
NEWLINE
NEWLINE
NORFBS=0
PTS=PT<<16
INTO DCM(PTS)
->SW(CONTYPE)
SW(1): ! SFC
IF SFC FITTED=YES THEN START
PRINTSTRING(" A ".HTOS(READ32(X'5000'),8)."
TINC ".HTOS(READ32(X'52E0'),8)."
TINCPAR ".HTOS(READ32(X'52E9'),8)."
REGISTERS:-
")
DAT(0)=READ16(X'5800')>>16
FOR I=1,1,127 CYCLE ; ! 64 32 BIT REGISTERS %CYCLE
! AUTOMATIC SEQUENCING
J=I&7
DAT(J)=WAITARFB(PTS,RFB,X'5800')>>16
*LSS_CLEAR RFB AND AFA; *LB_PTS
*ADB_X'40000E00'; *ST_(0+B );! SEND AFA
IF J=7 THEN PRINT(I-J,J,4)
REPEAT
SEQREG(X'9800',16,X'98F0',0,8,READ32)
SEQREG(X'9200',1,X'93FF',0,8,READ32)
->WAYOUT
FINISH
SW(2): ! DFC
PRINT BFUNS(0,21)
->WAYOUT IF NORFBS>2
NEWLINES(2)
SEQREG(X'5000',1,X'5316',16,4,DREAD16)
NEWLINES(3)
SEQREG(X'5328',1,X'59FF',16,4,DREAD16)
!
! READ OUT 256 CONTROLLER SPADS AFTER STOPPING THE CLOCK (20F 2**7 BIT)
!
PRINTSTRING("
CNTRLR SPADS
")
DWRITE16(X'A20F0080')
SEQREG(0,1,255,0,4,READSPAD)
!
! READ OUT 32 STREAM SPADS FOR FIRST 8 STREAMS
! SECOND 8 STREAMS IN X300 TO X3FF BUT I DONT KNOW HOW TO TELL
! IF DFC HAS THE EXTENDED OPTION! ANSWER FROM DFC EXPERT:-
! READ 9388 IF 2**11 BIT SET THEN N0 EXTENDED OPTION
! 9388 READ AND SAVED BY PRINT BFUNS
!
J=15; IF R388&X'800'#0 THEN J=7
FOR K=0,1,J CYCLE
PRINTSTRING("
SPADS FOR STRM")
WRITE(K,1)
NEWLINE
SEQREG(X'200'+32*K,1,X'21F'+32*K,0,4,READSPAD)
REPEAT
!
! READ OUT 2 ATUS
!
FOR I=1,1,2 CYCLE
FOR J=0,1,15 CYCLE
DWRITE16((X'A8C6'-2*(I-1))<<16!J<<12)
K=READ16(X'5886'-2*(I-1))
L=READ16(X'588E'-2*(I-1))
ATUS(16*I+J)=K&X'FFFF0000'!L>>16
REPEAT
REPEAT
PRINTSTRING("
REG ATU 1 ATU 2
")
SQPRINT(1,2)
PRINTSTRING("
LBE BUFFER
")
DWRITE16(X'A4FC0000')
FOR I=1,1,4 CYCLE
DWRITE16(X'A4D80000')
DWRITE16(X'A4C10000')
REPEAT
FOR I=0,1,3 CYCLE
DWRITE16(X'A4CE0000')
FOR J=0,1,7 CYCLE
DWRITE16(X'A40C0080')
DAT(J)=READ16(X'54D4')>>16
REPEAT
PRINT(8*I,7,4)
DWRITE16(X'A40C0080')
DWRITE16(X'A4C90000')
REPEAT
DWRITE16(X'A1080000'); ! WRITE INDIRECT TO REG 108
! ZEROS TO CLEAR SYSERR
IF CONFUSED#0 THEN START
DWRITE16(X'A10E0000')
DWRITE16(X'A1230000')
DWRITE16(X'A1800000')
DWRITE16(X'A1810000')
DWRITE16(X'A1820000')
DWRITE16(X'A1830000')
DWRITE16(X'A1D70000')
! MPLDREG=0; ! enginerrs say trust the hardwarre bit
FINISH
DWRITE16(X'A378FFFF'); ! CLEAR SYS ERRORS
! REGISTERED IN PROGRAM CONTROLL
RESULT=MPLDREG
IF MPLDREG&X'0080'=0 THEN DWRITE16(X'A10F0000')
->WAYOUT
SW(3): ! GPC
PRINT BFUNS(24,46)
NEWLINE
SEQREG(X'5000',1,X'503F',16,4,READ16)
SEQREG(X'5430',1,X'5433',16,4,READ16)
->WAYOUT UNLESS NORFBS=0; ! LITTLE POINT IN CONTINUING
FOR I=1,1,3 CYCLE
J=READ16(X'5039')>>16
IF J&7=6 THEN EXIT ; ! GPC IN DIAGNOSTIC STATE
PRINTSTRING("REG039=".HTOS(J,4)."
")
WRITE16(X'3921'); ! TRY TO STEP IT INTO NEXT STATE
REPEAT
RES=0
FOR I=0,1,15 CYCLE
CHANGE STREAM(I)
FOR J=0,1,15 CYCLE ; ! 15 REGS FOR EACH STRM
FOR K=0,1,8 CYCLE
L=SSPAD(K)
IF L=X'F810'THEN L=L+J
IF L<0 THEN RES=RES<<16!READ16(L)>>16 ELSE WRITE16(L)
REPEAT
ATUS(16*(I&7)+J)=RES
REPEAT
PSTRMS(I-7,I) IF I&7=7
REPEAT
WAYOUT:
PRINTSTRING("
".CNAME."DUMP ENDS
")
IF MULTIOCP=YES THEN RELEASE LOG
OUT OF DCM(PTS)
RESULT =RESULT
ROUTINE PSTRMS(INTEGER FIRST,LAST)
INTEGER I
PRINTSTRING("
SPAD")
FOR I=FIRST,1,LAST CYCLE
IF I#15 THEN START
PRINTSTRING(" STREAM")
WRITE(I,2)
FINISHELSE PRINTSTRING("CONTROLLER")
REPEAT
NEWLINE
SQPRINT(FIRST,LAST)
END
ROUTINE CHANGE STREAM(INTEGER STRM)
INTEGER I,J,NR
!***********************************************************************
!* CHANGE FROM ONE GPC STREAM TO ANOTHER BEFORE READING SPADS *
!***********************************************************************
CONSTHALFINTEGERARRAY W(0:12)=X'6001',X'4860',X'3921',X'6000'(3),
0,X'A000',X'3921'(3),X'3923',X'3921';
NR=NORFBS
FOR I=0,1,12 CYCLE
J=W(I)
IF J=0 THEN J=STRM
WRITE16(J)
REPEAT
UNLESS NR=NORFBS THEN START
PRINTSTRING("FAILED TO CHANGE TO STRM")
WRITE(STRM,2); NEWLINE
FINISH
END
INTEGERFN READSPAD(INTEGER SPAD)
INTEGER I
DWRITE16(X'62470000'!SPAD); ! WRITE DIRECT THE SPAD NO TO R247
DWRITE16(X'A3600000'); ! WRITE INDIRECT
I=READ16(X'5246')
RESULT =I>>16
END
ROUTINE PRINT(INTEGER AD,N,PL)
INTEGER I,SAME
SAME=0
N=N-1 AND SAME='Z' WHILE N>=0 AND DAT(N)=0
RETURN IF N<0
PRINTSTRING(HTOS(AD,4))
IF SAME=0 START
WHILE N>0 AND DAT(N)=DAT(N-1) CYCLE
SAME='*'
N=N-1
REPEAT
FINISH
FOR I=0,1,N CYCLE
SPACE
PRINTSTRING(HTOS(DAT(I),PL))
REPEAT
PRINTSYMBOL(SAME) IF SAME#0
NEWLINE
END
ROUTINE WRITE16(INTEGER REG)
INTEGER ISA,I,Q
ISA=X'40000E00'!PTS
I=REG<<16!X'E80'
*LB_ISA; *LSS_I
*ST_(0+B )
Q=WAIT ARFB(PTS,AFB,REG)
END
ROUTINE DWRITE16(INTEGER REGDATA)
!***********************************************************************
!* SENDS A WRITE COMMAND (IN TO 16 BITS OF PARAM) AND AFTER AFB *
!* FOLLOW UP WITH THE DATA (BOTTOM 16 BITS). *
!***********************************************************************
WRITE16(REGDATA>>16)
WRITE16(REGDATA)
END
INTEGERFN DREAD16(INTEGER REG)
!***********************************************************************
!* SPECIAL FOR DFC. SEND DIRECT AND INDIRECT READ AND 'OR' DATA *
!* TOGETHER. SAVES WORRYING IF LOCATION DIRECTLY OR INDIRECTLY *
!* ADDRESSED. WRONG FORM (PRESUMABLY!) RETURNS ZERO. *
!***********************************************************************
INTEGER ISA,I,J,K
ISA=X'40000E00'!PTS
I=REG<<16!X'E80'
*LB_ISA; *LSS_I
*ST_(0+B )
J=WAIT ARFB(PTS,RFB,REG)
*LSS_AFA; *LB_ISA; *ST_(0+B ); ! SEND AFA
I=I!!X'C0000000'
*LB_ISA; *LSS_I; *ST_(0+B )
K=WAIT ARFB(PTS,RFB,REG)
*LSS_AFA; *LB_ISA; *ST_(0+B ); ! SEND AFA
J=J!(K&X'FFFF0000')
IF REG=X'510E' THEN CONFUSED=j>>16
IF REG=X'510F' THEN MPLDREG=J>>16
RESULT =J
END
INTEGERFN READ16(INTEGER REG)
INTEGER ISA,I
ISA=X'40000E00'!PTS
I=REG<<16!X'E80'
*LB_ISA; *LSS_I
*ST_(0+B )
I=WAIT ARFB(PTS,RFB,REG)
*LSS_AFA; *LB_ISA; *ST_(0+B ); ! SEND AFA
RESULT =I
END
IF SFC FITTED=YES THEN START
INTEGERFN READ32(INTEGER REG)
!***********************************************************************
!* SPECIAL FOR SFC. SEND READ COLLECT 32 BITS IN 2 PARTS *
!***********************************************************************
INTEGER I,J,ISA
ISA=X'40000E00'!PTS
I=REG<<16!X'E80'
*LB_ISA; *LSS_I; *ST_(0+B )
I=WAIT ARFB(PTS,RFB,REG)
*LSS_CLEAR RFB AND AFA; *LB_ISA; *ST_(0+B ); ! SEND AFA
J=WAIT ARFB(PTS,RFB,REG)
*LSS_AFA; *LB_ISA; *ST_(0+B ); ! SEND AFA
RESULT =J>>16!(I&X'FFFF0000')
END
FINISH
ROUTINE PRINT BFUNS(INTEGER FIRST,LAST)
INTEGER I,J,K
FOR I=FIRST,1,LAST CYCLE
J=BFUNS(I)
K=READ16(J)>>16!J<<16
PRINTSTRING(HTOS(K,8))
IF J=X'9388' THEN R388=K; ! SAVE DFC CONFIGN FOR LATER
IF I&7=7 THEN NEWLINE ELSE SPACE
REPEAT
END
ROUTINE SQPRINT(INTEGER FIRST,LAST)
!***********************************************************************
!* PRINTS PARTS OF ATU ARRAY IN A SQUARE GRID FORMAT *
!***********************************************************************
INTEGER I,J
FOR J=0,1,15 CYCLE
WRITE(J,2)
FOR I=FIRST,1,LAST CYCLE
SPACES(2)
PRINTSTRING(HTOS(ATUS(16*(I&7)+J),8))
REPEAT
NEWLINE
REPEAT
END
ROUTINE SEQREG(INTEGER FIRST,STEP,LAST,SHFT,PL, C
INTEGERFN GET(INTEGER I))
!***********************************************************************
!* READ A SEQENCE OF REGISTER AND PRINT THEM . FN GET OBTAINS REG *
!* SHIFT AND PL CONCERN MANIPULATING AND PRINTING RESULT *
!***********************************************************************
INTEGER COUNT,SAVE,I
COUNT=0
FOR I=FIRST,STEP,LAST CYCLE
IF COUNT=0 THEN SAVE=I
DAT(COUNT)=GET(I)>>SHFT
IF COUNT=7 OR I=LAST THEN C
PRINT(SAVE,COUNT,PL) AND COUNT=-1
COUNT=COUNT+1
REPEAT
END
END
FINISH
OWNLONGINTEGER VSN=X'4641535420563435';! M'FAST V45'
CONSTINTEGER REAL0ADDR=X'81000000'
IF SSERIES=YES START
EXTERNALROUTINESPEC GDC(RECORD (PARMF)NAME P)
RECORDFORMAT DDTFORM(INTEGER C
SER, DSSMM, PROPADDR, STICK, CAA, GCCB AD, C
BYTE INTEGER LAST ATTN, DACTAD, HALF INTEGER HALFSPARE, C
INTEGER LAST TCB ADDR, C
STATE,IW1,CONCOUNT, SENSE1, SENSE2, SENSE3, SENSE4, C
REPSNO, BASE, ID, DLVN, MNEMONIC, C
STRING (6) LAB, BYTE INTEGER HWCODE, C
INTEGER ENTSIZE, X1,X2,LOGMASK, UASTE, C
UA SIZE, UA AD, TIMEOUT,PROPS,STATS1,STATS2, C
BYTEINTEGER QSTATE,PRIO,SP1,SP2, C
INTEGER LQLINK,UQLINK,CURCYL,SEMA,TRLINK,SLOT)
RECORDFORMAT TCBF(INTEGER CMD,STE,DATA LEN,DATA AD,NEXT TCB,RESP, C
(BYTEINTEGER INIT MECH,INIT CMASK,INIT SMASK,INIT MODE,INIT FN,INIT SEG, C
HALFINTEGER INIT CYL,BYTEINTEGER INIT HEAD,INIT HDLIMIT, C
HALFINTEGER INIT SCYL,INIT SHEAD,BYTEINTEGER INIT SECT,INIT OFFSET C
OR INTEGER PRE0,PRE1,PRE2,PRE3), C
INTEGER POST0,POST1,POST2,POST3,POST4,POST5,POST6,POST7)
CONSTINTEGER DCU ERR=X'00410000'; ! pseudo CDE from DCU
CONSTINTEGER DCU SNO=X'300000'
CONSTINTEGER HOLD=X'0100'
CONSTINTEGER MAX TRANS=13; ! + 1 for sense
CONSTINTEGER TCB SIZE=4*18
FINISH ELSE START
RECORDFORMAT DDTFORM(INTEGER SER, PTS, PROPADDR, STICK, CAA, C
RQA, LBA, ALA, STATE, IW1, CONCOUNT, SENSE1, SENSE2, SENSE3, C
SENSE4, REPSNO, BASE, ID, DLVN, MNEMONIC, C
STRING (6) LAB, BYTEINTEGER MECH, INTEGER PROPS, C
STATS1,STATS2,BYTEINTEGER QSTATE,PRIO,SP1,SP2,INTEGER LQLINK, C
UQLINK,CURCYL,SEMA,TRLINK,CHISA)
RECORDFORMAT CCAFORM(INTEGER MARK,PAW,PIW1,PIW2,CSAW1,CSAW2,C
CRESP1,CRESP2,LONGLONGREALARRAY STRMS(0:15))
RECORDFORMAT RQBFORM(INTEGER LSEGPROP, LSEGADDR, LBPROP, C
LBADDR, ALPROP, ALADDR, W6, W7, W8)
OWNINTEGER AUTOLD=0
OWNBYTEINTEGERARRAY PTCA(0:31); ! max=port 1, trunk f
OWNBYTEINTEGERARRAY PTBASE(0:31)=255(32)
CONSTINTEGER MAX DFCS=4; ! max DFCs coped with
OWNBYTEINTEGERARRAY SLOTX(0:16*MAXDFCS)=0(*)
CONSTINTEGER HOLD=X'0800'
FINISH
!*
RECORDFORMAT PROPFORM(INTEGER TRACKS, CYLS, PPERTRK, BLKSIZE C
, TOTPAGES, RQBLKSIZE, LBLKSIZE, ALISTSIZE, KEYLEN, C
SECTINDX)
!*
RECORDFORMAT LABFORM(BYTEINTEGERARRAY VOL(0:5), C
BYTEINTEGER S1, S2, S3, S4, ACCESS, C
BYTEINTEGERARRAY RES(1:20), C
BYTEINTEGER C1, C2, AC1, AC2, TPC1, TPC2, BF1, BF2, C
BYTEINTEGERARRAY POINTER(0:3), IDENT(1:14))
CONSTBYTEINTEGERARRAY HEXDS(0:15)='0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F'
CONSTINTEGER NORMALT=X'800000', ERRT=X'400000', C
ATTNT=X'100000', DISCSNO=X'00200000', PDISCSNO=X'210000', C
SCHEDSNO=X'30000'
OWNBYTEINTEGERARRAYFORMAT LVNF(0:99)
OWNBYTEINTEGERARRAYNAME LVN
CONSTLONGINTEGER LONGONE=1
OWNINTEGER DITADDR=0, NDISCS=0
!*
STRING (4)FN MTOS(INTEGER M)
INTEGER I,J
I=4; J=M
RESULT =STRING(ADDR(I)+3)
END
!*
EXTERNALROUTINE DISC(RECORD (PARMF)NAME P)
!*
ROUTINESPEC READ DLABEL(RECORD (DDTFORM)NAME DDT)
ROUTINESPEC LABREAD ENDS
ROUTINESPEC UNLOAD(RECORD (DDTFORM)NAME DDT)
ROUTINESPEC SENSE(RECORD (DDTFORM)NAME DDT, INTEGER VAL)
ROUTINESPEC DREPORT(RECORD (DDTFORM)NAME DDT,RECORD (PARMF)NAME P)
IF SSERIES=YES START
ROUTINESPEC FIRE CHAIN(RECORD (DDTFORM)NAME DDT)
RECORD (TCBF)NAME TCB
FINISH ELSE START
ROUTINESPEC SET PAW(RECORD (DDTFORM)NAME DDT,INTEGER PAW,SAW)
ROUTINESPEC REINIT DFC(INTEGER SLOT,PART)
ROUTINESPEC STREAM LOG(RECORD (DDTFORM)NAME DDT)
RECORD (RQBFORM)NAME RQB
RECORD (CCAFORM)NAME CCA
RECORD (DDTFORM)NAME ADDT
INTEGER K,STRM,PIW,PT
FINISH
RECORD (DDTFORM)NAME DDT,XDDT
RECORD (DDTFORM) SDDT
RECORD (PROPFORM)NAME PROP
RECORD (LABFORM)NAME LABEL
CONSTINTEGER AUTO=X'8000',AUTOAVAIL=AUTO!x'400';! bits in attn byte
CONSTINTEGER DEAD=0,CONNIS=1,RLABIS=2,DCONNIS=3,AVAIL=4,PAGTIS=5,C
PAGSIS=6,INOP=7,RRLABIS=8,PTISLOGP=9,PAVAIL=10,PCLAIMD=11,C
PTRANIS=12,PSENIS=13,SPTRANIS=14,RLABSIS=15
CONSTINTEGER RESPX=1<<CONNIS!1<<RLABIS!1<<DCONNIS!1<<PAGTIS! C
1<<PAGSIS!1<<RRLABIS!1<<PTISLOGP!1<<PTRANIS! C
1<<PSENIS!1<<SPTRANIS!1<<RLABSIS
CONSTINTEGER PAGIO=1<<PAGTIS!1<<PAGSIS!1<<PTISLOGP
CONSTINTEGER PRIVIO=1<<PTRANIS!1<<PSENIS!1<<SPTRANIS
CONSTINTEGER ZXDEV=M'ZX'; ! dummy device
CONSTINTEGER PROPLEN=40; ! length of property table
OWNINTEGER INITINH=0, LABREADS=0, CURRTICK=0
LONGINTEGER L
INTEGER ACT,I,J,SLOT,PTR,SIW1,SIW2,PTS,LRSTATE
INTEGER SEMA
STRING (40) S
STRING (6) PREVLAB
SWITCH INACT(0:12), AINT, FINT, NINT(0:15)
ACT=P_DEST&X'FFFF'
IF MONLEVEL&2#0 AND KMON&(LONGONE<<(DISCSNO>>16))#0 THEN C
PKMONREC("DISC:",P)
IF ACT>=64 THEN ->ACT64
->INACT(ACT)
INACT(0): ! initialisation
RETURN UNLESS NDISCS=0; ! in case initialised twice
NDISCS=COM_NDISCS
DITADDR=COM_DITADDR
LVN==ARRAY(COM_DLVNADDR,LVNF)
FOR I=0,1,99 CYCLE
LVN(I)=254
REPEAT
INITINH=1
!*
!
! For P series then:-
!
! Set up two arrays to avoid searching the DDT
! PTCA has the commnctns area public seg no for each controller(as p/t)
! PTBASE has a pointer to SLOTX. SLOTX contains 16 entries
! one for each stream and points to the DDT slot. Thus any disc can
! be found without searching
!
! For S series DCU supplies the slot address
!
IF SSERIES=NO START
I=INTEGER(COM_FPCCONFA)
IF I>MAX DFCS THEN I=MAX DFCS AND C
OPMESS("Too many DFCS for DISC")
FOR J=1,1,I CYCLE
K=INTEGER(COM_FPCCONFA+4*J)
PT=K>>24
PTBASE(PT)=16*J
PTCA(PT)=K&255; ! CA segment
REPEAT
FINISH
FOR J=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*J))
IF SSERIES=YES START
DDT_UASTE=INTEGER(PST VA+4+DDT_UA AD<<1>>19<<3)
DDT_SLOT=J
FINISH ELSE START
PT=DDT_PTS>>4
STRM=DDT_PTS&15
SLOTX(PTBASE(PT)+STRM)=J
FINISH
UNLESS DDT_MNEMONIC>>16=ZXDEV START
SENSE(DDT,0)
DDT_STATE=CONNIS; ! read vol labels
FINISH ELSE DDT_STATE=DEAD
REPEAT
P_DEST=PDISCSNO
PDISC(P)
P_DEST=X'A0001'; P_SRCE=0
P_P1=DISCSNO+5;P_P2=3; ! int on act 5 every 3 secs
PON(P)
RETURN
!*
! A disc may be in any one of the following states(held in DDT_STATE):-
! DEAD = 0 = not on line or unloaded
! CONNIS = 1 = connect interface & sense issued
! RLABIS = 2 = read label issued
! DCONNIS = 3 = disconnect (ie unload) issued. must reconnect on termntn
!
! If the label was valid the states then go:=
! AVAIL = 4 = available for paged or private use
! PAGTIS = 5 = paged transfer issued
! PAGSIS = 6 = paged transfer has failed & a sense issued
! INOP = 7 = inoperable awaiting operator reload
! RRLABIS = 8 = reread label issued
! PTISLOGP = 9 = as PAGTIS but read stream log pending
!
! Nonexistent or invald labels then go
! PAVAIL = 10 = available for private use
! PCLAIMD = 11 = claimed for private use by ser=DDT_STATUS
! PTRANIS = 12 = private chain issued
! PSENIS = 13 = private chain has failed & a sense isuued
! SPTRANIS = 14 = special private chain issued (no sense on failure)
! RLABSIS = 15 = read label failed & sense issued
!
INACT(1): ! claim for dedicated use
!
! Input request
! P_P1 = returnable
! P_P2 = service no for replies (o=release -1=unload--no reply)
! P_P3 = slot no or mnemonic or %STRING(6) vol label
!
! Replies
! P_P2 = 0 claim fails else service no for private requests
! P_P3 = slot no
! P_P4 = mnemonic
! P_P5& 6 = %STRING(6) vol label
!
PTR=P_P3; I=PTR
UNLESS 0<=PTR<NDISCS START
FOR I=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*I))
->HIT IF PTR=DDT_MNEMONIC OR DDT_LAB=STRING(ADDR(P_P3))
REPEAT
->CLAIM FAILS
FINISH ELSE DDT==RECORD(INTEGER(DITADDR+4*I))
HIT: ! DDT mapped on right slot
IF P_P2>0 START
IF DDT_STATE=PAVAIL OR (DDT_STATE=AVAIL AND DDT_DLVN<0)START
DDT_STATE=PCLAIMD
DDT_REPSNO=P_P2
->REPLY
FINISH ELSE ->CLAIM FAILS
FINISH ELSE START
IF DDT_STATE#PCLAIMD THEN OPMESS("Bum dev returned") C
AND RETURN
DDT_STATE=PAVAIL; DDT_REPSNO=0
IF SSERIES=NO START
RQB==RECORD(DDT_RQA); ! reset RQB (it may have been changed)
RQB_LSEGPROP=128<<18!X'C000'
RQB_LSEGADDR=INTEGER(PST VA+PST SEG*8+4)&X'FFFFF80'
PROP==RECORD(DDT_PROPADDR)
RQB_LBPROP=X'18000000'+PROP_LBLKSIZE
RQB_LBADDR=DDT_LBA
RQB_ALPROP=X'18000000'+PROP_ALISTSIZE
RQB_ALADDR=DDT_ALA
RQB_W6=X'FF00'
FINISH
OPMESS(MTOS(DDT_MNEMONIC)." unused")
IF P_P2<0 THEN SENSE(DDT,0) AND DDT_STATE=CONNIS
RETURN
FINISH
REPLY: ! reply to claims only
P_P2=DISCSNO+64+I
P_P3=I
P_P4=DDT_MNEMONIC
STRING(ADDR(P_P5))=DDT_LAB
SEND: P_DEST=P_SRCE
P_SRCE=DISCSNO+1
PON(P)
RETURN
CLAIM FAILS:
P_P2=0; ->SEND
INACT(2): ! paged request(_P1=DDTADDR)
DDT==RECORD(P_P1)
IF MULTI OCP=YES START
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0); *JCC_8,<PSEMAG>
SEMALOOP(DDT_SEMA,0)
PSEMAG:
FINISH
IF DDT_STATE#AVAIL OR P_SRCE&X'FFFF0000'#PDISCSNO START
IF MULTI OCP=YES START ; *LXN_SEMA; *TDEC_(XNB +0); FINISH
->REJECT
FINISH
DDT_STATE=PAGTIS
IF MULTI OCP=YES START ; *LXN_SEMA; *TDEC_(XNB +0); FINISH
DDT_ID=P_P1
IF SSERIES=YES START
FIRE CHAIN(DDT)
FINISH ELSE START
DDT_STICK=CURRTICK
CCA==RECORD(DDT_CAA)
! PT=DDT_PTS
STRM=DDT_PTS&15; ! real stream no
J=STRM+(P_P2+1)<<24; ! strm req normal or priority
SET PAW(DDT,J,X'10000024')
RETURN
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<GOTS>
SEMALOOP(CCA_MARK,2)
*LXN_CCA+4
GOTS: *LSS_(XNB +1); ! last PAW not cleared
*OR_J; *ST_(XNB +1); ! or batch requests together
*LB_STRM; *MYB_16; *ADB_CCA+4; *LXN_B
*LSS_X'10000024'; *ST_(XNB +8)
*LSS_-1; *LXN_CCA+4; *ST_(XNB +0)
*LSS_PT; *USH_-4; *USH_16; *OR_X'40000800'
*ST_B ; *LSS_1; *ST_(0+B )
FINISH
RETURN
ACT64: ! private chains
!
! Private chaining section
! ======= ======== =======
! The users has set up his chain using the area provided at grope time.
! P_P1 has a returnable ident
! P_P2 inhibit sense if <0
! P_P5&6 LSTBR
!
SLOT=ACT&63
DDT==RECORD(INTEGER(DITADDR+4*SLOT))
IF DDT_STATE#PCLAIMD THEN ->REJECT
!
DDT_REPSNO=P_SRCE
DDT_ID=P_P1; ! save private id
IF P_P2<0 THEN DDT_STATE=SPTRANIS ELSE DDT_STATE=PTRANIS
IF SSERIES=YES START
FIRE CHAIN(DDT)
FINISH ELSE START
DDT_STICK=CURRTICK
CCA==RECORD(DDT_CAA)
RQB==RECORD(DDT_RQA)
RQB_LSEGPROP=P_P5&X'FFFF0000'!X'C000'; ! ACR 0 protem
RQB_LSEGADDR=P_P6
STRM=DDT_PTS&15
SET PAW(DDT,X'01000000'+STRM,X'10000024'); ! user SAW flags ignored protem
FINISH
RETURN
REJECT: ! disc requested rejected
IF DDT_STATE=INOP OR DDT_STATE=RRLABIS START
IF SSERIES=YES THEN SIW1=0 ELSE CCA==RECORD(DDT_CAA)
->REPLY INOP
FINISH
PKMONREC("*** DISC rejects",P)
P_DEST=P_SRCE
P_P2=-1
P_SRCE=DISCSNO+64+SLOT
PON(P)
RETURN
INACT(4): ! note lvn P_P1 now checked
I=P_P1; J=LVN(I)
IF J>=NDISCS THEN RETURN ; ! crap lvn
DDT==RECORD(INTEGER(DITADDR+4*J))
DDT_DLVN=DDT_DLVN&255
RETURN
INACT(5): ! clocktick
IF SSERIES=NO AND AUTOLD#0 START
! a DFC being autoloaded
AUTOLD=AUTOLD-1
IF AUTOLD&255=0 THEN REINIT DFC(AUTOLD>>16,2) AND AUTOLD=0
RETURN
FINISH
CURRTICK=CURRTICK+1
FOR SLOT=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*SLOT))
IF SSERIES=NO AND CURRTICK-DDT_STICK>2 AND RESPX&1<<DDT_STATE#0 C
THEN ->TOUT
! DCU does timeout for S series I/Os
IF COM_SLIPL<0 AND DDT_STATE=INOP AND C
CURRTICK-DDT_STICK>100 AND DDT_CONCOUNT>0 C
AND DDT_MNEMONIC>>16#ZXDEV START ; ! inop for 5 mins & unmanned
PRINTSTRING("Disc timeout whilst running unattended
")
STOP ; ! enters 'RESTART'
FINISH
REPEAT
RETURN
IF SSERIES=NO START
TOUT: ! device times out
OPMESS(MTOS(DDT_MNEMONIC)." timed out")
CCA==RECORD(DDT_CAA)
STRM=DDT_PTS&15
IF CCA_PIW1&X'80000000'>>STRM#0 THEN START
OPMESS(MTOS(DDT_MNEMONIC)." missing int PONned")
P_DEST=DISCSNO+3; P_SRCE=0
P_P1=DDT_PTS>>4
PON(P)
RETURN
FINISH
IF DDT_STATE=CONNIS THEN DDT_STATE=DEAD AND RETURN ; ! no retry
! AFTER SAC ERROR THE DFC MAY BE LEFT
! WITH A SINGLE SUSPEND OUTSTANDING
! THIS IS INDICATED BY STOG IN REG 9XX
! CANNOT DETECT THIS WITHOUT A SCOPE SECOND SUSPEND
! TRY TO FORCE DFC INTO DIAGNOSTIC MODE.
! THE NEXT CHANNEL FLAG WILL THEN RESTART IT
BEGIN
INTEGER TRIES
I=X'40000800'!(DDT_PTS>>4&255)<<16
K=SAFEISREAD(I,J); ! THIS CLEAR STOGGLE IF SET
FOR TRIES=1,1,3 CYCLE
K=SAFEISWRITE(I,3) FOR J=1,1,TRIES
CCA_PAW=0; CCA_MARK=-1
SET PAW(DDT,X'01000000'+STRM,X'10000024')
WAIT(10)
DDT_STICK=CURRTICK
IF CCA_PAW=0 THEN OPMESS("transfer retried".STRINT(TRIES)) AND ->BEND
REPEAT
REINIT DFC(SLOT,1)
BEND: END
RETURN
FINISH
INACT(6): ! read stream log P_P1+P_P2=bitmask
IF MONLEVEL&4#0 THEN START
IF MULTIOCP=YES THEN RESERVE LOG
IF P_P1=-1 THEN L=-1 ELSE L=LENGTHENI(P_P1)<<32!P_P2&X'0FFFFFFFF'
PRINTSTRING("
Disc logging information")
IF SSERIES=YES THEN PRINTSTRING("
DCU/stream pagemoves pagefails") ELSE PRINTSTRING("
str response bytes read seeks srnh woff sker ster corrn") C
AND PRINTSTRING(" strbe hdoff media pagemoves pagefails")
FOR J=0,1,NDISCS-1 CYCLE
IF L&LONGONE<<J#0 START
DDT==RECORD(INTEGER(DITADDR+4*J))
IF SSERIES=YES START
IF DDT_STATE=AVAIL OR DDT_STATE=PAGTIS START
NEWLINE
PRINTSTRING(HTOS(DDT_DSSMM>>8,4)." ")
WRITE(DDT_STATS2,9); WRITE(DDT_STATS1,9)
PRINTSTRING(" ".DDT_LAB)
IF DDT_BASE>0 THEN PRINTSTRING(" (IPL vol)")
DDT_STATS1=0; DDT_STATS2=0
FINISH
FINISH ELSE START
IF DDT_STATE=AVAIL THEN STREAM LOG(DDT)
IF DDT_STATE=PAGTIS THEN DDT_STATE=PTISLOGP
FINISH
FINISH
REPEAT
NEWLINE
IF MULTIOCP=YES THEN RELEASE LOG
FINISH
P_DEST=P_SRCE; P_SRCE=DISCSNO!6
PON(P) IF P_DEST>0
PPROFILE
RETURN
INACT(7): ! reconfigure SAC(P_P2=SAC)
!
IF SSERIES=YES START ; ! or DCU rejects fire chain
PKMONREC("DISC fire fails:",P);! should not happen!!
DDT==RECORD(P_P3); ! but just conceivable during DCU recovery
! cannot leave a transfer hanging
IF P_P1=2 AND (DDT_STATE=PAGTIS OR DDT_STATE=PAGSIS) START
P_SRCE=P_DEST
P_DEST=DCU SNO+12
IF DDT_STATE=PAGTIS THEN P_P1=DDT_UA AD ELSE C
P_P1=DDT_UA AD+MAXTRANS*TCB SIZE
P_P2=DDT_SER
DPON(P,1); ! retry in 1 second
FINISH ELSE ->FINT(DDT_STATE)
RETURN
FINISH ELSE START
I=P_P2
P_P2=0
FOR J=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*J))
IF DDT_PTS>>8=I START ; ! SAC (possibly) in use
UNLESS DDT_STATE=DEAD START
UNLESS DDT_STATE=PAVAIL OR C
(DDT_STATE=AVAIL AND DDT_CONCOUNT=0) START ; ! in use
P_P2=4<<24!DDT_MNEMONIC>>8
P_P3=DDT_MNEMONIC<<24
EXIT
FINISH
UNLESS DDT_DLVN=-1 THEN LVN(DDT_DLVN&255)=255
DDT_STATE=DEAD
FINISH
FINISH
REPEAT
->ROUT
FINISH
INACT(8): ! transfer in progress when ZX dev awoke
! or disc swap when DFC autoloading
! CALL'ed not PONned (to keep replies in order)
IF SSERIES=YES THEN ->DUFFACT ELSE START
DDT==RECORD(INTEGER(DITADDR+4*P_P1))
CCA==RECORD(DDT_CAA); ! for CHINT
IF PAGIO&1<<P_P2#0 THEN ->REPLY INOP; ! P_P2 is old DDT_STATE
PT=DDT_PTS>>4
IF PRIVIO&1<<P_P2=0 THEN P_DEST=0 ELSE P_DEST=DDT_REPSNO
FINISH
PRIV INOP:
P_SRCE=DISCSNO
IF SSERIES=YES START
SIW1=0; ! for consistency later
TCB==RECORD(DDT_UA AD)
TCB_POST0=X'80800000'; ! inop
DDT_SENSE1=X'80800000'
FINISH ELSE START
DDT_SENSE2=X'80800000'
INTEGER(DDT_ALA+132)=DDT_SENSE2
FINISH
->COM2
INACT(9): ! for testing facilities
IF SSERIES=NO THEN I=CONTROLLER DUMP(P_P1,P_P2)
! need some sort of DCU dump for S series
RETURN
INACT(10): ! REINIT DFC (P_P1=PT,P_P2=OLD PT IF >=0)
IF SSERIES=YES THEN ->DUFFACT ELSE START
PT=P_P1
IF COM_NSACS=1 AND COM_SACPORT0#PT>>4 THEN ->BADPT
IF P_P2>=0 AND PT#P_P2 START ; ! SAC SWITCH
IF 0<=PT<=X'1F' AND 0<=P_P2<=X'1F' C
AND PTCA(PT)=0 AND PTCA(P_P2)>0 C
AND BYTEINTEGER(COM_CONTYPEA+PT)=0 AND C
BYTEINTEGER(COM_CONTYPEA+P_P2)=2 AND C
SAFE IS WRITE(X'40000800'!PT<<16,3)=0 START ; ! consistent
BYTEINTEGER(COM_CONTYPEA+P_P2)=0
BYTEINTEGER(COM_CONTYPEA+PT)=2; ! DFC
PTCA(PT)=PTCA(P_P2)
PTCA(P_P2)=0
PTBASE(PT)=PTBASE(P_P2)
PTBASE(P_P2)=0
FOR J=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*J))
I=DDT_PTS
IF I>>4=P_P2 START
IF AUTOLD>>16=J THEN AUTOLD=0
DDT_PTS=(I&15)!PT<<4
IF I=COM_SLIPL&X'FFF' THEN C
COM_SLIPL=COM_SLIPL>>16<<16!DDT_PTS
DDT_CHISA=X'40000800'!PT<<16
FINISH
REPEAT
FINISH ELSE ->BADPT
FINISH
IF 0<=PT<=X'1F' AND PTCA(PT)>0 AND C
SAFE IS WRITE(X'40000800'!PT<<16,2)=0 START
WAIT(1000); ! after master clear
REINIT DFC(PT,3)
FOR J=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*J))
IF DDT_PTS>>4=PT AND DDT_STATE=DEAD START
SENSE(DDT,0)
DDT_STATE=CONNIS
FINISH
REPEAT
FINISH ELSE OPMESS("Cannot reinit DFC ".HTOS(PT,2))
->ROUT
FINISH
BADPT:
OPMESS("DFC old/new pt???")
->ROUT
INACT(11): ! entry from SHUTDOWN routine
! P_P1 = pt
IF SSERIES=YES THEN ->DUFFACT ELSE START ; ! not S series protem
PT=P_P1
IF COM_NSACS=1 AND COM_SACPORT0#PT>>4 THEN ->ROUT; ! SAC gone
FOR J=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*J))
IF DDT_PTS>>4=PT THEN UNLOAD(DDT); ! disconnect
REPEAT
WAIT(100)
->ROUT
FINISH
ROUT:
UNLESS P_SRCE=0 START
I=P_SRCE
P_SRCE=P_DEST
P_DEST=I
PON(P)
FINISH
RETURN
IF SSERIES=YES START
DUFFACT:
PKMONREC("DISC act?",P)
RETURN
FINISH
INACT(3): ! interrupts
!***********************************************************************
!* Disc interrupt handling sequence *
!***********************************************************************
IF SSERIES=YES START
DDT==RECORD(P_P3)
SLOT=DDT_SLOT
PTS=DDT_DSSMM>>8&X'FFFF'; ! really DCU/stream
SIW1=P_P1
SIW2=P_P2
FINISH ELSE START
PT=P_P1; ! extract port & trunk from int
PTR=PTCA(PT)
IF PTR=0 THEN PRINTSTRING("No DFC on PT ".STRHEX(PT)."?
") AND RETURN
CCA==RECORD(X'80000000'+PTR<<18)
MORE INTS: ! see if any more ints
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<SGOT>; ! get semaphore
SEMALOOP(CCA_MARK,2)
*LXN_CCA+4
SGOT: *LSS_(XNB +2); *ST_PIW
*JAT_4,<CONTINT>
*SHZ_STRM; ! find interupting stream
CCA_PIW1=PIW!!X'80000000'>>STRM
! SIW1=INTEGER(ADDR(CCA_STRMS(STRM))+8)
! INTEGER(ADDR(CCA_STRMS(STRM))+8)=0
! SIW2=INTEGER(ADDR(CCA_STRMS(STRM))+12)
*LB_STRM; *MYB_16; *ADB_CCA+4; *LXN_B
*LSD_(XNB +10); *ST_SIW1
*LSS_0; *ST_(XNB +10)
CCA_MARK=-1
SLOT=SLOTX(PTBASE(PT)+STRM)
PTS=PT<<4+STRM
DDT==RECORD(INTEGER(DITADDR+4*SLOT))
IF DDT_PTS#PTS START
OPMESS("DISC tables ????")
FOR I=0,1,NDISCS-1 CYCLE ; ! try to find right slot
XDDT==RECORD(INTEGER(DITADDR+4*I))
IF XDDT_PTS=PTS START ; ! eureka
DDT==RECORD(ADDR(XDDT))
SLOT=I
EXIT
FINISH
REPEAT
FINISH
FINISH
IF SIW1&NORMALT#0 THEN ->NINT(DDT_STATE)
IF SIW1&ERRT#0 START
IF SSERIES=YES AND SIW2=-1 START ; ! timeout
FIRE CHAIN(DDT)
OPMESS(MTOS(DDT_MNEMONIC)." transfer retried")
RETURN
FINISH
->FINT(DDT_STATE)
FINISH
IF SIW1&ATTNT#0 AND SIW1&X'1000'=0 THEN ->AINT(DDT_STATE)
CHINT:IF SSERIES=NO AND CCA_PIW1#0 THEN ->MORE INTS
RETURN
IF SSERIES=NO START
CONTINT: ! int from controller or spurious
SIW1=CCA_CRESP1; SIW2=CCA_CRESP2
CCA_CRESP1=0; CCA_MARK=-1
IF SIW1#0 THEN PRINTSTRING("Disc controller int (". C
HTOS(PT,2).") :".STRHEX(SIW1)." ".STRHEX(SIW2)."??
")
RETURN
FINISH
!
NINT(AVAIL):FINT(AVAIL):
NINT(PAVAIL):FINT(PAVAIL):
NINT(PCLAIMD):FINT(PCLAIMD):
NINT(DEAD):FINT(DEAD): ! dead disc terinates?
PRINTSTRING("Disc int (".HTOS(PTS,3).") state ". C
STRINT(DDT_STATE)." ?????
")
->CHINT
NINT(CONNIS): ! sense terminates
LRSTATE=RLABIS; ! for read label
IF SSERIES=NO AND DDT_MNEMONIC>>16=ZXDEV START ; ! the kraken wakes!
J=DDT_PROPS
K=M'ED'<<16+HEXDS(J>>20&15)<<8+HEXDS(J>>16&15); ! real mnemonic
FOR I=0,1,NDISCS-1 CYCLE ; ! find old slot
XDDT==RECORD(INTEGER(DITADDR+4*I))
IF XDDT_MNEMONIC=K START
IF MULTI OCP=YES START
SEMA=ADDR(XDDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0); ! grab slot sema
*JCC_8,<KSEMAGOT>
SEMALOOP(XDDT_SEMA,0)
KSEMAGOT:
FINISH
XDDT_MNEMONIC=XDDT_MNEMONIC&X'FFFF'!ZXDEV<<16
DDT_PROPADDR=XDDT_PROPADDR
IF RESPX&1<<XDDT_STATE#0 START ; ! transfer in progress
P_DEST=DISCSNO+8
P_P1=I
P_P2=XDDT_STATE
XDDT_STATE=INOP
DISC(P); ! call (not PON) to keep PDISC replies in order
FINISH ELSE START
UNLESS XDDT_STATE=DEAD THEN XDDT_STATE=INOP
FINISH
IF XDDT_STATE=INOP AND XDDT_DLVN#-1 START ; ! force reload
DDT_LAB=XDDT_LAB
LRSTATE=RRLABIS
FINISH
I=-1; ! slot found
IF MULTI OCP=YES START ; *LXN_SEMA; *TDEC_(XNB +0); FINISH
EXIT
FINISH
REPEAT
DDT_MNEMONIC=K
IF I>=0 AND J>>24=X'35' START ; ! no old slot & EDS200
DDT_PROPADDR=DDT_PROPADDR+PROPLEN; ! default is EDS100
FINISH
FINISH
IF SSERIES=YES START
TCB==RECORD(DDT_UA AD+MAXTRANS*TCB SIZE)
DDT_SENSE1=TCB_POST0
DDT_SENSE2=TCB_POST1
DDT_SENSE3=TCB_POST2
DDT_SENSE4=TCB_POST6
FINISH ELSE START
I=DDT_ALA+128
DDT_SENSE1=INTEGER(I)
DDT_SENSE2=INTEGER(I+4)
DDT_SENSE3=INTEGER(I+8)
DDT_SENSE4=INTEGER(I+40)
!
! Reset the RQB so that the pointers point above the false floor
! of the logic block and address list. The false floor conceals a
! sense which is always set up
!
RQB==RECORD(DDT_RQA)
RQB_LBADDR=DDT_LBA
RQB_ALADDR=DDT_ALA
FINISH
I=DDT_PROPS>>24
IF I>X'35' THEN I=1 ELSE I=8
IF DDT_SENSE4&I<<28#0 START
READ DLABEL(DDT)
LABREADS=LABREADS+1
DDT_STATE=LRSTATE; ! RLABIS or RRLABIS
FINISH ELSE DDT_STATE=DEAD
->CHINT
NINT(RRLABIS): ! label on remounted disc read
NINT(RLABIS): ! label read successfully
LABREAD ENDS
IF SSERIES=YES THEN LABEL==RECORD(DDT_UA AD+TCB SIZE) ELSE C
LABEL==RECORD(DDT_ALA+72)
ETOI(ADDR(LABEL),6)
PREVLAB=DDT_LAB
FOR I=0,1,5 CYCLE
BYTEINTEGER(ADDR(DDT_LAB)+1+I)=LABEL_VOL(I)
REPEAT
LENGTH(DDT_LAB)=6
IF LABEL_ACCESS=X'C5' C
AND '0'<=LABEL_VOL(4)<='9' AND '0'<=LABEL_VOL(5)<='9' START
FOR I=0,1,3 CYCLE
BYTEINTEGER(ADDR(DDT_BASE)+I)=LABEL_POINTER(I)
REPEAT
S=" EMAS"
I=(LABEL_VOL(4)&X'F')*10+LABEL_VOL(5)&X'F'
IF LVN(I)<254 START
UNLESS SLOT=LVN(I) AND DDT_STATE#RRLABIS THEN ->DUPLICATE
FINISH
IF DDT_STATE=RRLABIS THEN DDT_LAB=PREVLAB AND ->REMOUNT
! wrong disc remounted
LVN(I)=SLOT
DDT_DLVN=I!X'80000000'
DDT_STATE=AVAIL
FINISH ELSE START
IF DDT_STATE=RRLABIS THEN ->REMOUNT;! wrong disc remounted
DDT_BASE=0
DDT_STATE=PAVAIL
DDT_DLVN=-1
S=" frgn"
FINISH
DDT_STATS1=0
DDT_STATS2=0
LOAD MESS:
OPMESS(MTOS(DDT_MNEMONIC)." loaded ".DDT_LAB.S)
->CHINT
DUPLICATE: ! disc with same lvn mounted
! may be remount of reqd disc
! on same or different drive
XDDT==RECORD(INTEGER(DITADDR+4*LVN(I)));! on oldmount slot
UNLESS XDDT_STATE=INOP OR XDDT_STATE=RRLABIS START ;! not awaiting remount
IF SSERIES=NO AND AUTOLD#0 START
! allow swap if DFC for old slot is autoloading
! (lest drive non-switchable & attentions blocked)
ADDT==RECORD(DITADDR+4*(AUTOLD>>16))
IF ADDT_PTS>>4=XDDT_PTS>>4 START
J=XDDT_STATE
XDDT_STATE=INOP
IF RESPX&1<<J#0 START ; ! transfer in progress
P_DEST=DISCSNO+8
P_P1=LVN(I)
P_P2=J
PON(P); ! fail transfer
FINISH
->DUPOK
FINISH
FINISH
OPMESS("Duplicate disc lvn ")
DDT_DLVN=-1; ! dont clear lvn when unloading
IF SSERIES=YES START ; ! no S/W unload
OPMESS("Unload ".MTOS(DDT_MNEMONIC))
DDT_STATE=DEAD
RETURN
FINISH ELSE START
UNLOAD(DDT)
DDT_STATE=DCONNIS; ->CHINT
FINISH
FINISH
DUPOK:
!
! Set up P for PONning to PDISC
!
P_DEST=PDISCSNO+11
P_SRCE=DISCSNO
P_P1=LVN(I); ! old slot
IF P_P1#SLOT START ; ! reloaded on different drive
IF XDDT_MNEMONIC>>16#ZXDEV AND DDT_STATE=RRLABIS C
THEN J=1 ELSE J=0; ! J=1 if DDT slot is awaiting another disc
IF MULTI OCP=YES START
SEMA=ADDR(XDDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0)
*JCC_8,<XSEMAGOT>
SEMALOOP(XDDT_SEMA,0)
XSEMAGOT:
UNLESS J=0 START
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0)
*JCC_8,<JSEMAGOT>
SEMALOOP(DDT_SEMA,0)
JSEMAGOT:
FINISH
! shouldn't cause an embrace (I hope!!)
FINISH
SDDT=DDT; ! save lest disc 'swap'
DDT_DLVN=XDDT_DLVN; ! copy across vital fields
DDT_STATS1=XDDT_STATS1; ! including fchk&closing bits
DDT_STATS2=XDDT_STATS2
DDT_CONCOUNT=XDDT_CONCOUNT
DDT_LQLINK=XDDT_LQLINK
DDT_UQLINK=XDDT_UQLINK
DDT_TRLINK=XDDT_TRLINK
DDT_QSTATE=XDDT_QSTATE
IF SSERIES=YES START ; ! reset AUTO IPL
IF XDDT_DSSMM>>8&X'FFFF'=COM_SLIPL&X'FFFF' THEN C
COM_SLIPL=COM_SLIPL>>16<<16!(DDT_DSSMM>>8&X'FFFF')
FINISH ELSE START
IF XDDT_PTS=COM_SLIPL&X'FFF' THEN C
COM_SLIPL=COM_SLIPL>>16<<16!DDT_PTS
FINISH
UNLESS J=0 START ; ! awaiting another disc
XDDT_DLVN=SDDT_DLVN
XDDT_STATS1=SDDT_STATS1
XDDT_STATS2=SDDT_STATS2
XDDT_CONCOUNT=SDDT_CONCOUNT
XDDT_LQLINK=SDDT_LQLINK
XDDT_UQLINK=SDDT_UQLINK
XDDT_TRLINK=SDDT_TRLINK
XDDT_QSTATE=SDDT_QSTATE
FINISH ELSE START
XDDT_STATS1=0; XDDT_STATS2=0; XDDT_STATE=DEAD
XDDT_CONCOUNT=0; XDDT_TRLINK=0
XDDT_LQLINK=0;XDDT_UQLINK=0;XDDT_QSTATE=0
FINISH
IF SSERIES=YES START ; ! cannot swap slots!!!
LVN(I)=SLOT
P_P1=SLOT
IF MULTI OCP=YES START
UNLESS J=0 START
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *TDEC_(XNB +0)
FINISH
SEMA=ADDR(XDDT_SEMA)
*LXN_SEMA; *TDEC_(XNB +0)
FINISH
FINISH ELSE START
SLOTX(PTBASE(DDT_PTS>>4)+DDT_PTS&15)=P_P1; ! swap SLOTX ptrs
SLOTX(PTBASE(XDDT_PTS>>4)+XDDT_PTS&15)=SLOT
SDDT=DDT; DDT=XDDT; XDDT=SDDT; ! swap slots
IF MULTI OCP=YES START
UNLESS J=0 START
SEMA=ADDR(XDDT_SEMA)
*LXN_SEMA; *TDEC_(XNB +0)
FINISH
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *TDEC_(XNB +0)
DDT==RECORD(ADDR(XDDT)); ! remap slot
FINISH
FINISH
FINISH
DDT_STATE=AVAIL
PON(P)
->LOADMESS
FINT(CONNIS): ! sense fails
DDT_STATE=DEAD; ->CHINT
FINT(RLABIS): ! read label fails
LABREAD ENDS
DDT_IW1=SIW1
DDT_SENSE1=SIW2
DDT_STATE=RLABSIS
SENSE(DDT,2)
->CHINT
NINT(RLABSIS):FINT(RLABSIS): ! SENSE AFTER LABREAD
DDT_LAB="nolabl"
DDT_DLVN=-1
DDT_STATE=PAVAIL
OPMESS(MTOS(DDT_MNEMONIC)." loaded no label")
DDT_BASE=0
P_DEST=0
->COM1
NINT(DCONNIS):FINT(DCONNIS): ! unload complete
SENSE(DDT,0); ! reconnect interface
DDT_STATE=CONNIS
UNLDED:OPMESS(MTOS(DDT_MNEMONIC)." unloaded")
IF DDT_DLVN#-1 THEN LVN(DDT_DLVN&255)=255
->CHINT
AINT(RLABIS):
LABREAD ENDS
AINT(DEAD):AINT(CONNIS): ! attention while initialising
AINT(RLABSIS):
PRINTSTRING("Attntn while initng ".HTOS(PTS,3)." ". C
STRHEX(SIW1).STRHEX(SIW2)."
")
IF SSERIES=NO START
FOR I=1,1,5000 CYCLE
IF CCA_PIW1&(X'80000000'>>STRM)#0 THEN ->CHINT
REPEAT
FINISH
DDT_STATE=CONNIS
SENSE(DDT,1); ! start sequence again
AINT(DCONNIS): ! extra attention caused by unload
->CHINT
AINT(AVAIL):AINT(PAVAIL): ! attention while idle
AINT(PAGTIS):AINT(PAGSIS):AINT(PTISLOGP): ! attention while paging
IF SIW1&HOLD#0 THEN START ; ! hold was pressed
IF DDT_STATE=PAVAIL OR C
(DDT_STATE=AVAIL AND DDT_CONCOUNT=0) START
! not in system use can unload
IF SSERIES=YES START ; ! no S/W unload
OPMESS("Unload ".MTOS(DDT_MNEMONIC))
! leave _STATE 'till disc goes manual
FINISH ELSE START
UNLOAD(DDT)
DDT_STATE=DCONNIS
FINISH
FINISH ELSE START
OPMESS(DDT_LAB." still needed ".STRINT(DDT_STATE))
FINISH
->CHINT
FINISH
IF SIW1&AUTOAVAIL=AUTOAVAIL START ; ! gratuitous 'auto & available'
PRINTSTRING("Surprise attntn on ".HTOS(PTS,3)." ". C
STRHEX(SIW1).STRHEX(SIW2)."
")
->CHINT
FINISH
!
! If attnt wasnt hold,surprise or log overflow(already dealt with) then it
! must have been not auto or not available. Abandon disc if possible
! otherwise demand it back and wait
!
IF DDT_STATE=PAVAIL OR C
(DDT_STATE=AVAIL AND DDT_CONCOUNT=0) START
DDT_STATE=DEAD
->UNLDED
FINISH
REMOUNT: ! demand reload of demounted disc
OPMESS("Reload ".DDT_LAB." now!!!".TOSTRING(17))
! Check (with sema) for transfer isuued and
! send failure replies
IF MULTIOCP=YES START
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0)
*JCC_8,<RSEMAGOT>
SEMALOOP(DDT_SEMA,0)
RSEMAGOT:
FINISH
I=DDT_STATE
DDT_STATE=INOP
DDT_STICK=CURRTICK
IF MULTIOCP=YES START
*LXN_SEMA; *TDEC_(XNB +0)
FINISH
IF RESPX&1<<I#0 START ; ! transfer in progress
IF PAGIO&1<<I#0 THEN ->REPLY INOP
IF PRIVIO&1<<I#0 THEN P_DEST=DDT_REPSNO AND ->PRIV INOP
FINISH
->CHINT
AINT(INOP): ! attention while waiting remount
IF SIW1&AUTO#0 START ; ! drive now reloaded
IF SSERIES=NO AND DDT_MNEMONIC>>16=ZXDEV START ; ! switch/labread fails/switch
K=M'ED'<<16!DDT_MNEMONIC&X'FFFF'
FOR I=NDISCS-1,-1,0 CYCLE ; !find old slot
XDDT==RECORD(INTEGER(DITADDR+4*I))
IF XDDT_MNEMONIC=K START
XDDT_MNEMONIC=ZXDEV<<16!K&X'FFFF'; ! swap back mnem.
XDDT_STATE=DEAD
XDDT_LAB=""
EXIT
FINISH
REPEAT
DDT_MNEMONIC=K
FINISH
READ DLABEL(DDT); ! check its right disc
LABREADS=LABREADS+1
DDT_STATE=RRLABIS
FINISH
->CHINT
AINT(RRLABIS):
FINT(RRLABIS): ! failed to read label
LABREAD ENDS
OPMESS(MTOS(DDT_MNEMONIC)." label read fails")
->REMOUNT
NINT(INOP):FINT(INOP): ! transfers & senses going when
! disc went inop have now finished
REPLY INOP: ! tell PDISC disc is inop
P_P3=ERRT; ! transfer failed
P_P4=0
P_P5=NORMALT; ! sense worked
P_DEST=PDISCSNO+10
P_SRCE=DISCSNO
DDT_ID=ADDR(DDT)
IF SSERIES=YES START
TCB==RECORD(DDT_UA AD+MAXTRANS*TCB SIZE)
TCB_POST0=X'80800000'; ! inop in 2ndry & 3ry status
DDT_SENSE1=X'80800000'
FINISH ELSE START
DDT_SENSE2=X'80800000'
INTEGER(DDT_ALA+132)=DDT_SENSE2
PT=DDT_PTS>>4; ! in case more ints incarea
FINISH
->COM2
FINT(SPTRANIS): ! special privat chain fails
! do a controller sense only
! so as to leave status
IF SSERIES=NO START ; ! not S series protem
CCA==RECORD(DDT_CAA)
CCA_CSAW2=ADDR(DDT_SENSE1)
SET PAW(DDT,X'04000000',X'11000008')
WAIT(5); ! modest wait for int.
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<GOTSEM>
SEMALOOP(CCA_MARK,2)
GOTSEM:
IF CCA_CRESP1#0 AND CCA_PIW1=0 THEN CCA_CRESP1=0; ! clear controller response
CCA_MARK=-1
FINISH
NINT(PTRANIS): ! private chain ok
NINT(SPTRANIS): ! special private chain ok
P_DEST=DDT_REPSNO
P_SRCE=DISCSNO+64+SLOT; ! was 64+STRM ! needs to be slot I think
P_P1=DDT_ID
P_P2=0; ! flag for normal termination
P_P3=SIW1; P_P4=SIW2
PON(P)
DDT_STATE=PCLAIMD
->CHINT
FINT(PTISLOGP): ! page request fails
DDT_STATE=PAGTIS; ! abandon pending logging read
FINT(PAGTIS): ! paged request fails
FINT(PTRANIS): ! private chain fails
DDT_IW1=SIW1
DDT_SENSE1=SIW2
DDT_STATE=DDT_STATE+1
SENSE(DDT,2)
->CHINT
NINT(PTISLOGP): ! page tran ok
IF SSERIES=NO THEN STREAM LOG(DDT); ! deal with pending logging
! request before replying
NINT(PAGTIS): ! paged transfer ok
P_DEST=PDISCSNO+10
P_SRCE=DISCSNO+2
P_P1=DDT_ID
P_P2=0
DDT_STATE=AVAIL
PDISC(P); ! CALL not PON for efficiency
->CHINT
FINT(PAGSIS): ! paged sense fails
IF SSERIES=NO THEN ->REMOUNT; ! tell operator & mark INOP etc.
! (not S series lest we are recovering DCUs)
NINT(PAGSIS): ! paged sense ok
IF SSERIES=YES START ; ! if inop then tell operator etc.
TCB==RECORD(DDT_UAAD+MAXTRANS*TCBSIZE)
IF TCB_POST0<0 THEN ->REMOUNT
FINISH ELSE START
IF INTEGER(DDT_ALA+132)<0 THEN ->REMOUNT
FINISH
P_DEST=PDISCSNO+10
P_SRCE=DISCSNO+2
DDT_STATE=AVAIL
->COM1
NINT(PSENIS): ! private sense ok
FINT(PSENIS): ! private sense fails (!???)
P_DEST=DDT_REPSNO
P_SRCE=DISCSNO+64+SLOT; ! was + STRM !
DDT_STATE=PCLAIMD
COM1:
P_P3=DDT_IW1
P_P4=DDT_SENSE1
P_P5=SIW1
IF SSERIES=YES START
TCB==RECORD(DDT_UA AD+MAXTRANS*TCBSIZE)
DDT_SENSE1=TCB_POST0
DDT_SENSE2=TCB_POST1
DDT_SENSE3=TCB_POST2
DDT_SENSE4=TCB_POST6
FINISH ELSE START
I=DDT_ALA+128
DDT_SENSE1=INTEGER(I)
DDT_SENSE2=INTEGER(I+4)
DDT_SENSE3=INTEGER(I+8)
DDT_SENSE4=INTEGER(I+40)
FINISH
COM2: ! inoperable replies join here
!
! If P series then:
! reset the RQB so that the pointers point above the false floor
! of the logic block and address list. The false floor conceals a
! sense which is always set up
!
IF SSERIES=NO START
RQB==RECORD(DDT_RQA)
RQB_LBADDR=DDT_LBA
RQB_ALADDR=DDT_ALA
FINISH
P_P1=DDT_ID
P_P2=1; ! transfer fails
IF SSERIES=YES THEN P_P6=ADDR(DDT_SENSE1)-4 ELSE C
P_P6=ADDR(DDT_SENSE1)
DREPORT(DDT,P)
UNLESS P_DEST=0 START
IF SSERIES=YES AND SIW1&DCU ERR=DCU ERR THEN DPON(P,2) ELSE PON(P)
! reply delayed if DCU error to give DCU1s time to recover
FINISH
RETURN
AINT(*): ! private attentions
P_DEST=DDT_REPSNO; P_SRCE=DDT_SER+64
P_P1=0; P_P2=0
P_P3=SIW1; P_P4=SIW2
PON(P) UNLESS P_DEST=0
RETURN
!*
ROUTINE UNLOAD(RECORD (DDTFORM)NAME DDT)
!***********************************************************************
!* Performs a disconnect interface which unloads the disc *
!* (P series only, no S/W unload on S series *
!***********************************************************************
IF SSERIES=YES START
! %RECORD(TCBF)%NAME TCB
! TCB==RECORD(DDT_UA AD)
! TCB_CMD=X'2C004018'; ! unload ignore shrt & long
! TCB_STE=DDT_UASTE
! TCB_NEXT TCB=0
! TCB_RESP=0
! P_DEST=DCU SNO+12
! P_SRCE=DISC SNO+7
! P_P1=ADDR(TCB)
! P_P2=DDT_SER
! P_P4=M'UNLD'
! PON(P)
FINISH ELSE START
RECORD (RQBFORM)NAME RQB
INTEGER STRM
STRM=DDT_PTS&15
RQB==RECORD(DDT_RQA)
RQB_W7=X'80001300'
RQB_W8=0
SET PAW(DDT,X'01000000'+STRM,X'10000024')
FINISH
END
ROUTINE READ DLABEL(RECORD (DDTFORM)NAME DDT)
!***********************************************************************
!* Reads sector 0 head 0 cyl 0 which should be 80 byte vol label *
!***********************************************************************
IF SSERIES=YES START
RECORD (TCBF)NAME TCB
INTEGER I
TCB==RECORD(DDT_UA AD)
TCB=0
TCB_STE=DDT_UASTE
TCB_INIT SMASK=X'FE'; ! mask nowt
TCB_INIT FN=X'20'; ! restore
TCB_CMD=X'2000C012'
TCB_DATA LEN=80
TCB_DATA AD=DDT_UA AD+TCBSIZE
P_DEST=DCU SNO+12
P_SRCE=DISC SNO+7
P_P1=ADDR(TCB)
P_P2=DDT_SER
P_P4=M'RLAB'
PON(P)
FINISH ELSE START
RECORD (RQBFORM)NAME RQB
INTEGER LBA,ALA,STRM
LBA=DDT_LBA
ALA=DDT_ALA
STRM=DDT_PTS&15
DDT_STICK=CURRTICK
RQB==RECORD(DDT_RQA)
!
INTEGER(LBA)=X'86000000'; ! chain cww,lit and selecthd
INTEGER(LBA+4)=X'00000A00'; ! read S0
INTEGER(ALA)=X'58000058'; ! 88 bytesof key+data
INTEGER(ALA+4)=ALA+64; ! read into address list space
RQB_W7=X'12001300'; ! seek cyl 0 & do chain
RQB_W8=0; ! seek data (hopefully ignored)
SET PAW(DDT,X'01000000'+STRM,X'10000024')
FINISH
END
ROUTINE LABREAD ENDS
!***********************************************************************
!* Called at end of read label to unihibit if needed *
!***********************************************************************
LABREADS=LABREADS-1
IF INITINH=1 AND LABREADS=0 THEN C
INITINH=0 AND UNINHIBIT(SCHEDSNO>>16)
END
ROUTINE SENSE(RECORD (DDTFORM)NAME DDT,INTEGER VAL)
!***********************************************************************
!* Perform a sense on device whose DDT slot is DDT.VAL=0 for initial*
!* sense. Sense to be preceeded by a connect stream. *
!* If P series then: *
!* preceed sense by read propcodes (into DDT_PROPS) *
!* a sense is always kept below the false floor in lbloack &alist *
!***********************************************************************
IF SSERIES=YES START
RECORD (TCBF)NAME TCB
TCB==RECORD(DDT_UA AD+MAX TRANS*TCB SIZE)
TCB_CMD=X'2C004004'; ! sense ignore shrt & long
TCB_STE=DDT_UASTE
TCB_DATA LEN=32
TCB_DATA AD=ADDR(TCB_POST0)
TCB_NEXT TCB=0
TCB_RESP=0
TCB_PRE0=DDT_LAST TCB ADDR; ! remember lest sense fails
P_DEST=DCU SNO+12
P_SRCE=DISC SNO+7
P_P1=ADDR(TCB)
P_P2=DDT_SER
P_P4=M'SNSE'
!PON(P)
GDC(P); ! reply PONned on failure
FINISH ELSE START
RECORD (RQBFORM)NAME RQB
INTEGER LBA,ALA,STRM
LBA=DDT_LBA-12+4*VAL
INTEGER(DDT_ALA-12)=ADDR(DDT_PROPS); ! keep consistent 'lest slot swap
ALA=DDT_ALA-16
STRM=DDT_PTS&15
DDT_STICK=CURRTICK
RQB==RECORD(DDT_RQA)
RQB_LBADDR=LBA
RQB_ALADDR=ALA
RQB_W7=X'02001300'; ! do chain
SET PAW(DDT,X'01000000'+STRM,X'10000024')
FINISH
END
!*
IF SSERIES=YES START
!*
ROUTINE FIRE CHAIN(RECORD (DDTFORM)NAME DDT)
P_DEST=DCU SNO+12
P_SRCE=DISC SNO+7
P_P1=DDT_UA AD
P_P2=DDT_SER
GDC(P); ! reply PONned on failure
! should not happen!!!
END
!*
FINISH ELSE START
ROUTINE SET PAW(RECORD (DDTFORM)NAME DDT,INTEGER PAW,SAW)
!***********************************************************************
!* GRAB SEMA AND SET ACTIVATION WORDS. THEN FIRE IO *
!***********************************************************************
RECORD (CCAFORM)NAME CCA
INTEGER W,OLDPAW
CCA==RECORD(DDT_CAA)
FOR W=1,1,5 CYCLE
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<GOTSEMA>
SEMALOOP(CCA_MARK,2)
GOTSEMA:
OLDPAW=CCA_PAW
IF OLDPAW=0 THEN ->FIRE
!
! Rather than wait try to form a batch request
!
! DUMPTABLE(0,ADDR(CCA),512)
IF OLDPAW>>24<=2 THEN OLDPAW=X'07000000' + C
(X'8000'>>(OLDPAW&15))
IF OLDPAW>>24=7 AND PAW>>24<=2 THEN C
PAW=OLDPAW!(X'8000'>>(PAW&15)) AND ->FIRE
IF W<3 THEN START
CCA_MARK=-1
*LXN_DDT+4; *LB_(XNB +31)
*LSS_1; *ST_(0+B )
WAIT(1)
FINISH
REPEAT
PRINTSTRING("
DFC--PAW not cleared")
FIRE:
CCA_PAW=PAW
IF PAW=X'04000000' THEN CCA_CSAW1=SAW ELSE C
INTEGER(ADDR(CCA)+32+16*(DDT_PTS&15))=SAW
CCA_MARK=-1
*LXN_DDT+4
*LB_(XNB +31); ! ch flag IS address
*LSS_1; *ST_(0+B )
END
ROUTINE REINIT DFC(INTEGER SLOT,PART)
!***********************************************************************
!* DFC is dead. Masterclear and move its commsarea from 0 to *
!* the place specified in DDT. Then fire the chain again *
!***********************************************************************
RECORDFORMAT INITFORM(INTEGER W0,W1,W2,W3,W4)
OWNRECORD (INITFORM) INIT
RECORD (DDTFORM)NAME DDT
RECORD (CCAFORM)NAME CCA,CCA0
OWNINTEGER DUMPS=-1
OWNINTEGER CONNECT LBE=X'00010800'
INTEGER I,J,K
INTEGER ISA,R,PT,CAA,STRM
IF PART<3 START ; ! part3 is from INACT(10)
DDT==RECORD(INTEGER(DITADDR+4*SLOT))
PT=DDT_PTS>>4
FINISH ELSE PT=SLOT
ISA=X'40000800'!PT<<16
CAA=X'80000000'+PTCA(PT)<<18; ! commarea addr
->PART2 IF PART>1
R=0; ! MP not loaded in DFC
DUMPS=DUMPS+1
IF DUMPS<=1 START
R=CONTROLLER DUMP(2,PT)
DUMPTABLE(60,CAA,288);! comms area
DUMPTABLE(61,DDT_LBA,600); ! LBs & address lists
FINISH
*LB_ISA; *LSS_2; *ST_(0+B ); ! master clear
IF R&X'80'=0 START ; ! mclear will have started autoload
AUTOLD=SLOT<<16!25; ! allow 3*25=75 secs
OPMESS("Trying to autoload DFC")
RETURN
FINISH
WAIT(1000); ! a sec to settle down
PART2:
SLAVESONOFF(0); ! turn off slaves
INIT_W0=((INTEGER(PST VA+PST SEG*8)&X'FFFC'+X'80')//8-1)<<18! C
X'80000000'
INIT_W1=INTEGER(PST VA+PST SEG*8+4)&X'0FFFFF80'
INIT_W2=CAA; ! W2 to comms area address
!
! Init W0&W1 have size&base 0f PST. Now set up real0 as commarea
!
CCA0==RECORD(REAL0ADDR)
CCA0_MARK=-1
CCA0_PAW=X'04000000'; ! do controller req
CCA0_CSAW1=X'12000014'; ! 20 bytes of init info
CCA0_CSAW2=REALISE(ADDR(INIT))
*LB_ISA; *LSS_1; *ST_(0+B )
WAIT(5)
IF DUMPS=0 AND PART<3 THEN START
DUMPTABLE(64,REAL0ADDR,127)
DUMPTABLE(65,CAA,127)
FINISH
IF CCA0_PAW=0 START
OPMESS("DFC ".HTOS(PT,2)." reinitialised")
DUMPS=-1
FINISH ELSE START
OPMESS("Failed to autoload DFC")
IF DUMPS>1 AND COM_SLIPL<0 START
PRINTSTRING("DFC autoload failed whilst running unattended
")
STOP ; ! enters 'RESTART'
FINISH
FINISH
CCA==RECORD(CAA)
CCA_CRESP1=0; ! delete initialise response
CCA_PAW=0
FOR I=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*I))
IF DDT_PTS>>4=PT START
STRM=DDT_PTS&15
J=X'01000000'+STRM; ! reconnect all streams
RQB==RECORD(DDT_RQA)
K=RQB_LBADDR; ! remember current chain ptr
R=RQB_W7; ! & control flags etc.
RQB_LBADDR=ADDR(CONNECT LBE)
RQB_W7=X'02001300'; ! do chain
SET PAW(DDT,J,X'10000024')
WAIT(10); ! modest wait
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<SGOT>
SEMALOOP(CCA_MARK,2)
SGOT:
CCA_PIW1=CCA_PIW1!!X'80000000'>>STRM; ! clear interrupt
INTEGER(ADDR(CCA_STRMS(STRM))+8)=0; ! & response
CCA_MARK=-1
RQB_LBADDR=K; ! restore chain ptr
RQB_W7=R; ! & flags
IF RESPX&1<<DDT_STATE#0 START
SET PAW(DDT,J,X'10000024'); ! refire chain
DDT_STICK=CURRTICK
FINISH
FINISH
REPEAT
SLAVESONOFF(-1); ! slaves back on
END
ROUTINE STREAM LOG(RECORD (DDTFORM)NAME DDT)
!***********************************************************************
!* Read the stream log for each stream in turn. Waits for response *
!***********************************************************************
IF MONLEVEL&4#0 THEN START
RECORD (RQBFORM)NAME RQB
RECORD (CCAFORM)NAME CCA
INTEGER LBA,ALA,STRM,I,J
LBA=DDT_LBA; ALA=DDT_ALA
STRM=DDT_PTS&15
CCA==RECORD(DDT_CAA)
RQB==RECORD(DDT_RQA)
!
INTEGER(LBA)=X'00410200'; ! READ STREAM LOG
INTEGER(ALA)=X'5800000C'; ! 12 BYTES
INTEGER(ALA+4)=ALA+16; ! DATA INTO ADDRESS LIST
RQB_W7=X'02001300'; ! DO STREAM REQUEST
SET PAW(DDT,X'02000000'+STRM,X'10000024')
!
J=ADDR(CCA_STRMS(STRM))+8
I=0
WHILE I<500 CYCLE
WAIT(1)
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<GOTS>
SEMALOOP(CCA_MARK,2)
GOTS:
EXIT IF INTEGER(J)#0
I=I+1
CCA_MARK=-1
REPEAT ; ! UNTIL RESPONSE
!
CCA_MARK=-1
I=INTEGER(J)
INTEGER(J)=0; ! CLEAR RESPONSE WORD
NEWLINE; WRITE(STRM,2)
PRINTSTRING(" ".STRHEX(I))
ALA=ALA+16; ! TO STREAM DATA
WRITE(INTEGER(ALA),10); ! BYTES READ
WRITE(BYTEINTEGER(ALA+4)<<8!BYTEINTEGER(ALA+5),7);! SEEKS
J=BYTEINTEGER(ALA+6)
WRITE(J>>4,4); ! SRNHS
WRITE(J&15,4); ! WOFFS
J=BYTEINTEGER(ALA+7)
WRITE(J>>4,4); ! SEEK ERRORS
WRITE(J&15,4); ! SMAC ERRS
WRITE(BYTEINTEGER(ALA+8),5); ! DATA CORRNS
WRITE(BYTEINTEGER(ALA+9),5); ! STROBE OFFSETS
WRITE(BYTEINTEGER(ALA+10),5); ! HD OFFSETS
WRITE(BYTEINTEGER(ALA+11),5); ! MEDIA ERRORS
WRITE(DDT_STATS2,9); ! PAGES TRANSFERRED
WRITE(DDT_STATS1,9); ! PAGES THAT FAILED TO TRANSFER
PRINTSTRING(" ".DDT_LAB)
IF DDT_BASE=X'800' THEN PRINTSTRING(" (IPL VOL)")
DDT_STATS1=0; DDT_STATS2=0
FINISH
END
FINISH
ROUTINE DREPORT(RECORD (DDTFORM)NAME DDT,RECORD (PARMF)NAME P)
!***********************************************************************
!* Prints out a failure report in a readable form *
!***********************************************************************
IF SSERIES=YES START
CONSTINTEGER TCBPSIZE=40; ! bytes of TCB to be dumped
CONSTSTRING (8)ARRAY SENSEM(0:7)="S0T1T2T3","T4T5T6T7",
"T8T9TAC0","C1C2C3C4","C5C6M0M1",
"M2M3M4M5","M6M7M8M9","MAXXXXXX";
RECORD (TCBF)NAME STCB,FTCB
INTEGER I,J,K,N
STCB==RECORD(DDT_UA AD+MAX TRANS*TCBSIZE); ! sense TCB
UNLESS STCB_PRE0=0 THEN FTCB==RECORD(STCB_PRE0) ELSE C
FTCB==RECORD(DDT_UA AD); ! _PRE0 remembered by SENSE
IF MULTI OCP=YES THEN RESERVE LOG
PRINTSTRING("&& DISC TRANSFER ".DDT_LAB." ON ". C
MTOS(DDT_MNEMONIC)." (".HTOS(DDT_DSSMM>>8,4).") FAILS "C
.STRING(ADDR(COM_DATE0)+3)." ".STRING(ADDR(COM_TIME0)+3))
PRINTSTRING("
TCB response = ".HTOS(FTCB_RESP,8)."
sense data (response = ".HTOS(STCB_RESP,8).")
")
K=ADDR(STCB_POST0)
FOR I=0,1,7 CYCLE
PRINTSTRING(SENSEM(I)." ".STRHEX(INTEGER(K+4*I)))
NEWLINE
REPEAT
PRINTSTRING("
complete chain of TCBs before failure
")
N=(ADDR(FTCB)-DDT_UA AD)//TCBSIZE
FOR J=0,4,TCBPSIZE-4 CYCLE
FOR I=0,1,N CYCLE
PRINTSTRING(HTOS(INTEGER(DDT_UAAD+I*TCBSIZE+J),8))
IF J=0 AND I#N THEN PRINTSTRING("->") ELSE SPACES(2)
REPEAT
NEWLINE
REPEAT
NEWLINE
IF MULTI OCP=YES THEN RELEASE LOG
FINISH ELSE START
CONSTSTRING (3)ARRAY SENSEM(0:11)=" C0"," S0"," T3"," T7",
"T11","T15","T19","T23",
"T27","T31"," M0"," M4";
RECORD (PROPFORM)NAME PROP
INTEGER I,J,K,A0,A1,FLB,AAL,LBE
PROP==RECORD(DDT_PROPADDR)
IF MULTIOCP=YES THEN RESERVE LOG
PRINTSTRING("
&& DISC TRANSFER ".DDT_LAB." ON ".MTOS(DDT_MNEMONIC). C
" (".HTOS(DDT_PTS,3).") FAILS ".DATE." ".TIME."
RESPONSE0 RESPONSE1 FAILURES TRANSFERS
")
PRINTSTRING(" ".STRHEX(P_P3)." ".STRHEX(P_P4))
WRITE(DDT_STATS1,8)
WRITE(DDT_STATS2,9)
PRINTSTRING("
SENSE DATA (RESP=".STRHEX(P_P5).")
")
K=DDT_ALA+128
FOR I=0,1,11 CYCLE
PRINTSTRING(SENSEM(I)." ".STRHEX(INTEGER(K+4*I))."
")
REPEAT
PRINTSTRING("
RQB LBLOCK ADDRESS LIST ID
")
FLB=P_P3&255
I=FLB+2
IF I<8 THEN I=8
FOR J=0,4,4*I CYCLE
IF J<=32 THEN PRINTSTRING(STRHEX(INTEGER(DDT_RQA+J))." ") C
ELSE PRINTSTRING(" ")
LBE=INTEGER(DDT_LBA+J)
PRINTSTRING(STRHEX(LBE))
IF 4*FLB=J THEN PRINTSYMBOL('*') ELSE SPACE
AAL=(LBE&255)*4; ! BYTES FROM START OF AL
PRINTSTRING("-> ")
IF AAL<PROP_ALISTSIZE THEN START
A0=INTEGER(DDT_ALA+AAL)
A1=INTEGER(DDT_ALA+AAL+4)
PRINTSTRING(STRHEX(A0).STRHEX(A1)." ")
IF LBE>>8&255=X'69' AND A0=5 AND A1<0 START ;! PRINT ID IF PUBLIC
FOR K=0,1,4 CYCLE
PRINTSTRING(HTOS(BYTEINTEGER(A1+K),2))
REPEAT
FINISH
FINISH ELSE PRINTSTRING("NOT VALID")
NEWLINE
REPEAT
NEWLINE
IF MULTIOCP=YES THEN RELEASE LOG
FINISH
END
END
EXTERNALROUTINE PDISC(RECORD (PARMF)NAME P)
!***********************************************************************
!* Receives paged disc transfers. Organises all queuing and *
!* generates the ccws which are the passed to disc for execuition *
!***********************************************************************
IF SSERIES=YES START
RECORD (TCBF)NAME TCB
CONSTINTEGERARRAY CMD(1:6)=X'20408022',
X'20408023'(2),X'20408222',X'20408022',X'20408023'
!
! Error recovery consists of making retries with strobe normal,early
! and late and the following head offsets:-
! 0,+12,-12,+24,-24,+36,-36
! this gives 21 additional reads. The first retry in normal as advised
! the array corrn contains mode,function&offset bytes in btm 24 bits
!
CONSTINTEGERARRAY CORRN(0:22)=0,
X'001C00',X'204C00',X'104C00',
X'004C0C',X'204C0C',X'104C0C',
X'004C8C',X'204C8C',X'104C8C',
X'004C18',X'204C18',X'104C18',
X'004C98',X'204C98',X'104C98',
X'004C24',X'204C24',X'104C24',
X'004CA4',X'204CA4',X'104CA4',
X'008C00';
CONSTINTEGER FDS160=X'39'
FINISH ELSE START
RECORD (RQBFORM)NAME RQB
CONSTINTEGERARRAY CCW(1:6)=X'04002202',
X'84002302',X'84002302',X'24002202',X'04002202',
X'84002302';
CONSTINTEGER IGNORELB=X'400000'
FINISH
RECORDFORMAT REQFORM(INTEGER DEST, BYTEINTEGER FAULTS, FLB, C
LLBP1, REQTYPE, INTEGER IDENT, CYLINK, COREADDR, CYL, C
TRKSECT, STOREX, REQLINK)
RECORD (DDTFORM)NAME DDT,XDDT
RECORD (PROPFORM)NAME PROP
RECORD (PARMXF)NAME ACELL
RECORD (REQFORM)NAME REQ,ENTRY
CONSTINTEGER TRANOK=0, TRANWITHERR=1, TRANREJECT=2, C
NOTTRANNED=3, ABORTED=4, PTACT=5, POUTACT=6
!%ROUTINESPEC QUEUE(%INTEGERNAME QHEAD, %INTEGER REQ,CYL)
ROUTINESPEC PTREPLY(RECORD (REQFORM)NAME REQ,INTEGER FAIL)
SWITCH PDA(0:11)
OWNINTEGER INIT=0
INTEGERNAME LINK
INTEGER SEMA
IF SSERIES=YES START
INTEGER NEXT SEEK,TCBA,SECTINDX,STEAD
CONSTINTEGERARRAY RETRIES(1:6)=21,2,2,21,21,2
CONSTINTEGER PAGED=X'40000000',CYCLIC CHECK=X'40'
FINISH ELSE START
INTEGER LBA,ALA,XTRA,CURRHEAD,FIRSTHEAD,FIRST SECT,LBA0,ALA0
CONSTINTEGERARRAY RETRIES(1:6)=7,1,1,7,7,1
CONSTINTEGER MAXTRANS=12,CYCLIC CHECK=X'80'
FINISH
INTEGER I,J,K,ACT,UNIT,LUNIT,CYL,TRACK,SECT,CELL,SECSTAT
INTEGER ERRLBE,UNRECOVERED,NEXTCELL,SRCE,FAIL,FLB,STOREX,L,PRIO
!*
ACT=P_DEST&X'FFFF'
IF MONLEVEL&2#0 AND KMON&(LONGONE<<(PDISCSNO>>16))#0 THEN C
PKMONREC("PDISC:",P)
->PDA(ACT)
PDA(0): ! initialise
IF INIT#0 THEN RETURN ; ! in case !
FOR I=0,1,NDISCS-1 CYCLE
DDT==RECORD(INTEGER(DITADDR+4*I))
DDT_QSTATE=0
DDT_LQLINK=0
DDT_UQLINK=0
DDT_TRLINK=0
DDT_CURCYL=0
IF MULTIOCP=YES THEN DDT_SEMA=-1
REPEAT
INIT=1
RETURN
PDA(6): ! pageout request(ie write)
PDA(5): ! pageturn request(ie read)
! P_P1=AMTX/EPX
! P_P2=discaddr
! P_P3=STOREX
! P_P4=prioity 0=high,1=low
P_P6=P_P3; ! save STOREX
P_P3=(STORE(P_P3)_REALAD+X'01000000')!X'80000000'
! turn into PDA(1) form
PDA(1): ! read request
PDA(2): ! write request
PDA(3): ! write + check(treated as write)
PDA(4): ! check read
! all have _P2=discaddr and
! _P3 =coreaddr
SRCE=P_SRCE&X'7FFFFFFF'
UNIT=P_P2>>24
IF UNIT>99 THEN ->REJECT; ! prevent bound chk on crap da
J=P_P2&X'FFFFFF'; ! fsys relative page
LUNIT=LVN(UNIT)
->REJECT IF LUNIT>=NDISCS
DDT==RECORD(INTEGER(DITADDR+4*LUNIT))
IF SSERIES=YES START
! _PPERTRK for FDS devices is pages*2/TRACK so double the page no.
! to get correct CYL/TRACK then recalculate SECT from real page no.
K=J
IF DDT_PROPS>>24>=FDS160 THEN J=J*2
FINISH
! PROP==RECORD(DDT_PROPADDR)
! I=J//PROP_PPERTRK
! SECT=J-I*PROP_PPERTRK+1
! CYL=I//PROP_TRACKS
! TRACK=I-CYL*PROP_TRACKS
! %IF CYL>PROP_CYLS %THEN ->REJECT
*LCT_DDT+4
*LXN_(CTB +2); ! XNB to props record
*LSS_J
*IMDV_(XNB +2); ! _PPERTRK
*IMDV_(XNB +0); ! PROP_TRACKS
*ST_CYL
*LB_TOS
*STB_TRACK
*LB_TOS
*ADB_1
*STB_SECT
*ICP_(XNB +1); ! PROP_CYLS
*JCC_2,<REJECT>
IF SSERIES=YES START
! %UNLESS K=J %START; ! recalculate SECT
! SECT=K-K//PROP_PPERTRK*PROP_PPERTRK+1
! %IF SECT>PROP_PPERTRK//2+1 %THEN SECT=SECT-PROP_PPERTRK//2
! %FINISH
*LSS_K; *ICP_J; *JCC_8,<SECTOK>
*IMDV_(XNB +2); *LSS_TOS ; *IAD_1; *ST_SECT
*LSS_(XNB +2); *USH_-1; *ST_J
*IAD_1; *ICP_SECT; *JCC_10,<SECTOK>
*LSS_SECT; *ISB_J; *ST_SECT
SECTOK:
FINISH
!
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<PSEMAGOT>
SEMALOOP(MAINQSEMA,0)
PSEMAGOT:
FINISH
IF PARMASL=0 THEN MORE PPSPACE
ACELL==PARM(PARMASL)
CELL=ACELL_LINK
REQ==PARM(CELL)
IF CELL=PARMASL THEN PARMASL=0 ELSE C
ACELL_LINK=REQ_REQLINK
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
P_SRCE=ACT; ! set 3 bytes to 0 also !
REQ<-P
REQ_DEST=SRCE
REQ_CYLINK=0
REQ_CYL=CYL
REQ_TRKSECT=(TRACK<<8!SECT)<<8
REQ_REQLINK=0
IF MULTIOCP=YES THEN START
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0)
*JCC_8,<QSEMAGOT1>
SEMALOOP(DDT_SEMA,0)
QSEMAGOT1:
FINISH
IF DDT_QSTATE=0 OR CYL>=DDT_CURCYL THEN START
! QUEUE(DDT_UQLINK,CELL,CYL)
LINK==DDT_UQLINK; *JLK_<QUEUE>
FINISH ELSE START
! QUEUE(DDT_LQLINK,CELL,CYL)
LINK==DDT_LQLINK; *JLK_<QUEUE>
FINISH
->INIT TRANSFER IF DDT_QSTATE=0; ! unit idle
IF MULTIOCP=YES START ; *LXN_SEMA; *TDEC_(XNB +0); FINISH
RETURN
REJECT: ! request invalid
PKMONREC("*** PDISC rejects",P)
P_DEST=SRCE
P_SRCE=PDISCSNO+ACT
P_P2=TRANREJECT; ! rejected
IF ACT=PTACT THEN PTREPLY(P,2) ELSE PON(P)
RETURN
INIT TRANSFER: ! set up chain and hand to disc
CELL=DDT_UQLINK
REQ==PARM(CELL)
!
! Assume all transfers on this cyl will be carried out and arrange
! linking accordingly. Correct linking at repeat if not so
!
DDT_UQLINK=REQ_REQLINK
CYL=REQ_CYL
IF SSERIES=YES START
IF CYL=DDT_CURCYL#0 THEN NEXT SEEK=X'C' ELSE NEXT SEEK=X'1C'
! X'10' = seek cyl
TCBA=DDT_UA AD
PROP==RECORD(DDT_PROPADDR)
SECTINDX=PROP_SECTINDX
FINISH ELSE START
IF CYL=0 THEN XTRA=IGNORELB ELSE XTRA=0
ALA=DDT_ALA
ALA0=ALA
LBA=DDT_LBA
LBA0=LBA
RQB==RECORD(DDT_RQA)
FINISH
!
! The IPL cyl (0) is nonstandard in 2 ways
! firstly it has overflow formats and secondly track 0 has no keys
! disc tries to hide this so that the bulkmover etc can be used
! to move chopsupe to the worksite
!
FLB=0; I=0; PRIO=1
CYCLE
NEXTCELL=REQ_CYLINK
IF REQ_REQTYPE=POUTACT AND C
STORE(REQ_STOREX)_FLAGLINK&X'FF0000'#0 START
REQ_CYLINK=ABORTED
INTEGER(ADDR(REQ)+4)=PDISCSNO
FASTPON(CELL)
FINISH ELSE START
IF REQ_REQTYPE#PTACT THEN PRIO=0
IF SSERIES=YES START
TCB==RECORD(TCBA)
TCBA=TCBA+TCBSIZE
TCB=0
TCB_INIT SMASK=X'FE'; ! nothing masked
TCB_INIT FN=NEXT SEEK; ! seek cyl,head & seg
J=REQ_TRKSECT>>8&255
TCB_INIT SECT=J
TCB_INIT SEG=SECTINDX*EPAGESIZE*(J-1)
J=REQ_TRKSECT>>16
TCB_INIT HEAD=J
TCB_INIT SHEAD=J
TCB_INIT HDLIMIT=1
TCB_INIT CYL=CYL
TCB_INIT SCYL=CYL
IF REQ_FAULTS#0 START ; ! are retrying not transfering
J=CORRN(REQ_FAULTS)
TCB_INIT MODE<-J>>16
TCB_INIT FN<-J>>8
TCB_INIT OFFSET<-J
NEXT SEEK=X'8C'; ! clear offset
FINISH ELSE NEXT SEEK=X'C'; ! is this necessary?
TCB_CMD=CMD(REQ_REQTYPE&255)
STEAD=PST VA+REQ_COREADDR<<1>>19<<3
TCB_STE=INTEGER(STEAD+4)
IF INTEGER(STEAD)&PAGED#0 THEN TCB_STE=TCB_STE!2
TCB_NEXT TCB=TCBA
TCB_DATA AD=REQ_CORE ADDR
TCB_DATA LEN=TRANSIZE
REQ_FLB=FLB
FINISH ELSE START
IF I=0 THEN START
FIRST HEAD=REQ_TRKSECT>>16
CURR HEAD=FIRST HEAD
FIRST SECT=REQ_TRKSECT>>8&255
FINISH ELSE START ; ! select hd§or
J=REQ_TRKSECT>>16; ! head for this transfer
IF J#CURR HEAD OR CYL=0 START
CURR HEAD=J
INTEGER(LBA)=X'86000000'+J; ! select head
LBA=LBA+4
FINISH
K=REQ_TRKSECT>>8&255; ! rotational sector
INTEGER(LBA)=X'86001000'+20*EPAGESIZE*(K-1); ! set sector for k
LBA=LBA+4
FINISH
REQ_FLB=FLB
J=(LBA-LBA0)>>2; ! logic block no for tic
K=(ALA-ALA0)>>2; ! start of relevant bit of alist
INTEGER(LBA)=X'84106900'+K; ! search id =
INTEGER(LBA+4)=X'01000000'+J;! tic to search id
INTEGER(LBA+8)=CCW(REQ_REQTYPE)!XTRA+K
INTEGER(ALA)=5
INTEGER(ALA+4)=ADDR(REQ)+22;! ADDR(REQ_CYL)+2
INTEGER(ALA+8)=TRANSIZE
INTEGER(ALA+12)=REQ_COREADDR
LBA=LBA+12
ALA=ALA+16
FINISH
I=I+1
!
! Move the cell from the request queu to transferinprogress queu
!
REQ_REQLINK=DDT_TRLINK
DDT_TRLINK=CELL
IF SSERIES=YES THEN FLB=(TCBA-DDT_UA AD)//TCBSIZE ELSE C
FLB=(LBA-LBA0)>>2
REQ_LLBP1=FLB
FINISH
CELL=NEXT CELL
!
! See if there any more transfers and if the are on the same cyl
!
IF CELL=0 THEN ->DECHAIN
REQ==PARM(CELL)
EXIT IF I=MAXTRANS
REPEAT
REQ_REQLINK=DDT_UQLINK
DDT_UQLINK=CELL
DECHAIN:
IF I=0 THEN ->DOMORE; ! all aborted choose next cyl
IF SSERIES=YES START
TCB_NEXT TCB=0; ! unchain TCBs
TCB_CMD=TCB_CMD&X'FFBFFFFF'
FINISH ELSE START
! INTEGER(LBA-4)=INTEGER(LBA-4)&X'FBFFFFFF'
*LD_X'18000001FFFFFFFC'; ! one byte/-4
*INCA_LBA; ! to LBA-4
*MVL_L =1,251,0; ! X'FB',0 clear chain bit
RQB_W7=X'1E001300'
RQB_W8=CYL<<16!(20*EPAGESIZE*(FIRST SECT-1))<<8!FIRST HEAD
FINISH
IF MONLEVEL&4#0 THEN DDT_STATS2=DDT_STATS2+1; ! update transfer count
P_DEST=DISCSNO+2
P_SRCE=PDISCSNO+10
P_P1=ADDR(DDT)
P_P2=PRIO
DDT_QSTATE=1
DDT_CURCYL=CYL
IF MULTIOCP=YES START ; *LXN_SEMA; *TDEC_(XNB +0); FINISH
DISC(P)
RETURN
PDA(10): ! reply from DISC
DDT==RECORD(P_P1)
IF MULTIOCP=YES START
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0)
*JCC_8,<QSEMAGOT2>
SEMALOOP(DDT_SEMA,0)
QSEMAGOT2:
FINISH
CELL=DDT_TRLINK
IF P_P2=0 THEN START ; ! duplicate code for speed
WHILE CELL#0 CYCLE
REQ==PARM(CELL)
J=REQ_REQLINK
IF REQ_REQTYPE=PTACT THEN START
!
! Put this code in line
!
! PTREPLY(REQ,0)
STOREX=REQ_STOREX
IF MULTIOCP=YES THEN START
*INCT_(STORESEMA)
*JCC_8,<SSEMAGOT2>
SEMALOOP(STORESEMA,0)
SSEMAGOT2:
FINISH
L=STORE(STOREX)_FLAGLINK
STORE(STOREX)_FLAGLINK=L&X'3FFF0000'
IF MULTIOCP=YES START ; *TDEC_(STORESEMA); FINISH
L=L&X'FFFF'
UNTIL L=0 CYCLE
K=PARM(L)_LINK
FASTPON(L)
L=K
REPEAT
! RETURN PP CELL(CELL)
IF MULTIOCP=YES THEN START
*INCT_MAINQSEMA
*JCC_8,<QSEMAGOT>
SEMALOOP(MAINQSEMA,0)
QSEMAGOT:
FINISH
IF PARMASL=0 THEN REQ_REQLINK=CELL ELSE START
ACELL==PARM(PARMASL)
REQ_REQLINK=ACELL_LINK
ACELL_LINK=CELL
FINISH
PARMASL=CELL
IF MULTIOCP=YES START ; *TDEC_MAINQSEMA; FINISH
FINISH ELSE START
INTEGER(ADDR(REQ)+4)=PDISCSNO; ! P_SRCE
REQ_CYLINK=0; ! P_P2== 0 for ok
FASTPON(CELL)
FINISH
CELL=J
REPEAT
DDT_TRLINK=0; ! no transfers in progress
DOMORE:
IF DDT_UQLINK=0 THEN DDT_UQLINK=DDT_LQLINK C
AND DDT_LQLINK=0
->INIT TRANSFER IF DDT_UQLINK#0
DDT_QSTATE=0
IF MULTIOCP=YES START ; *LXN_SEMA; *TDEC_(XNB +0); FINISH
RETURN
FINISH
IF MONLEVEL&4#0 THEN START
DDT_STATS1=DDT_STATS1+1
FINISH
! update failure count
! whilst avoiding overflow
ERRLBE=P_P3&255
IF P_P5&NORMALT=0 THEN SEC STAT=0 ELSE SEC STAT=INTEGER(P_P6+4)
UNRECOVERED=1
IF SSERIES=NO AND SEC STAT&X'08000000'#0 C
THEN UNRECOVERED=SEC STAT&X'F7000000'
IF UNRECOVERED=0 THEN ERRLBE=ERRLBE+1
FAIL=NOT TRANNED
IF SEC STAT=X'10000000' AND BYTEINTEGER(P_P6+8)=CYCLIC CHECK C
THEN FAIL=TRANWITH ERR; ! cyclic check only
CYL=DDT_CURCYL
!
! Note recovered errors stop the chain on the non-failing LBE which
! is normally the page transfer LBE. This block has transfered ok
! the next transfers have not been started. Therefore up the LBE count
! by one and refrain from tagging any transfer as having failed
! thus all necessary requeing should be done including the case when
! the recovery is on the search
!
WHILE CELL#0 CYCLE
REQ==PARM(CELL)
DDT_TRLINK=REQ_REQLINK
IF REQ_LLBP1<=ERRLBE OR REQ_FAULTS>RETRIES(REQ_REQTYPE) START
IF REQ_LLBP1<=ERRLBE THEN REQ_CYLINK=TRAN OK ELSE C
REQ_CYLINK=FAIL
IF REQ_CYLINK#0 THEN START
PKMONREC("PDISC transfer fails",P)
FINISH
IF REQ_REQTYPE=PTACT THEN PTREPLY(REQ,REQ_CYLINK) ELSE C
INTEGER(ADDR(REQ)+4)=PDISCSNO AND FASTPON(CELL)
FINISH ELSE START
REQ_CYLINK=0; ! obliterate old cyl link
IF REQ_FLB<=ERRLBE<REQ_LLBP1 AND UNRECOVERED#0 START
REQ_FAULTS=REQ_FAULTS+1
FINISH
! QUEUE(DDT_UQLINK,CELL,CYL)
LINK==DDT_UQLINK; *JLK_<QUEUE>
FINISH
CELL=DDT_TRLINK
REPEAT
IF SEC STAT<0 START ; ! disc inop
DDT_QSTATE=2
IF MULTI OCP=YES START ; *LXN_SEMA; *TDEC_(XNB +0); FINISH
RETURN
FINISH
->DOMORE
PDA(11): ! inop disc now operable
DDT==RECORD(INTEGER(DITADDR+4*P_P1))
IF MULTI OCP=YES START ; ! grab sema
SEMA=ADDR(DDT_SEMA)
*LXN_SEMA; *INCT_(XNB +0)
*JCC_8,<ISEMAGOT>
SEMALOOP(DDT_SEMA,0)
ISEMAGOT:
FINISH
if ddt_qstate=1 then monitor("PDISC inop disc now operable???")
DDT_TRLINK=0
DDT_CURCYL=0
->DOMORE
!%ROUTINE QUEUE(%INTEGERNAME LINK,%INTEGER CELL,CYL)
!***********************************************************************
!* Queues request in ascending page(ie cyl) order so seek times *
!* are minimised. Prio=0 transfers always go to front however *
!* apart from demand pages at head this is the optimal algorithm *
!* for queues up to 32 in CACM.15.3 MAR 1972 pp177 et seq *
!***********************************************************************
!%RECORD(REQFORM)%NAME REQ,ENTRY,NEXTREQ
!%INTEGER NEXTCELL,AD
! REQ==PARM(CELL)
QUEUE:
NEXTCELL=LINK
ENTRY==PARM(NEXTCELL)
!
! Put this transfer at head of the queue if:-
! A) the queue is empty
! B) this transfer lies between current cyl and first transfer.
! this case includes all transfers arriving on current cyl since
! CURRENt head posn is kept as trck 0 page 0 of current cyl
IF NEXTCELL=0 OR CYL<ENTRY_CYL START
LINK=CELL
REQ_REQLINK=NEXTCELL; ! prio transfer to front
! %RETURN
*J_TOS
FINISH
!
! Handcode the cycle keeping XNB to entry and CTB to nextreq
! also keep cyl in ACC and copy ADDR(PARM(0)) to AD
!
*LXN_ENTRY+4; *LSS_CYL
*ICP_(XNB +5); ! ENTRY_CYL
*JCC_8,<QONCYL>
QCYCLE:
*LB_(XNB +8); ! ENTRY_REQLINK
*JAT_12,<QEXIT>
*MYB_PCELLSIZE; *ADB_PARM0AD
*LCT_B ; *ICP_(CTB +5); ! NEXTREQ_CYL
*JCC_4,<QEXIT>
*LXN_B ; *JCC_7,<QCYCLE>; ! CC still set
*J_<QONCYL>
QEXIT:
*LSS_(XNB +8); ! ENTRY_REQLINK=NEXTCELL
*LCT_REQ+4; *ST_(CTB +8); ! =REQ_REQLINK
*LSS_CELL; *ST_(XNB +8)
! %CYCLE
! ->QONCYL %IF CYL=ENTRY_CYL
! NEXTCELL=ENTRY_REQLINK
! %EXIT %IF NEXTCELL=0
! NEXTREQ==PARM(NEXTCELL)
! %EXIT %IF NEXTREQ_CYL>CYL
! ENTRY==NEXTREQ
! %REPEAT
! REQ_REQLINK=NEXTCELL
! ENTRY_REQLINK=CELL
! %RETURN
*J_TOS
QONCYL:
*LSS_(XNB +3); *LB_CELL
*STB_(XNB +3); *LCT_REQ+4
*ST_(CTB +3)
! REQ_CYLINK=ENTRY_CYLINK
! ENTRY_CYLINK=CELL
*J_TOS
!%END
ROUTINE PTREPLY(RECORD (REQFORM)NAME REQ,INTEGER FAIL)
!***********************************************************************
!* Replies to all local controllers waiting for a page transfer *
!* usually one only but possibly several. This code will go inline *
!* for the normal case when alltransfers in chain are errorfree *
!***********************************************************************
RECORD (PARMXF)NAME REP
INTEGER L,J,STOREX
STOREX=REQ_STOREX
IF FAIL>1 THEN START ; ! clear the page
J=REQ_COREADDR
L=EPAGESIZE*1024
*LDTB_X'18000000'
*LDB_L
*LDA_J
*MVL_L =DR ,0,0
FINISH
IF MULTIOCP=YES THEN START
*INCT_(STORESEMA)
*JCC_8,<SSEMAGOT>
SEMALOOP(STORESEMA,0)
SSEMAGOT:
FINISH
L=STORE(STOREX)_FLAGLINK
STORE(STOREX)_FLAGLINK=L&X'3FFF0000'; ! clear out flags& link
IF MULTIOCP=YES START ; *TDEC_(STORESEMA); FINISH
L=L&X'FFFF'
UNTIL L=0 CYCLE
REP==PARM(L)
IF FAIL#0 THEN REP_DEST=REP_DEST!1 AND REP_P3=FAIL
J=REP_LINK
FASTPON(L)
L=J
REPEAT
RETURN PPCELL(CELL) IF FAIL#2; ! headcell back to freelist
END
END
IF SFC FITTED=YES THEN START
ENDOFLIST
RECORDFORMAT PONOFF(INTEGER DEST,SRCE, C
(INTEGER P1,P2,P3,P4 OR C
INTEGER INTACT,EPAGE,STORI,PRI), C
INTEGER P5,P6,LINK)
EXTERNALROUTINE DRUM(RECORD (PONOFF)NAME P)
! first the necessary recordformats:-
RECORDFORMAT CONTABF(INTEGER ISCONTREG, BATCH, SEMA, MARKAD, C
INTEGERNAME CRESP0)
! one of these for each sfc.
! GLOBALLY DEFINED DATAFORMATS:-
RECORDFORMAT ESQBF(INTEGER DEST,SRCE,INTACT,EPAGE,STORI,P4,C
LONGINTEGER LSAW,INTEGER Q)
! PONOFF MAPS ONTO ESQBF FOR SENDING TO DISC IN EVENT OF FAILURE
! ESQBF = extended sector queue block format.
RECORDFORMAT STRF(LONGINTEGER LSAW,INTEGER SRESP0,SRESP1)
! stream block within a communication area.
RECORDFORMAT ESCBF(INTEGER HQ, LQ, SAW0, PAWBS, ADDSTRS)
! ESCBF = Extended Sector Control block, one for each extended
! sector on each drum. HQ & LQ the high and low priority
! queues, SAW0 - everything except track for first sector
! in the extended sector, PAWBS - the bits to be inserted
! in the paw for this extended sector.
RECORDFORMAT DTABF(INTEGER NSECS, HALFINTEGER PTM, C
BYTEINTEGER LOGI, CONTI, C
INTEGER SECLIM, NEXT, STATE, C
INTEGERNAME MARK, PAW, PIW, C
RECORD (ESCBF)ARRAY ESCBS(0:31))
! one of theses for each drum. Allows max of 16 extended sectors per
! track i.e. 2K page minimum.
! NSECS - number of (1K) sectors used on this drum
! SECLIM - no. of (1K) sectord used on each track, max for integral
! number of esecs on track
! NEXT - address of next entry in dtable, 0=>last
! LOGI - logtab index, unique to each drum
! CONTI - contab index relevant to this drum.
! STATE - msb=0 => auto
! b 0:1 = time clock 0=> time out
! b 2:7 = no. of outstanding esecs
! %NAMES - for rapid access to relevant parts of communication area.
! ESCBS - one for each esector queue.
RECORDFORMAT LOGTABF (INTEGER TOT,RECOV, HALFINTEGER FAIL,TOUTS)
RECORDFORMAT COMAF(INTEGER MARK, PAW, COUNTS, DRUMRQ, CSAW1, C
CSAW2, CRESP1, CRESP2, INTEGERARRAY PAWS, PIWS(0:7))
RECORD (COMAF)NAME CCA,CCA0
ROUTINESPEC ACTIVATE(RECORD (DTABF)NAME DT,RECORD (ESCBF)NAME ES, C
INTEGERNAME Q)
!%ROUTINESPEC CLAIM(%INTEGERNAME N)
ROUTINESPEC SERV(RECORD (DTABF)NAME DTENT, INTEGER ESEC)
ROUTINESPEC DOBR
ROUTINESPEC TAKE CRESPS(RECORD (CONTABF)NAME CTENT)
ROUTINESPEC PSTATUS(RECORD (DTABF)NAME DTENT)
ROUTINESPEC FAIL ALL(RECORD (DTABF)NAME DTENT)
ROUTINESPEC PDATM
ROUTINESPEC PTM(RECORD (DTABF)NAME DTENT)
CONSTSTRING (21) PTMS="port trunk mechanism"
ROUTINESPEC REPORT(RECORD (DTABF)NAME DTENT, C
INTEGER ESEC, STRING (47) S)
ROUTINESPEC INITIALISE(RECORD (PARMF)NAME P)
ROUTINESPEC LOAD MPROG(INTEGER PT)
OWNINTEGER IDENT=M'DRUM', IFIER=M'36AC'
! FIRST ENTRY IN DRUM TABLE REFERENCED BY:-
OWNRECORD (DTABF)NAME DTAB0
! DEFINE THE CONTROLLER TABLE BY:-
OWNRECORD (CONTABF)ARRAYNAME CONTABA
OWNRECORD (CONTABF)ARRAYFORMAT CONTABAF (1:8)
OWNRECORD (CONTABF)NAME CONTAB1; ! ONTO 1ST(OFTEN ONLY) EL OF
! ARRAY CONTABA
RECORD (CONTABF)NAME CONTAB
OWNINTEGER CONTMAX=0; ! MAX INDEX IN CONTAB.
OWNRECORD (LOGTABF)ARRAY LOGTAB(0:15); ! I.E. MAX OF 16 DRUMS CATERED FOR ??
RECORD (LOGTABF)NAME LOG; ! FOR MAPPING ONTO LOGTAB
! MAIN ACTIVITY CONTROLLING SWITH:-
SWITCH ACTIVITY(0:10); ! 0 => INITIALISE
! 1 => READ
! 2 => WRITE
! 3 => INTERRUPT
! 4 PERFORMANCE LOG AND RESET
! 5 = POLLING (NEEDED FOR ERRORS)
! 6 = SPARE
! 7 = SAC RECONFIGURE
! 8 spare
! 9 = 5 minute tick after format
! 10 = reinit SFC
! SCALAR VARIABLES
INTEGER BRFLAG; ! SET #0 TO INDICATE BITS ADDED TO PAWS SINCE LAST
! BATCH REQUEST
INTEGER WBIT, DEVAD, DRUM, SECLIM, TRACK, ESEC
INTEGER ESQBI, WQ
RECORD (DTABF)NAME DTENT
RECORD (ESCBF)NAME ESCB
RECORD (STOREF)NAME STOR
RECORD (ESQBF)NAME ESQB
INTEGERNAME Q,Q2; ! REFERENCES EITHER HQ OR LQ
! NOW SCALARS CONCERNED WITH TERMINATION
! DETECTION
INTEGERNAME CSEMA; ! CONTROLLER SEMAPHORE FOR DUALS
INTEGER EPMASK, COMPLETED, MASK, PIW
INTEGER CONTI, CREG; ! LOOK FOR CRESP FOLLOWING INTERRUPT
INTEGER STATE; ! USED DURING CLOCK TICK
! SOME IMPORTANT OWNS:-
OWNINTEGER EPN=0; ! NUMBER OF SECTORS PER EPAGE
OWNINTEGER EPNBITS=0; ! EPN 1S LEFT JUSTIFIED
CONSTINTEGER DSN=X'28'; ! SERVICE NUMBERS
CONSTINTEGER DSNSRCE=DSN<<16; ! ABOVE<<16 FOR PON & POFF
CONSTSTRING (8) AAD="&& DRUM "
STRING (6) SFCPT
! CONSTANTS USED AT MAIN LEVEL
CONSTINTEGER SETWBIT=X'01000000'; ! STREAM FLAG BIT FOR WRITING
CONSTINTEGER S=X'80000000'; ! ACTIVE INDICATOR ON Q HEADS
CONSTINTEGER SAC CONTROL=X'40000800'; ! ADD IN PT TO GIVE CONTROL REG
CONSTINTEGER NT=X'00800000'
CONSTINTEGER TROUBLE=X'00490000'; ! in stream responses
CONSTINTEGER ADV=X'00040000'; ! advisory status present
! VARIABLES USED IN TIMING FRQUENCY OF STROBES.
CONSTLONGINTEGER INTERVAL=6000; ! APPROX HALF A REV.
CONSTINTEGER TOUT LIMIT=5; ! MAX TIMEOUTS BEFORE ABANDONING
OWNLONGINTEGER PAST=0
LONGINTEGER PRESENT
INTEGER I,J,SS,AD,PT,PTX
INTEGER ADPTS; ! ADDR(AMTPTS(AMTX)) FOR WRITES
BRFLAG=0; ! NO BATCH REQUEST NEEDED - YET!
IF MONLEVEL&2#0 AND KMON&LONGONE<<DSN#0 THEN C
PKMONREC("DRUM:",P)
->ACTIVITY(P_DEST&X'FFFF')
ACTIVITY(0):
INITIALISE(P); ! ONCE ONLY
P_DEST=X'A0001'; P_SRCE=0
P_INTACT=DSNSRCE+5; ! P_P1!
P_EPAGE=2; ! REQUEST A POLL EVERY 2 SECS
PON(P)
RETURN
ACTIVITY(1):
WBIT=0; ! A READ REQUEST
ADPTS=0
->RW
ACTIVITY(2):
WBIT=SETWBIT; ! A WRITE REQUEST
ADPTS=P_PRI ;! ADDR(AMTPTS(AMTX))
RW:
DTENT==DTAB0
! DEVAD=P_EPAGE*EPN; ! A LOGICAL SECTOR ADDRESS.
! %WHILE DEVAD>=DTENT_NSECS %CYCLE
! DEVAD=DEVAD-DTENT_NSECS
! DTENT==RECORD(DTENT_NEXT); ! ?? GUARANTEE NEVER OFF LIMIT?
! %REPEAT
*LXN_P+4
*LSS_(XNB +3); ! P_EPAGE
*IMY_EPN
*LCT_DTENT+4
WAGN: ! WHILE LABEL
*ICP_(CTB +0)
*JCC_4,<WXIT>
*ISB_(CTB +0)
*LCT_(CTB +3)
*J_<WAGN>
WXIT: *ST_DEVAD
*STCT_DTENT+4
! DRUM NOW SET & DEVAD RELATIVE TO IT.
IF DTENT_STATE<0 START ; ! DRUM NOT OPERABLE!
P_DEST=P_SRCE&(¬S)
P_SRCE=DSNSRCE
P_EPAGE=-1; ! FAILED
PON(P); ! TO CALLER "NO CAN DO"
RETURN
FINISH ELSE START
IF MULTIOCP=YES THEN START
CSEMA==CONTABA(DTENT_CONTI)_SEMA
*INCT_(CSEMA)
*JCC_8,<CSEMAGOT>
SEMALOOP(CSEMA,2)
CSEMAGOT:
FINISH
SECLIM=DTENT_SECLIM
! TRACK=DEVAD//SECLIM
! ESEC=(DEVAD-TRACK*SECLIM)//EPN
*LSS_DEVAD; *IMDV_SECLIM; *ST_TRACK
*LSS_TOS ; *IDV_EPN; *ST_ESEC
! SET UP ESQB AND LINK INTO ESCB Q
ESCB==DTENT_ESCBS(ESEC)
ESQBI=NEWPPCELL
ESQB==PARM(ESQBI)
! COPY PONOFF VALUES TO ESQB
ESQB_INTACT=P_INTACT
ESQB_DEST=P_SRCE&(¬S); ! ONLY USED IN EVENT OF FAILURE.
ESQB_SRCE=P_DEST
ESQB_EPAGE=P_EPAGE
ESQB_STORI=P_STORI
ESQB_P4=ADPTS; ! =0 FOR READ
ESQB_LSAW=LENGTHENI(ESCB_SAW0+WBIT+TRACK)<<32C
+STORE(P_STORI)_REALAD&X'0FFFFFFF'
! PLACE ESQB IN APPROPRIATE Q.
IF WBIT=0=P_PRI THEN Q==ESCB_HQ ELSE Q==ESCB_LQ
IF Q>=0 START ; ! NO TRANSFER IN PROGRESS
ESQB_Q=Q
Q=ESQBI
FINISH ELSE START
WQ=Q&(¬S); ! ACTIVE Q.
Q2==PARM(WQ)_LINK
ESQB_Q=Q2
Q2=ESQBI
FINISH
IF ESCB_HQ!ESCB_LQ>0 THEN ACTIVATE(DTENT,ESCB,Q)
! NOTHING WAS ACTIVE BEFORE.
IF MULTIOCP=YES THEN CSEMA=-1
FINISH
! THE REQUEST IS NOW CORRECTLY ENTERED.
P_DEST=0; ! INDICATING NO REPLY ?????????
! GO ON TO LOOK FOR TERMINATIONS ONLY IF
! SIGNIFICANT TIME HAS PASSED.
SERVICE:
*RRTC_0
*SHS_1
*ST_PRESENT
IF PRESENT<PAST+INTERVAL START
! NOT LONG ENOUGH TO BE WORTH LOOKING
DOBR IF BRFLAG#0
RETURN
FINISH
! NEXT PART SERVICES ALL DRUMS FOLLOWING
! POFF'D REQUESTS AND INTERRUPTS.
! ONLY DEAL WITH COMPLETE ESECS.
DTENT==DTAB0
CYCLE
IF MULTIOCP=YES THEN START
CSEMA==CONTABA(DTENT_CONTI)_SEMA
*INCT_(CSEMA)
*JCC_8,<CSEMAGOT2>
SEMALOOP(CSEMA,2)
CSEMAGOT2:
FINISH
PIW=DTENT_PIW; ! COPY OUT PIW FOR THIS DRUM
IF PIW#0 THEN START
EPMASK=EPNBITS
! COMPLETED=0
! MASK=EPMASK
! %WHILE PIW#0 %CYCLE
! %IF PIW&EPMASK=EPMASK %START
! COMPLETED=COMPLETED!MASK
! %FINISH
! MASK=MASK>>EPN
! PIW=PIW<<EPN
! %REPEAT
!
! CAN HANDCODE CUNNINGLY WITHOUT A LOOP PROVIDED THERE ARE ONLY 24
! BITS USED IN PIW . ALSOL ASSUMES EPN=4
!
*LSS_PIW; *USH_-8
*ST_B ; *USH_-2
*AND_B ; *ST_B
*USH_-1; *AND_B
*AND_X'00111111'; ! BTM BIT OF EACH QUARTET SET
! IF QUARTET ORIGINALLY X'F'
*IMY_15; ! (2**EPN-1)
*USH_8; *ST_COMPLETED
! COMPLETED CONTAINS BITS FOR ALL
! COMPLETED ESECS
IF COMPLETED#0 START
! CLAIM(DTENT_MARK)
! DTENT_PIW=DTENT_PIW!!COMPLETED
! DTENT_MARK=-1; ! RELEASE CA
*LXN_DTENT+4; ! XNB TO DTENT
*INCT_((XNB +5)); ! DTENT_MARK
*JCC_8,<MARKGOT>
SEMALOOP(DTENT_MARK,2)
*LXN_DTENT+4
MARKGOT:
*LSS_COMPLETED
*NEQ_((XNB +9))
*ST_(DR )
*ST_PIW; ! ANY BITS LEFT OVER
*LSS_-1; *ST_((XNB +5))
! PIW BITS CLEARED
ESEC=0
UNTIL COMPLETED=0 CYCLE
! SERV(DTENT,ESEC) %UNLESS COMPLETED>0
! MSB=0 => EPN MS BITS=0
! COMPLETED=COMPLETED<<EPN
!
! HANDCODE SO AS TO AVOID GOING ROUND CYCLE FOR EMPTY SECYORS
!
*LSS_COMPLETED; *SHZ_B
*USH_4; *ST_COMPLETED
*LSS_B ; *USH_-2; *IAD_ESEC; *ST_ESEC
SERV(DTENT,ESEC)
ESEC=ESEC+1
REPEAT
FINISH ; ! WITH THAT DRUM
IF PAST=0 AND PIW#0 START ; ! WAS INT BUT NOT IDLE
!
! CHECK TRANSFERS OUTSTANDING FOR FAILURES
!
AD=DTENT_ESCBS(0)_ADDSTRS+8
I=0; SS=0
WHILE PIW#0 CYCLE
! %WHILE PIW>0 %THEN I=I+1 %AND PIW=PIW<<1
! PIW=PIW<<1
*LSS_PIW; *SHZ_B
*ADB_I; *STB_I
*USH_1; *ST_PIW
SS=SS!INTEGER(AD+16*I)
I=I+1
REPEAT
IF SS&TROUBLE#0 THEN START
IF MULTIOCP=YES THEN RESERVE LOG
PDATM; NEWLINES(2)
PRINTSTRING(PTMS); NEWLINE
PTM(DTENT); NEWLINE
PSTATUS(DTENT)
IF MULTIOCP=YES THEN RELEASE LOG
IF DTENT_PAW#0 START
BRFLAG=1
CONTABA(DTENT_CONTI)_BATCH=1
FINISH
FINISH
FINISH
FINISH
IF MULTIOCP=YES THEN CSEMA=-1
EXITIF DTENT_NEXT=0
DTENT==RECORD(DTENT_NEXT)
REPEAT
PAST=PRESENT; ! UPDATE STROBE CLOCK
! ONLYREMAINS TO ISSUE BATCH REQUEST
! IF NEEDED.
DOBR IF BRFLAG#0
RETURN ; ! TO SUPERVISOR !!!!!!!!!!!!!!!!!!!
ACTIVITY(3): ! AN INTERRUPT HAS OCCURRED, SOME DRUM IDLE OR
! A CONTROLLER RESPONSE, FORMER DEALT WITH
! UNDER "SERVICE:".
CREG=P_INTACT<<16!SAC CONTROL
CONTI=1; CONTAB==CONTAB1
WHILE CONTAB_ISCONTREG#CREG CYCLE
CONTI=CONTI+1
CONTAB==CONTABA(CONTI)
REPEAT
TAKE CRESPS(CONTAB) IF CONTAB_CRESP0#0
PAST=0; ! FORCES CLOCK UPDATE AND STROBE
->SERVICE
ACTIVITY(4): ! Print and reset all performance counts.
IF MONLEVEL&4#0 THEN START
IF MULTIOCP=YES THEN RESERVE LOG
NEWLINES(2)
PDATM
PRINTSTRING(" PERFORMANCE LOG")
NEWLINES(2)
PRINTSTRING(" SFC DRUM TRANSFER COUNTS")
NEWLINE
PRINTSTRING(PTMS." attempted failed recovrd timed out")
NEWLINE
! track through each entry in DTAB
DTENT==DTAB0
DRUM=0
CYCLE
PTM(DTENT)
SPACES(7)
LOG==LOGTAB(DRUM)
PRINTSTRING(HTOS(LOG_TOT,8))
SPACES(3)
PRINTSTRING(HTOS(LOG_FAIL,4))
SPACES(5)
PRINTSTRING(HTOS(LOG_RECOV,4))
SPACES(5)
PRINTSTRING(HTOS(LOG_TOUTS,4))
NEWLINE
LOG=0; ! RESET ALL COUNTS
EXIT IF DTENT_NEXT=0
DTENT==RECORD(DTENT_NEXT)
DRUM=DRUM+1
REPEAT
NEWLINE
IF MULTIOCP=YES THEN RELEASE LOG
FINISH
RETURN
ACTIVITY(5): ! PERIODIC CLOCK TICK (4SECS)
! USED FOR TIMEOUT DETECTION+ SERVICE
DTENT==DTAB0
CYCLE
IF MULTIOCP=YES THEN START
CSEMA==CONTABA(DTENT_CONTI)_SEMA
*INCT_(CSEMA)
*JCC_8,<CSEMAGOT3>
SEMALOOP(CSEMA,2)
CSEMAGOT3:
FINISH
STATE=DTENT_STATE
IF STATE&(¬3)>0 START ; ! IF AUTO & ACTIVE
STATE=STATE-1; ! DECREMENT TIME CLOCK
IF STATE&3=0 START ; ! A TIME OUT !
IF MULTIOCP=YES THEN RESERVE LOG
OPMESS("Drum ".HTOS(DTENT_PTM,3)." time out ")
NEWLINES(4)
PRINTSTRING("Drum time out")
NEWLINE
! CLEAR ABNT BY READING STATUS
PSTATUS(DTENT)
! ? PAW BITS WHICH HAVE BEEN IGNORED
IF MULTIOCP=YES THEN RELEASE LOG
LOG==LOGTAB(DTENT_LOGI)
LOG_TOUTS=LOG_TOUTS+1
IF LOG_TOUTS<TOUT LIMIT START
IF DTENT_PAW#0 START
BRFLAG=1
CONTABA(DTENT_CONTI)_BATCH=1;! FORCE BATCH REQUEST
FINISH
PAST=0; ! FORCE SERVICE
STATE=STATE&(¬3)+2; ! RESET TIME CLOCK
FINISH ELSE STATE=S AND FAIL ALL(DTENT)
FINISH ; ! DEALING WITH TIME OUT
DTENT_STATE=STATE; ! UPDATE STATE
FINISH ; ! WITH THIS DRUM AND
IF MULTIOCP=YES THEN CSEMA=-1
EXIT IF DTENT_NEXT=0
DTENT==RECORD(DTENT_NEXT)
REPEAT
->SERVICE
ACTIVITY(7): ! reconfigure SAC (P_P2=SAC)
I=P_P2
P_P2=0
DTENT==DTAB0
CYCLE
IF DTENT_PTM>>8=I AND DTENT_STATE>=0 START ; ! auto
FAIL ALL(DTENT); ! abandon drum
FINISH
EXIT IF DTENT_NEXT=0
DTENT==RECORD(DTENT_NEXT)
REPEAT
->ROUT
ACTIVITY(10): ! reinit SFC (P_P1=pt,P_P2=old pt if >=0)
SFCPT="SFC ".HTOS(P_P1,2)
PT=P_P1
PTX=P_P2
IF PTX>=0 AND PTX#PT START ; ! SAC switch
UNLESS 0<=PT<=X'1F' AND 0<=PTX<=X'1F' C
AND BYTEINTEGER(COM_CONTYPEA+PT)=0 AND C
BYTEINTEGER(COM_CONTYPEA+PTX)=1 THEN C
OPMESS("SFC old/new pt???") AND ->ROUT
FINISH ELSE START
UNLESS 0<=PT<=X'1F' AND BYTEINTEGER(COM_CONTYPEA+PT)=1 C
THEN OPMESS("Cannot reinit ".SFCPT) AND ->ROUT
FINISH
DTENT==DTAB0
J=-1
CYCLE
IF DTENT_PTM>>4=PT START
IF DTENT_STATE>=0 THEN FAIL ALL(DTENT); ! abandon drum if auto
IF PTX>=0 AND PTX#PT THEN DTENT_PTM=DTENT_PTM&15!PT<<4; ! SAC switch
J=DTENT_CONTI; ! remember controller
FINISH
EXIT IF DTENT_NEXT=0
DTENT==RECORD(DTENT_NEXT)
REPEAT
IF J<0 THEN OPMESS("No drums on ".SFCPT) AND ->ROUT
IF PTX>=0 AND PTX#PT START ; ! SAC switch
CONTABA(J)_ISCONTREG=SAC CONTROL!PT<<16; ! reset IS reg
BYTEINTEGER(COM_CONTYPEA+PT)=1
BYTEINTEGER(COM_CONTYPEA+PTX)=0
FINISH
IF P_P3>=0 START ; ! reload microprogram
LOAD MPROG(PT)
OPMESS(SFCPT." mprog loaded")
FINISH
I=SAC CONTROL!PT<<16
*LB_I; *LSS_2; *ST_(0+B ); ! master clear
WAIT(1)
SLAVESONOFF(0); ! slaves off
J=CONTABA(J)_MARKAD
CCA0==RECORD(REAL0ADDR)
CCA0_MARK=-1
CCA0_PAW=X'04000000'; ! do controller req
CCA0_CSAW1=X'32000004'
CCA0_CSAW2=REALISE(J)
CCA0_CRESP1=0
*LXN_REAL0ADDR; *INCT_(XNB ); *TDEC_(XNB )
CCA==RECORD(J)
CCA_MARK=-1
WAIT(1)
*LXN_J
L1: *INCT_(XNB ); *JCC_7,<L1>
CCA_PAW=X'04000000'
CCA_CRESP1=0
*LB_I; *LSS_1; *ST_(0+B )
*LXN_J; *TDEC_(XNB )
WAIT(5)
IF CCA0_PAW#0 THEN OPMESS("Failed to reinit ".SFCPT) AND ->ROUT
CCA=0
CCA_MARK=-1
DTENT==DTAB0; ! mark drums auto & inactive
CYCLE
IF DTENT_PTM>>4=PT START
*LXN_CCA+4; ! connect interface
*INCT_(XNB +0)
*JCC_8,<ISEMAGOT>
SEMALOOP(CCA_MARK,2)
ISEMAGOT:
J=(DTENT_PTM&15)<<21
CCA_PAW=X'04000000'
CCA_CSAW1=X'3A000004'!J
CCA_DRUMRQ=X'05000000'!J
CCA_CRESP1=0
*LB_I; *LSS_1; *ST_(0+B )
CCA_MARK=-1
FOR PTX=1,1,COM_INSPERSEC CYCLE
EXIT IF CCA_CRESP1#0
REPEAT
IF CCA_CRESP1#NT THEN OPMESS(SFCPT." connect fails") C
AND ->ROUT
IF P_P4>0 START ; ! format drum
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<FSEMAGOT>
SEMALOOP(CCA_MARK,2)
FSEMAGOT:
CCA_PAW=X'04000000'
CCA_CSAW1=X'3A000000'!J+DTENT_NSECS
CCA_DRUMRQ=X'01000000'!J
CCA_CRESP1=0
*LB_I; *LSS_1; *ST_(0+B )
CCA_MARK=-1
FOR J=1,1,COM_INSPERSEC*250*10 CYCLE
EXIT IF CCA_CRESP1#0
REPEAT
IF CCA_CRESP1#NT THEN OPMESS(SFCPT." format fails") C
AND ->ROUT
OPMESS(SFCPT." formatted OK")
FINISH
*LXN_CCA+4
*INCT_(XNB +0)
*JCC_8,<FSEMAGOT1>
SEMALOOP(CCA_MARK,2)
FSEMAGOT1:
CCA_CRESP1=0
CCA_PAW=0
CCA_CSAW1=0
CCA_DRUMRQ=0
CCA_MARK=-1
DTENT_STATE=0 UNLESS P_P4>0; ! wait for active mem. timeout after format
DTENT_PIW=0
DTENT_PAW=0
FINISH
EXIT IF DTENT_NEXT=0
DTENT==RECORD(DTENT_NEXT)
REPEAT
SLAVESONOFF(-1); ! slaves back on
OPMESS(SFCPT." reinitialised ok")
IF P_P4>0 START ; ! formatted so wait a while
P_DEST=X'A0002'
P_P1=DSNSRCE!9
P_P2=300; ! 5 minutes
P_P3=PT
PON(P)
FINISH
RETURN
ACTIVITY(9): ! tick after format
DTENT==DTAB0
CYCLE
IF DTENT_PTM>>4=P_P1 AND DTENT_STATE<0 THEN DTENT_STATE=0; ! release drum
EXIT IF DTENT_NEXT=0
DTENT==RECORD(DTENT_NEXT)
REPEAT
OPMESS("SFC ".HTOS(P_P1,2)." back in service")
RETURN
ROUT:
UNLESS P_SRCE=0 START
I=P_SRCE
P_SRCE=P_DEST
P_DEST=I
PON(P)
FINISH
RETURN
ROUTINE LOAD MPROG(INTEGER PT)
ROUTINESPEC WAITAFB(INTEGER ISDIAG); ! WAIT FOR ACKNOWLEDGE FROM B
! SFC MICROPROGRAM VERSION 941 DATED 29NOV78
!
! THIS VERSION FIRST USED IN CHOPSUPE 18E
! PREVIOUSLY VSN 940 USED FROM 15JAN78
ENDOFLIST
CONSTINTEGERARRAY UPA(0:X'200')=C
X'3006E841',X'0C829041',X'00018782',X'00032C22',
X'00014003',X'00031874',X'22601141',X'0001D041',X'86803951',
X'86858041',X'22601141',X'A0103941',X'00029041',X'0001004C',
X'86803901',X'0881E841',X'A0136841',X'0F00E8C1',X'22605041',
X'0002DF62',X'00051844',X'00000044',X'0000F4A3',X'00028042',
X'8004F462',X'80801157',X'2260417A',X'86803941',X'30003906',
X'00008841',X'0000907E',X'A00B3840',X'0000A879',X'0000115E',
X'0810E87B',X'0000A876',X'00010079',X'0002E876',X'0000A873',
X'0000A872',X'0002780B',X'0001D07D',X'00050873',X'0000F072',
X'0000F871',X'0000A86C',X'0000A86B',X'0000A86A',X'50003941',
X'0002C041',X'00001940',X'00031846',X'A0705815',X'0000EA7D',
X'00028003',X'00031F42',X'000284E7',X'000004E7',X'0DE00034',
X'2260212C',X'0C81C833',X'0001D82F',X'0001B823',X'81040041',
X'0E024041',X'00012041',X'000209C1',X'84040041',X'0001E9E8',
X'00000040',X'0001B045',X'0001E045',X'000251C5',X'0001F9C6',
X'000201C6',X'86803961',X'64103960',X'8406D041',X'6390395E',
X'8400395D',X'84003941',X'00032AC1',X'0002F84A',X'8400393A',
X'000000C1',X'80000041',X'00000402',X'0000F83E',X'2260111A',
X'0DE00041',X'00008042',X'0000E87C',X'0000F056',X'00000482',
X'00000071',X'0002C041',X'00000040',X'0001D045',X'0000116F',
X'00004171',X'0002E87C',X'80802174',X'06808841',X'00000764',
X'00027041',X'20E00041',X'00091841',X'0000800F',X'0002E483',
X'0002F841',X'00032861',X'00026841',X'0002C02B',X'80048036',
X'22604149',X'00036040',X'22601136',X'86050852',X'000249CF',
X'3007003B',X'2260113B',X'0001003F',X'0001084D',X'0002F0C1',
X'80000041',X'0001EC02',X'0000020C',X'80802141',X'000000C1',
X'00000442',X'0002C00F',X'00000204',X'00011812',X'84050841',
X'0001E9C1',X'22601141',X'0001D041',X'86803941',X'A0103941',
X'00023041',X'00023841',X'0000A041',X'20E0113B',X'00008841',
X'0DE00036',X'00026041',X'80003941',X'00026839',X'000080C1',
X'80026841',X'0F80003A',X'0000115A',X'0000803C',X'0000A8E5',
X'0000FAC1',X'00031041',X'0003302A',X'0000A02B',X'0000F82C',
X'0D900007',X'00044141',X'820CE841',X'090890C6',X'2262E483',
X'81840041',X'00011816',X'00044141',X'000C00C1',X'8006C041',
X'0C826840',X'00015007',X'00016008',X'81857782',X'00011815',
X'00014041',X'0001200C',X'000518BF',X'00014841',X'0002E484',
X'00000024',X'0002C041',X'00003940',X'84826802',X'00015805',
X'00016806',X'0000EF82',X'00000022',X'0001400A',X'00048838',
X'00051820',X'20E33442',X'00002143',X'80800241',X'00002128',
X'000D98C1',X'80040041',X'80801141',X'50003941',X'0F03852D',
X'00005AC1',X'00033840',X'0901004D',X'0900F04C',X'0900F04B',
X'0900F84A',X'0900F849',X'0900E848',X'0900E847',X'09822038',
X'84003941',X'0002383A',X'30040034',X'00007041',X'0000833B',
X'8106F841',X'0E024041',X'8186C041',X'0E021040',X'00000020',
X'0000833D',X'A0600908',X'00026841',X'A060110D',X'0003304C',
X'80808040',X'00002152',X'00002146',X'20E10027',X'00000001',
X'20E10829',X'0000A062',X'00006288',X'20E2E8C1',X'0000CC42',
X'00002142',X'0000580B',X'20E128C1',X'0002AE87',X'0000B662',
X'20E0213F',X'80801141',X'50003941',X'20E00035',X'000231FA',
X'0000EF67',X'00042141',X'000D4841',X'848490C1',X'80022041',
X'00000405',X'0000F044',X'80801141',X'50003941',X'00001916',
X'60100041',X'0C880402',X'00028841',X'00015786',X'0002C041',
X'0000B040',X'0DE13014',X'00031841',X'0000A5AE',X'22614012',
X'20E23041',X'00001141',X'84003941',X'0002380E',X'0D9220C1',
X'C1E01141',X'8206F041',X'30003941',X'21E01141',X'0001C041',
X'86803941',X'30003941',X'8504C041',X'20E04141',X'00014841',
X'44B2F041',X'0C840402',X'850400C2',X'00029001',X'20E01141',
X'00015742',X'00028041',X'60303919',X'00000545',X'00000443',
X'000231CC',X'00000545',X'80802149',X'00000443',X'80801141',
X'50003904',X'0000002A',X'00000041'(3),X'0000A54F',X'000231C1',
X'8402B765',X'5D09E841',X'0E857CE3',X'8500B841',X'000404C2',
X'0002380A',X'22200041',X'209890C1',X'0006FC42',X'00004147',
X'0000A4E3',X'80802141',X'A0100084',X'20E230C1',X'00001141',
X'8400391D',X'22100041',X'0004E0C1',X'09002141',X'80040041',
X'00011CF3',X'0E021D22',X'0F0080C2',X'30048038',X'8004F6E2',
X'0DE22039',X'0880A041',X'85055D66',X'44B00583',X'00022841',
X'0000E843',X'0C89A041',X'00016041',X'20E23041',X'00001141',
X'84003941',X'0000D041',X'80801141',X'50003944',X'818220C1',
X'00001141',X'8000395F',X'A0636841',X'00019841',X'0002D841',
X'000197A8',X'8106C041',X'00017840',X'00001943',X'A0500941',
X'00007041',X'8504BCD8',X'8080EAC2',X'81057805',X'00031041',
X'00033341',X'00002141',X'0001E841',X'000000C1',X'00016C47',
X'8584A5B4',X'44B08041',X'5C895DF0',X'81040041',X'0E90062F',
X'81801142',X'00002108',X'8584D841',X'61603941',X'64B17041',
X'0C86C041',X'000160C0',X'0000A079',X'800402C1',X'08800070',
X'2220F041',X'20980051',X'0904A032',X'0E840041',X'C1E01151',
X'81801141',X'00008615',X'64B005C7',X'0C840041',X'C2E17041',
X'669AC041',X'61183940',X'0000A06A',X'0000000F',X'C162C041',
X'66983940',X'0000A066',X'00000013',X'808802C1',X'00031041',
X'0003306D',X'30003941',X'21E01141',X'0001C041',X'86803941',
X'0001F041',X'80040046',X'0002C041',X'81003940',X'00000007',
X'82001141',X'80003909',X'0880C1C1',X'84003941',X'85854841',
X'20E04141',X'44B17041',X'0C855C02',X'858550C2',X'00029001',
X'20E01141',X'60303941',X'44B00742',X'00028041',X'0C86C041',
X'000162C0',X'00000047',X'82000763',X'00000642',X'0002F82F',
X'00001141',X'81003941',X'00022041',X'0000A041',X'20E23041',
X'00001141',X'84003941',X'80801141',X'50003941',X'00001941',
X'00031841',X'00023CE7',X'00009442',X'A0104144',X'808004E4',
X'00002141',X'00000084',X'221000C3',X'00031B41',X'0000ED65',
X'00051B41',X'00002141',X'00000041',X'80056CE6',X'0E021D28',
X'0F01E8C1',X'00031EE2',X'300485CC',X'00000569',X'8201E8C1',
X'00001141',X'80003956',X'3005E841',X'0000E0C1',X'0DE22041',
X'0E908041',X'C2601141',X'30003941',X'22601141',X'0002F041',
X'0001C041',X'86803941',X'30003941',X'8504C041',X'20E04141',
X'00014841',X'44B00041',X'0C856841',X'850550C1',X'20E01141',
X'60303941',X'0002F742',X'00028041',X'00031AC1',X'0000ED69',
X'00000000'(28),X'00D20941',X'84640616',X'84640716',X'F2B24B72'
!%LIST
INTEGER I,SPT,ISA,DATA,COMM,DCM FAIL
INTEGER MSH,LSH
CONSTINTEGER CONTROL=X'800'
CONSTINTEGER DIAGSTAT=X'D00'
CONSTINTEGER ISDIAG=X'E00'
CONSTINTEGER MCLEAR=2
CONSTINTEGER DCMBIT=X'400'
CONSTINTEGER NOTDCM=¬DCMBIT
CONSTINTEGER AFB=X'800'
CONSTINTEGER CLEARTOSEND=X'E80'
CONSTINTEGER CLEAR FOR NEXT=X'E00'
CONSTINTEGER UH=X'FFFF0000'
CONSTINTEGER WIDCOM=X'A200'
SPT=(X'4000'!PT)<<16; ! SAC control
ISA=SPT+CONTROL
*LB_ISA; *LSS_MCLEAR; *ST_(0+B )
ISA=SPT+DIAGSTAT; ! into direct control mode
*LB_ISA
*LSS_(0+B ); *OR_DCMBIT; *ST_(0+B )
ISA=SPT+ISDIAG; ! write microprogram
DCM FAIL=0
FOR I=0,1,511 CYCLE
DATA=UPA(I)
MSH=DATA&UH!CLEAR TO SEND
LSH=DATA<<16!CLEAR TO SEND
COMM=(WIDCOM+I)<<16!CLEAR TO SEND
*LB_ISA; *LSS_COMM
*ST_(0+B ); WAITAFB(ISA)
*LB_ISA; *LSS_MSH
*ST_(0+B ); WAITAFB(ISA)
*LB_ISA; *LSS_LSH
*ST_(0+B ); WAITAFB(ISA)
REPEAT
! set mprog loaded indicator
COMM=(WIDCOM+X'200')<<16!CLEAR TO SEND
*LB_ISA; *LSS_COMM
*ST_(0+B ); WAITAFB(ISA)
*LB_ISA; *LSS_CLEARTOSEND
*ST_(0+B ); WAITAFB(ISA)
*LB_ISA; *LSS_CLEARTOSEND
*ST_(0+B ); WAITAFB(ISA)
UNLESS DCM FAIL=0 THEN C
PRINTSTRING("SFC ".HTOS(PT,2)." mprog flags=". C
HTOS(DCM FAIL,4)."
")
*LB_ISA; *LSS_CLEAR FOR NEXT; *ST_(0+B ); ! clear FBs
ISA=SPT+DIAGSTAT; !unset DCM
*LB_ISA
*LSS_(0+B ); *AND_NOTDCM; *ST_(0+B )
ROUTINE WAITAFB(INTEGER ISDIAG)
INTEGER I
AGAIN:
*LB_ISDIAG
*LSS_(0+B )
*ST_I
*AND_AFB
*JAT_4,<AGAIN>
DCM FAIL=DCM FAIL!(I&X'1FF'); ! all FFBS and parity fails
END ; ! OF WAITAFB
END ; ! OF LOAD UPROG
ROUTINE ACTIVATE(RECORD (DTABF)NAME DTENT,RECORD (ESCBF)NAME ESCB, C
INTEGERNAME Q)
RECORD (ESQBF)NAME ESQB
LONGINTEGER LSAW; ! COPIES ESCB VALUES TO COMM AREA SAWS
INTEGER SEC, FIRST; ! INSERTS PAW BITS
INTEGER COUNT, ADDSTRS
CONSTLONGINTEGER INCS=X'0001000000000400'; ! SECTOR AND MEMAD SIMULTANEOUSLY
! AND FLAGS FOR BATCH REQUEST.
FIRST=Q
ESQB==PARM(FIRST)
ADDSTRS=ESCB_ADDSTRS
LSAW=ESQB_LSAW
! COUNT=EPN
! %CYCLE
! LONGINTEGER(ADDSTRS)=LSAW
! SAW0 & SAW1
! INTEGER(ADDSTRS+8)=0
! SRESP0
! COUNT=COUNT-1
! %EXITIF COUNT=0
! LSAW=LSAW+INCS
! ADDSTRS=ADDSTRS+16
! %REPEAT
! UNROLL ABOVE LOOP FOR CASE OF EPN=4 ONLY
*LXN_ADDSTRS; ! POINT TO EL 0 OF STREAM
*LB_0
*ST_(XNB +0); *STB_(XNB +2)
*IAD_INCS
*ST_(XNB +4); *STB_(XNB +6)
*IAD_INCS
*ST_(XNB +8); *STB_(XNB +10)
*IAD_INCS
*ST_(XNB +12); *STB_(XNB +14)
! COMM AREA SAWS NOW SET UP
Q=Q!S; ! INDICATE IT IS ACTIVE.
! CLAIM(DTENT_MARK)
! DTENT_PAW=DTENT_PAW!ESCB_PAWBS
! DTENT_MARK=-1
! RELEASE
*LXN_DTENT+4
*INCT_((XNB +5)); ! DTENT_MARK IS INTEGERNAME
*JCC_8,<MARKGOT>
SEMALOOP(DTENT_MARK,2)
*LXN_DTENT+4; ! RESET XNB AFTER CALL
MARKGOT:
*LCT_ESCB+4
*LSS_(CTB +3); ! ESCB_PAWBS
*OR_((XNB +7))
*ST_(DR )
*LSS_-1; *ST_((XNB +5))
DTENT_STATE=DTENT_STATE&(¬3)+6; ! INCREMENT ACTIVE COUNT AND
! RESET TIME CLOCK (=2 TICKS)
CONTABA(DTENT_CONTI)_BATCH=1; ! #0 => BATCH REQUEST OUTSTANDING.
BRFLAG=1; ! DITTO
END ; ! OF ACTIVATE.
ROUTINE SERV(RECORD (DTABF)NAME DTENT, INTEGER ESEC)
RECORD (ESCBF)NAME ESCB; ! AN ESEC TERMINATION HAS OCCURRED
RECORD (ESQBF)NAME ESQB
RECORD (LOGTABF)NAME LOG
INTEGERNAME Q; ! REFERENCES HQ OR LQ AS APPROPRIATE
INTEGER FIRST, SECOND, SRESPS, THISP, NEXTP;! INDICES IN PARMX
!%INTEGER COUNT, ADDRESP0
RECORD (STOREF)NAME STOR
LOG==LOGTAB(DTENT_LOGI)
LOG_TOT=LOG_TOT+1
ESCB==DTENT_ESCBS(ESEC)
! WHICH QUEUE IS ACTIVE?
IF ESCB_HQ<0 THEN Q==ESCB_HQ ELSE Q==ESCB_LQ
Q=Q!!S; ! CLEAR ACTIVE MARKER.
FIRST=Q
ESQB==PARM(FIRST)
SECOND=ESQB_Q; ! LINK OVERWRITTEN DURING PON.
! COUNT=EPN
! ADDRESP0=ESCB_ADDSTRS+8
! SRESPS=0
! %CYCLE
! SRESPS=SRESPS ! INTEGER(ADDRSP0)
! COUNT=COUNT-1
! %EXITIF COUNT=0
! ADDRESP0=ADDRESP0+16
! %REPEAT
! UNROLL THIS LOOP FOR THE CASE OF EPN=4 ONLY!!!!
*LXN_ESCB+4
*LCT_(XNB +4); ! TO EL 0 ESCB_STRS
*LSS_(CTB +2)
*OR_(CTB +6)
*OR_(CTB +10)
*OR_(CTB +14)
*ST_SRESPS
! PREPARE REPLY
STOR==STORE(ESQB_STORI)
ADPTS=ESQB_P4
!
! IF DRUM DOES NOT REPLY TO PAGETURN THEN THE STORE ARRAY MUST BE UPDATED
! THIS INCLUDES THE CASE WHEN A DRUM WRITE FINISHES AND THE DISCWRITE
! IS STILL GOING AND ALL SUCCESSFUL READS WHEN REPLIES GO TO LOCAL CONT
! THE STORE ARRAY IS SEMAPHORED. TRY TO AVOID HOLDING SEMAS THROUGH
! PROCEDURE CALLS ETC
!
IF SRESPS&TROUBLE=0 START
IF SRESPS&ADV#0 START
IF MULTIOCP=YES THEN RESERVE LOG
REPORT(DTENT,ESEC,"ERROR RECOVERY")
IF MULTIOCP=YES THEN RELEASE LOG
FINISH
IF MULTIOCP=YES THEN START
*INCT_(STORESEMA)
*JCC_8,<GOT2>
SEMALOOP(STORESEMA,0)
GOT2:
FINISH
THISP=STOR_FLAGLINK
IF ADPTS#0 AND THISP&X'80FF0000'=0 START
! WRITEOUT NEED REPLY
IF MULTIOCP=YES START ; *TDEC_(STORESEMA); FINISH
ESQB_EPAGE=0
FASTPON(FIRST)
FINISH ELSE START
IF ADPTS=0 THEN START ; ! WAS READ NO REPLY TO PAGETURN
STOR_FLAGLINK=THISP&X'CFFF0000'
THISP=THISP&X'FFFF'
IF MULTIOCP=YES START ; *TDEC_(STORESEMA); FINISH
UNTIL THISP=0 CYCLE
NEXTP=PARM(THISP)_LINK
FASTPON(THISP); ! REPLY TO LOCAL CONTROOLER(S)
THISP=NEXTP
REPEAT
FINISH ELSE START ; ! WRITE NO REPLY
STOR_FLAGLINK=THISP&X'CFFFFFFF'
BYTEINTEGER(ADPTS)=BYTEINTEGER(ADPTS)-1
IF MULTIOCP=YES START ; *TDEC_(STORESEMA); FINISH
FINISH
RETURN PPCELL(FIRST)
FINISH
FINISH ELSE START
IF MULTIOCP=YES THEN RESERVE LOG
REPORT(DTENT,ESEC,"TRANSFER FAILURE")
PSTATUS(DTENT); ! WHICH WILL CLEAR ABNT
IF MULTIOCP=YES THEN RELEASE LOG
ESQB_EPAGE=-1
FASTPON(FIRST); ! TO PAGETURN FOR RECOVERY
FINISH
DTENT_STATE=DTENT_STATE-4; ! DECREMENT ACTIVE COUNT
! UPQUEUE ON ESEC
Q=SECOND
! ACTIVATE NEW QUEUE HEAD
IF ESCB_HQ#0 THEN Q==ESCB_HQ ELSE Q==ESCB_LQ
IF Q#0 THEN ACTIVATE(DTENT,ESCB,Q)
END ; ! OF SERV.
ROUTINE TAKE CRESPS(RECORD (CONTABF)NAME CONTENT)
INTEGER MN, CRESP0, CRESP1
INTEGERNAME CSEMA
RECORD (DTABF)NAME DTENT
! RESPONSE BITS AND MASKS
CONSTSTRING (24) SFCE="&& DRUM CONTROLLER ERROR"
CONSTINTEGER ATTENTIONS=X'00102000'
CONSTINTEGER CRMNMASK=X'03000000'; ! MN BITS IN CRESP
CONSTINTEGER SWMNMASK=X'00600000'; ! SAME IN SAW0
CONSTINTEGER CRTOSWSHIFT=3; ! CONVERT CR SW MN POSITION
CONSTINTEGER AUTO=X'8000'; ! AUTO => AVAILABLE BUT ??
! DEAL WITH DRUM ON & OFF LINE.
! IF OFF THEN SIMPLY :-
! CLEAR PIW, FORGET ABOUT THE MEMI SAW.
! RESET AUTO IN DTAB
! IF ON-LINE:-
! REACTIVATE ALL QUEUES
IF MULTIOCP=YES THEN START
CSEMA==CONTENT_SEMA
*INCT_(CSEMA)
*JCC_8,<CSEMAGOT>
SEMALOOP(CSEMA,2)
CSEMAGOT:
FINISH
CRESP0=CONTENT_CRESP0
CRESP1=INTEGER(ADDR(CONTENT_CRESP0)+4)
CONTENT_CRESP0=0; ! SFC WILL NOT OVERWRITE UNTIL 0 WRITTEN THROUGH.
! FIND FIRST DRUM ON THIS SFC
DTENT==DTAB0
WHILE ADDR(CONTENT)#ADDR(CONTABA(DTENT_CONTI)) CYCLE
DTENT==RECORD(DTENT_NEXT)
REPEAT
IF CRESP0&ATTENTIONS#ATTENTIONS START
OPMESS(SFCE)
IF MULTIOCP=YES THEN RESERVE LOG
NEWLINES(2)
PRINTSTRING(SFCE." "); PDATM
NEWLINE
PRINTSTRING("controller response ")
PRINTSTRING(HTOS(CRESP0,8).HTOS(CRESP1,8)); NEWLINE
PRINTSTRING(PTMS); NEWLINE
PTM(DTENT)
NEWLINE
PSTATUS(DTENT)
IF MULTIOCP=YES THEN RELEASE LOG
RETURN
FINISH
! ESTABLISH WHICH DRUM INVOLVED
MN=(CRESP0&CRMNMASK)>>CRTOSWSHIFT
WHILE DTENT_ESCBS(0)_SAW0&SWMNMASK#MN CYCLE
DTENT==RECORD(DTENT_NEXT)
REPEAT
! N.B. BOTH CYCLES WHICH SEARCH DTAB
! IN THIS ROUTINE, ARE ASSUMED TO TERMINATE ??
IF CRESP0&AUTO#AUTO START
OPMESS("Drum ".HTOS(DTENT_PTM,3)." not auto!!!")
FAIL ALL(DTENT) UNLESS DTENT_STATE=S; ! already dead
FINISH ELSE START
IF DTENT_STATE<0 START
OPMESS("Drum ".HTOS(DTENT_PTM,3)." auto agn")
DTENT_STATE=0; ! AUTO BUT INACTIVE
DTENT_PIW=0
DTENT_PAW=0
FINISH
FINISH
IF MULTIOCP=YES THEN CSEMA=-1
END ; ! OF TAKE CRESP
ROUTINE FAIL ALL(RECORD (DTABF)NAME DTENT)
!***********************************************************************
!* DRUM NOT USABLE. FAIL ALL TRANSFERS AND SEAL IT OFF *
!* THE LONG WAIT MAY CAUSE SEMAPHORE PROBLEMS IN DUALS *
!* IGNORE PRO TEM. HOPEFULLY FAILURES WILL BE RARE *
!***********************************************************************
INTEGER I, FIRST, SECOND
INTEGERNAME Q
RECORD (ESCBF)NAME ESCB
RECORD (ESCBF)ARRAYNAME ESCBS
OPMESS("Abandoning drum ".HTOS(DTENT_PTM,3))
DTENT_STATE=S; ! NOTHING ACTIVE NOW
ESCBS==DTENT_ESCBS
FOR ESEC=0,1,DTENT_SECLIM//EPN-1 CYCLE ; !!!!!!!!
ESCB==ESCBS(ESEC)
FOR I=0,1,1 CYCLE
IF I=0 THEN Q==ESCB_HQ ELSE Q==ESCB_LQ
Q=Q&(¬S)
WHILE Q#0 CYCLE
FIRST=Q
ESQB==PARM(FIRST)
SECOND=ESQB_Q
ESQB_EPAGE=-1; ! indicate failure!!
FASTPON(FIRST)
Q=SECOND
REPEAT
REPEAT
REPEAT
! SOME SFC FAULTS EG LOW GAS PRESSURE ALLOW TRANSFERS TO CONTINUE
! FOR AT LEAST 10 SECS AFTER ATTNT. RESULTS IN HIGHLY INCONVEIENT
! INTERRUPTS. DEAL WITH THIS HERE BY WAITING SO AS TO AVOID LENGTHENING
! PATH IN THE MAIN LOOP
WAIT(100)
DTENT_PIW=0
DTENT_PAW=0
END
ROUTINE DOBR
!***********************************************************************
!* PAW BITS HAVE BEEN ADDED TO FOME SFC('S) SINCE THE LAST *
!* BATCH REQUEST WAS ISSUED, COULD HAVE BEEN SWEPT IN *
!* WITH THE WASH OTHERWISE NEED ANOTHER BATCH REQUEST. *
!***********************************************************************
RECORD (CONTABF)NAME CONTENT
CONSTINTEGER BR=X'07000000'; ! PAW FUNCTION - BATCH REQUEST
INTEGER CONTI, ISAD
INTEGERNAME CSEMA
RECORDFORMAT CAF(INTEGER MARK,PAW,SECTS,DRUMRQ,CAW0,CAW1, C
CRESP0,CRESP1, LONGINTEGER LPAW01,LPAW23)
RECORD (CAF)NAME CA; ! NEED ACCESS TO PAW AND LPAW'S.
CONTI=CONTMAX
UNTIL CONTI=0 CYCLE
CONTENT==CONTABA(CONTI)
IF MULTIOCP=YES THEN START
CSEMA==CONTENT_SEMA
*INCT_(CSEMA)
*JCC_8,<CSEMAGOT>
SEMALOOP(CSEMA,2)
CSEMAGOT:
FINISH
IF CONTENT_BATCH#0 START
! OUTSTANDING BITS
CA==RECORD(CONTENT_MARKAD)
IF CA_PAW=0 START
! PREVIOUS BR HAS BEEN (IS BEING) HONOURED.
ISAD=CONTENT_ISCONTREG
! CLAIM(CA_MARK)
! %IF CA_LPAW01!CA_LPAW23#0 %START
! MUST CLAIM SEMA BEFOR CHECKING THESE AS IT IS A CONTROLLER ERROR
! TO SEND A CH FLAG WITH NO BITS SET
! CA_PAW=BR
*LXN_CA+4; ! XNB TO COMMS AREA
*INCT_(XNB +0)
*JCC_8,<SEMAGOT>
SEMALOOP(CA_MARK,2)
*LXN_CA+4
SEMAGOT:
*LSD_(XNB +8); *OR_(XNB +10)
*JAT_4,<MISS>
*LSS_BR; *ST_(XNB +1)
! SEN FLAG
*LB_ISAD
*LSS_1
*ST_(0+B )
MISS: *LSS_-1; *ST_(XNB +0)
! %FINISH
FINISH
CONTENT_BATCH=0; ! NO LONGER OUTSTANDING
FINISH
CONTI=CONTI-1
IF MULTIOCP=YES THEN CSEMA=-1
REPEAT
END ; ! OF DOBR.
ROUTINE PSTATUS(RECORD (DTABF)NAME DTENT)
!***********************************************************************
!* READS AND PRINTS STATUS *
!* WHICH CLEARS ANY ABNORMAL TERMINATION *
!***********************************************************************
RECORDFORMAT CAF(INTEGER MARK, PAW, N1, N2, CAW0, CAW1, C
CRESP0, CRESP1)
! NEED ACCESS TO ALL THESE
CONSTINTEGER PAWFCR=X'04000000'; ! CONTROLLER REQUEST FUNCTION
CONSTINTEGER RSTATUS=X'31000014'; ! CLEAR ABNT WITH IT.
OWNINTEGERARRAY STATUS(-2:4)= M'SFCS',M'TATE',0(5)
! MUST BE OWN TO ENSURE PHYSICAL CONTIGUITY
INTEGER ISA, TEMP, PAW
RECORD (CAF)NAME CA
TEMP=DTENT_ESCBS(0)_SAW0&X'00600000'!RSTATUS
! RSTATUS, PLUS MECH NO.
SLAVESONOFF(0); ! THUS FORGET ALL ABOUT SLAVE STORES
CA==RECORD(ADDR(DTENT_MARK))
! CLAIM(CA_MARK)
*LXN_CA+4
*INCT_(XNB +0)
*JCC_8,<SEMAGOT>
SEMALOOP(CA_MARK,2)
SEMAGOT:
PAW=CA_PAW; ! SAVE PAW
CA_PAW=PAWFCR
CA_CAW0=TEMP
CA_CAW1=REALISE(ADDR(STATUS(0)))
CA_CRESP0=0
CA_MARK=-1
FOR TEMP=0,1,4 CYCLE
STATUS(TEMP)=-1
REPEAT
ISA=CONTABA(DTENT_CONTI)_ISCONTREG;! SEND FLAG
*LB_ISA; *LSS_1; *ST_(0+B )
TEMP=100000
WHILE CA_CRESP0=0 AND TEMP>0 CYCLE
TEMP=TEMP-1
REPEAT
SLAVESONOFF(-1); ! ALL BACK ON SFC DONE
IF CA_CRESP0#NT START
PRINTSTRING("read status failed, controller response")
PRINTSTRING(HTOS(CA_CRESP0,8).HTOS(CA_CRESP1,8))
NEWLINE
STATUS(4)=X'DEADDEAD'; ! ?? RECOGNIZABLE
TEMP=CONTROLLERDUMP(1,ISA>>16&255);! DUMP THE SFC
FINISH
! CLAIM(CA_MARK)
*LXN_CA+4
*INCT_(XNB +0)
*JCC_8,<SEMAGOT2>
SEMALOOP(CA_MARK,2)
SEMAGOT2:
CA_CRESP0=0; ! CLEAR FOR FURTHER RESPONSES
CA_PAW=PAW; ! RESTORE PAW
CA_MARK=-1
PRINTSTRING("controller status: ")
FOR TEMP=0,1,4 CYCLE
PRINTSTRING(HTOS(STATUS(TEMP),8))
SPACE
REPEAT
NEWLINES(2)
END ; ! OF PSTATUS
ROUTINE REPORT(RECORD (DTABF)NAME DTENT, INTEGER ESEC, C
STRING (47) MESS)
!***********************************************************************
!* THIS ROUTINE PRINTS OUT STREAM RESPONSES *
!* ON THIS ESEC OF THIS DRUM. *
!***********************************************************************
CONSTSTRING (13)ARRAY ERRS(0:31)= C
"?", "illegal track","illegal page", "pefa",
"ifa", "FA error", "internal sfc", "?",
"NORMAL TERM", "ABNORMAL TERM","?", "?",
"FAULT", "ADVISORY", "?", "SFC detected",
"mech inop", "mech error", "addressing", "cyclic check",
"srnh", "dev ipe", "?", "?",
"?", "?", "rec adresing", "rec cyc check",
"rec srnh", "rec dev ipe", "rec trunk ipe","?"
INTEGER BIT, SEC, SRESP0
INTEGER ADDSTRS
RECORD (STRF)NAME STR
RECORD (LOGTABF)NAME LOG
MESS=AAD.MESS
!OPMESS(MESS)
NEWLINE
PRINTSTRING(MESS." ")
PDATM
NEWLINES(2)
PRINTSTRING(PTMS); NEWLINE
PTM(DTENT); NEWLINE
ADDSTRS=DTENT_ESCBS(ESEC)_ADDSTRS
LOG==LOGTAB(DTENT_LOGI)
FOR SEC=0,1,EPN-1 CYCLE
STR==RECORD(ADDSTRS)
SRESP0=STR_SRESP0
IF SRESP0&TROUBLE#0 START
LOG_FAIL=LOG_FAIL+1
FINISH ELSE START
LOG_RECOV=LOG_RECOV+1 IF SRESP0&ADV#0
FINISH
PRINTSTRING(HTOS(SRESP0,8))
PRINTSTRING(" ".HTOS(STR_SRESP1,8))
BIT=0
UNTIL SRESP0=0 CYCLE
PRINTSTRING(" ".ERRS(BIT)) IF SRESP0<0
SRESP0=SRESP0<<1
BIT=BIT+1
REPEAT
NEWLINES(2)
ADDSTRS=ADDSTRS+16
REPEAT
NEWLINE
END ; ! OF REPORT.
ROUTINE INITIALISE(RECORD (PONOFF)NAME P)
RECORD (DTABF)NAME DTENT
RECORD (ESCBF)NAME ESCB
INTEGER ESEC, LOGI, AD
DTAB0==RECORD(COM_SFCA+4)
EPN=P_INTACT; ! P_P1
EPNBITS=¬((-1)>>EPN)
! HQ AND LQ OF DRUMTAB 0_ESEC(0) HAVE REL OFFSET OF CONTROLLER TABLE
! AND NO OF CONTROLLERS FROM START OF TABLE PROPER
! FISH OUT PARAMETERS WHICH DEFINE
! CONTROLLER TABLE
ESCB==DTAB0_ESCBS(0)
COM_SFCCTAD=COM_SFCA+ESCB_HQ
CONTABA==ARRAY(COM_SFCCTAD,CONTABAF)
CONTAB1==CONTABA(1)
CONTMAX=ESCB_LQ
FOR LOGI=1,1,CONTMAX CYCLE
CONTABA(LOGI)_SEMA=-1
REPEAT
ESCB_HQ=0
ESCB_LQ=0
! SET UP DTAB NEXT'S AS ADDRESSES NOT DISPLACEMENTS
! AND SET UP LOGI INDEXES.
DTENT==DTAB0
LOGI=0
CYCLE
DTENT_LOGI=LOGI
DTENT_PTM=CONTABA(DTENT_CONTI)_ISCONTREG>>12&X'FF0'! C
DTENT_ESCBS(0)_SAW0>>21&3
AD=DTENT_NEXT
EXIT IF AD=0
AD=AD+P_EPAGE
DTENT_NEXT=AD
DTENT==RECORD(AD)
LOGI=LOGI+1
REPEAT
! PLUS TIMING VARIABLE (OWN ANYWAY)
PAST=0
END ; ! OF INITIALISE
ROUTINE PDATM; ! TIME STAMP FOR JOURNAL OUPUT
PRINTSTRING("DT: ".DATE." ".TIME)
END ; ! OF PDATM
ROUTINE PTM(RECORD (DTABF)NAME DTENT); ! PRINTS IN FORMAT:-
INTEGER TEMP; ! i.e. port trunk mechanism (PTMS)
TEMP=DTENT_PTM
PRINTSTRING(" ".HTOS(TEMP>>8,1));! PORT
SPACES(5)
PRINTSTRING(HTOS(TEMP>>4&15,1)); ! TRUNK
SPACES(7)
PRINTSTRING(HTOS(TEMP&3,1)); ! MECH NO.
END ; ! OF PTM
END ; ! OF DRUM !!!!!!!!!
LIST
FINISH ; ! CONDITIONAL COMPILATION OF DRUM
EXTERNALROUTINE SEMAPHORE(RECORD (PARMF)NAME P)
RECORDFORMAT SEMAF(INTEGER DEST,SRCE,TOP,BTM,SEMA,TICK,P5,P6,LINK)
RECORD (SEMAF)NAME SEMACELL
RECORD (PARMXF)NAME WAITCELL
OWNINTEGERARRAY HASH(0:31)=0(32)
OWNINTEGER TICKS=0
INTEGERFNSPEC NEWSCELL
INTEGERFNSPEC NEWWCELL
INTEGER SEMA, HASHP, NCELL, I, WCELL
INTEGERNAME CELLP
SWITCH ACT(1:4)
IF MONLEVEL&2#0 AND KMON&1<<7#0 THEN C
PKMONREC("SEMAPHORE:",P)
SEMA=P_P1
IF P_DEST&15<3 THEN HASHP=IMOD(SEMA-SEMA//31*31) AND C
CELLP==HASH(HASHP)
->ACT(P_DEST&7)
!-----------------------------------------------------------------------
ACT(1): ! P OPERATION
WHILE CELLP#0 CYCLE
SEMACELL==PARM(CELLP)
IF SEMA=SEMACELL_SEMA THEN START
I=SEMACELL_BTM
IF I=0 THEN START ; ! ALREADY HAD V OPERATION
SEMACELL_DEST=P_SRCE
SEMACELL_SRCE=X'70001'
FASTPON(CELLP)
CELLP=0
FINISH ELSE START ; ! ADD TO BTM OF QUEUE
WCELL=NEWWCELL
PARM(I)_LINK=WCELL
SEMACELL_BTM=WCELL
FINISH
RETURN
FINISH
CELLP==SEMACELL_LINK
REPEAT
!
! NO QUEUE YET
!
NCELL=NEWSCELL
CELLP=NCELL
WCELL=NEWWCELL
SEMACELL_TOP=WCELL
SEMACELL_BTM=WCELL
RETURN
!-----------------------------------------------------------------------
ACT(2): ! V OPERATION
WHILE CELLP#0 CYCLE
SEMACELL==PARM(CELLP)
IF SEMA=SEMACELL_SEMA THEN START
SEMACELL_TICK=TICKS; ! RECORD V OPERATION
I=SEMACELL_TOP
IF I#0 START ; ! IN CASE 2 V OPERATIONS
SEMACELL_TOP=PARM(I)_LINK
PARM(I)_SRCE=P_SRCE; ! if a timeout P_SRCE = X'70004'
! this SRCE enables director to reset faulty SEMA
FASTPON(I)
FINISH
IF SEMACELL_TOP=0 THEN START ;! RETURN HEADCELL
I=SEMACELL_LINK
RETURN PP CELL(CELLP)
CELLP=I
FINISH
RETURN
FINISH
CELLP==SEMACELL_LINK
REPEAT
!
! P OPERATION NOT HERE YET
!
NCELL=NEWSCELL
CELLP=NCELL
RETURN
!-----------------------------------------------------------------------
ACT(3): ! DISPLAY SEMAPHORE QUEUES
IF MONLEVEL&2#0 THEN START
FOR HASHP=0,1,31 CYCLE
CELLP==HASH(HASHP)
WHILE CELLP#0 CYCLE
SEMACELL==PARM(CELLP)
SEMA=SEMACELL_SEMA
I=SEMACELL_TOP
WHILE I#0 CYCLE
OPMESS("SEMA X".HTOS(SEMA,8). C
" Q :X".HTOS(PARM(I)_DEST>>16,3))
I=PARM(I)_LINK
REPEAT
CELLP==SEMACELL_LINK
REPEAT
REPEAT
FINISH
RETURN
!-----------------------------------------------------------------------
ACT(4): ! TEN SECOND TICK
TICKS=TICKS+1
FOR HASHP=0,1,31 CYCLE
CELLP==HASH(HASHP)
WHILE CELLP#0 CYCLE
SEMACELL==PARM(CELLP)
IF TICKS-SEMACELL_TICK>=12 START ;! 2 MINS SINCE V OPER
OPMESS("FSEMA timeout ".HTOS(SEMACELL_SEMA,8))
P_DEST=X'70002'
P_SRCE=X'70004'
P_P1=SEMACELL_SEMA
PON(P)
FINISH
CELLP==SEMACELL_LINK
REPEAT
REPEAT
RETURN
INTEGERFN NEWWCELL
INTEGER I
I=NEWPPCELL
WAITCELL==PARM(I)
WAITCELL_DEST=P_SRCE
WAITCELL_SRCE=X'70001'
WAITCELL_LINK=0
IF MONLEVEL&2#0 THEN WAITCELL_P5=M'SEMA'
IF MONLEVEL&2#0 THEN WAITCELL_P6=M'WAIT'
RESULT =I
END
!-----------------------------------------------------------------------
INTEGERFN NEWSCELL
INTEGER I
I=NEWPPCELL
SEMACELL==PARM(I)
SEMACELL=0
SEMACELL_SEMA=SEMA
SEMACELL_TICK=TICKS
IF MONLEVEL&2#0 THEN SEMACELL_P5=M'SEMA'
IF MONLEVEL&2#0 THEN SEMACELL_P6=M'HEAD'
RESULT =I
END
END
ENDOFFILE