.TITLE	ZRHost - VAX/VMS VIRT DISK Host Process (memory disk)
;xxiosb=1
	.IDENT	'V01-003'
;$$xdt=1
; Note: Initial cut failed. Waiting on event flag 10 is not functioning
; properly. Therefore drop back and create a mailbox and assign a
; channel to it. Driver will notify us of work by sending the buffer
; header to us via exe$wrtmailbox. We have to supply UCB address of
; the mailbox after the size in our initial QIO, in the buffer.
;
; FACILITY:
; 
; Host part of a remote virtual disk. This process executes on
; a local machine in conjunction with ZRDRV and talks over DECnet
; to a special remote DECnet object. This remote object is installed
; with privilege (log_io) and is able to access a particular disk
; on the remote system, whose name is specified by a logical and whose
; geometry is returned to this program. (The presumtpion is that the
; remote disk and geometry will either be set via command input or via
; logical names, and the geometry must be played back to ZRDRV so that
; its' virtual disk will be the same geometry as the actual remote disk.
; This is important for some few VMS components and makes the backup
; and mount work reliably.)
;   This process communicates via nontransparent DECnet with the remote
; one to handle actual disk data transfers. Writes may optionally be
; blocked at the remote end if this is to be a read-only access.
;
; This version is intended to achieve "robustness" in the face of network
; outages by closing the network channel here and reopening it. This
; should allow a new remote object to start, using the same disk,
; and allow the I/O to continue as before. This retry operation will be
; done only a limited number of times, but should allow a link to
; survive a brief network outage, particularly if alternate routing
; exists.
;
; Command format:
; ZRHost/switches VDn: 
;  where a .CLD file is expected so that this can all be parsed by
;  the CLI. The legal switches will just be /ASSIGN or /DEASSIGN
;  to specify which operation is required. In the /DEASSIGN
;  case no filename is needed of course; the virtual disk must
;  however be dismounted before this utility will allow it to
;  be deassigned. The ucb$w_refc field must be zero before the
;  deassign is thus permitted.
; Note deassign normally will NOT be via command (I don't see how a
; command could ever be read) but vie exit AST.
;
; Note: define VMS$V5 to build for Version 5.x of VMS.
vms$v5=1
;
; 
; AUTHOR:
; 
; G. EVERHART
;--
	.PAGE
	.SBTTL	EXTERNAL AND LOCAL DEFINITIONS

	.LIBRARY /SYS$SHARE:LIB/
; 
; EXTERNAL SYMBOLS
; 

	$ADPDEF				;DEFINE ADAPTER CONTROL BLOCK
	$CRBDEF				;DEFINE CHANNEL REQUEST BLOCK
	$DCDEF				;DEFINE DEVICE CLASS
	$DDBDEF				;DEFINE DEVICE DATA BLOCK
	$DEVDEF				;DEFINE DEVICE CHARACTERISTICS
	$DPTDEF				;DEFINE DRIVER PROLOGUE TABLE
	$EMBDEF				;DEFINE ERROR MESSAGE BUFFER
	$IDBDEF				;DEFINE INTERRUPT DATA BLOCK
	$IODEF				;DEFINE I/O FUNCTION CODES
	$IRPDEF				;DEFINE I/O REQUEST PACKET
	$PRDEF				;DEFINE PROCESSOR REGISTERS
	$PCBDEF				;DEFINE PCB OFFSETS
	$SCSDEF
	$SBDEF
	$STSDEF
	$STSDEF		; Symbols for returned status.
	$DVIDEF		; Symbols for $GETDVI service.
	$DCDEF		; Symbols for device type.
	$SSDEF				;DEFINE SYSTEM STATUS CODES
	$UCBDEF				;DEFINE UNIT CONTROL BLOCK
	$VECDEF				;DEFINE INTERRUPT VECTOR BLOCK

; 
; No need for direct UCB access here; this is done via the driver
; itself. We just worry about the files, etc.
; 

	$FIBDEF			; Symbols for file information block.
	$IODEF			; Symbols for QIO functions.
	$DVIDEF			; Symbols for $GETDVI calls.
	$TPADEF			; Symbols for LIB$TPARSE calls.
	$DEFINI	UCB			;START OF UCB DEFINITIONS
;.=UCB$L_BCR+2				;BEGIN DEFINITIONS AT END OF UCB
.=UCB$K_LCL_DISK_LENGTH	;v4 def end of ucb
; USE THESE FIELDS TO HOLD OUR LOCAL DATA FOR VIRT DISK.
; Add our stuff at the end to ensure we don't mess some fields up that some
; areas of VMS may want.
;The following must match the same-named data in the ACB extension
	.blkl	2	;safety
$DEF	UCB_L_UCB	.BLKL	1	;Save UCB address here
$DEF	UCB_L_MEMBUF	.BLKL	1	;Address of buffer for this transfer
$DEF	UCB_L_NSPTS	.BLKL	1	;Number of SPTs required for buffer
$DEF	UCB_L_SVPN	.BLKL	1	;Starting system page number
$DEF	UCB_L_ADRSPT	.BLKL	1	;Address of first SPT used
$DEF	UCB_L_SVABUF	.BLKL	1	;System virtual address of user buffer
;
$DEF	UCB$HPID	.BLKL	1	;ADDRESS OF HOST UCB
$DEF	UCB$HLBN	.BLKL	1	;LBN OF HOST FILE
$DEF	UCB$HFSZ	.BLKL	1	;SIZE OF HOST FILE, BLKS
$DEF	UCB$PPID	.BLKL	1	;PID OF ORIGINAL PROCESS FROM IRP BLK
$def	ucb$irps	.BLKL	1	;IRP save area during host proc action
$def	ucb$smbx	.BLKL	1	;mailbox UCB for work notices
; Define save areas for UCB fields needed for I/O copies and used in
; driver to process copies here.
$def	ucb$lsvapte	.blkl 1    ;saves ucb$l_svapte
$def	ucb$lsts	.blkl 1     ;saves ucb$l_sts
$def	ucb$lsvpn	.blkl 1  ; similar
$def	ucb$wboff	.blkl 1  ; similar
$def	ucb$lmedia	.blkl	1
$def	ucb$irplmedia	.blkl	1	;irp$l_media save
$def	ucb$wdirseq	.blkl	1
$def	ucb$lbcr	.blkl	1
; NOTE: It is important to ENSURE that we never clobber IRP$L_PID twice!
; therefore, adopt convention that UCB$PPID is cleared whenever we put
; back the old PID value in the IRP. Only clobber the PID where
; UCB$PPID is zero!!!
$DEF	UCB$L_MEMBUF	.BLKL	1	; MEMORY AREA
$DEF	UCB$L_MEMBF	.BLKL	1	; MEMORY BUFFER FOR CONTROL PROCESS
$DEF	UCB$stats	.BLKL	1	;STATUS CODE SAVE AREA
$def	ucb$jiggery	.blkl	1	;adjust to refcnt to fix up
; Since I/O postprocessing on virtual or paging I/O makes lots of
; assumptions about location of window blocks, etc., which are
; not true here (wrong UCB mainly), we'll bash the function status
; we send to the host driver to look like physical I/O is being
; done and save the real function code here. Later when ZR: does
; I/O completion processing, we'll replace the original function
; from here back in the IRP. This will be saved/restored along with
; ucb$ppid (irp$l_pid field) and so synchronization will be detected
; with ucb$ppid usage.
;
$def    ucb$l_blk	.blkl	1	;block i/o if nonzero
$def	ucb$l_ucbtbl	.blkl	1	;table of ucb addresses
;$def	ucb$l_bufpol	.blkl	1	;buffer addresses table
$def	ucb$l_ctlfgs	.blkl	1	;control flags
$def	ucb$l_sanity	.blkl	1	;sanity test
	.if	ndf,xcldbg
$def	ucb$l_misc	.blkl	20	;debug
	.endc
; (bit 1 set implies disallow create, delete, or extend)
$DEF	UCB$K_ZR_LEN	.BLKL	1	;LENGTH OF UCB
;UCB$K_ZR_LEN=.				;LENGTH OF UCB
	$DEFEND	UCB			;END OF UCB DEFINITONS
; Macro to check return status of system calls.
;
	.MACRO	ON_ERR	THERE,?HERE
	BLBS	R0,HERE
	BRW	THERE
HERE:	.ENDM	ON_ERR

	.PSECT	ZRHostD_DATA,RD,WRT,NOEXE,LONG

ourpid:	.long	0	;;;store this locally
;;;(avoid paging problems in kernel)
xsec:	.double	3.01
;
; KERNEL ARG LIST
K_ARG:
	.LONG	2	;2 ARGS: ZR device name, mb device name
	.ADDRESS	VDV_BUF_DESC
	.address	mbx_buf_desc
dvl:	.long	0
DESBLK:
	.LONG	0
	.ADDRESS	XITHDL		;EXIT HANDLER ADDRESS
	.long	0
	.address	dvl
	.LONG	0,0			;REST OF EXIT HANDLER CONTROL BLK
;
DEFAULT_DEVICE:
	.ASCID	/SYS$DISK/

	$ATRDEF
	$FABDEF
	$FATDEF
	$FIBDEF
	$IODEF
	$NAMDEF
	$RMSDEF
	$XABDEF
	.ALIGN LONG
IOSTATUS: .BLKQ 1
;**
VDV_BUF:			; Buffer to hold VDVice name.
	.BLKB	40
VDV_BUF_SIZ = . - VDV_BUF

VDV_BUF_DESC:			; Descriptor pointing to VDVice name.
	.LONG	 VDV_BUF_SIZ
	.ADDRESS VDV_BUF

VPID:				; Owner of VDVice (if any).
	.BLKL	1

VDV_ITEM_LIST:			; VDVice list for $GETDVI.
	.WORD	 VDV_BUF_SIZ	; Make sure we a have a physical device name.
	.WORD	 DVI$_DEVNAM
	.ADDRESS VDV_BUF
	.ADDRESS VDV_BUF_DESC
	.WORD	 4		; See if someone has this device allocated.
	.WORD	 DVI$_PID
	.ADDRESS VPID
	.LONG	 0
	.WORD	 4
	.WORD	 DVI$_DEVCLASS	; Check for a terminal.
	.ADDRESS VDV_CLASS
	.LONG	 0
	.LONG	 0		; End if item list.

VDV_CLASS:
	.LONG	1
;^^^
mbx_BUF:			; Buffer to hold mbxice name.
	.BLKB	40
mbx_BUF_SIZ = . - mbx_BUF

mbx_BUF_DESC:			; Descriptor pointing to mbxice name.
	.LONG	 mbx_BUF_SIZ
	.ADDRESS mbx_BUF

mPID:				; Owner of mbxice (if any).
	.BLKL	1

mbx_ITEM_LIST:			; mbxice list for $GETDVI.
	.WORD	 mbx_BUF_SIZ	; Make sure we a have a physical device name.
	.WORD	 DVI$_DEVNAM
	.ADDRESS mbx_BUF
	.ADDRESS mbx_BUF_DESC
	.WORD	 4		; See if someone has this device allocated.
	.WORD	 DVI$_PID
	.ADDRESS mPID
	.LONG	 0
	.WORD	 4
	.WORD	 DVI$_DEVCLASS	; Check for a terminal.
	.ADDRESS mbx_CLASS
	.LONG	 0
	.LONG	 0		; End if item list.

mbx_CLASS:
	.LONG	1
;^^^
DEFNAM:

WRK:	.BLKL	1	;SCRATCH INTEGER
; DESCRIPTOR FOR VDn: "FILENAME"
	.ALIGN LONG
VDFNM:	.WORD	 255.	;LENGTH
VDFTP:	.BYTE	DSC$K_DTYPE_T	;TEXT TYPE
	.BYTE	1	; STATIC STRING
	.ADDRESS	VDFNMD
VDFNMD:	.BLKB	256.	; DATA AREA
;
VDCHN:	.LONG	0	;CHANNEL HOLDERS
;
; FOR initial use, don't bother allocating the file. Assume the
; user can somehow allocate a contiguous file of the size he wants
; for himself.
;
Retcnt:	.long	0	;retry count
MBCHN:	.long	0	; channel for mailbox
MBUCB:	.long	0	; UCB address for mailbox
ASDSC:	.ASCID	/ASSIGN/
DASDSC:	.ASCID	/DEASSIGN/
P1DSC:	.ASCID	/UNIT/
P2DSC:	.ASCID	/FNAM/
nsds:	.ascid	/NOSPC/
nwds:	.ascid	/NOWRITE/
	.EVEN
;
; ucb data area
HSTUCB:	.LONG	0	;HOST UCB ADDRESS
;Info holders for info from subroutines that access the remote
;machine...
NETCHN:	.LONG	0	;CHANNEL TO REMOTE SYSTEM
NETTRK:	.LONG	0	;TRACKS RETURNED FROM REMOTE
NETSCT:	.LONG	0	;SECTORS FROM REMOTE
NETCYL:	.LONG	0	;CYLINDERS FROM REMOTE
NETBLKS: .LONG	0	;SIZE IN BLOCKS FROM REMOTE
;
ctlfgs:	.long	0	;holds control flags
;
; Argument lists for external subroutines
Openarg:
	.long	5	;get channel number, t/s/c/size info
	.address	netchn
	.address	nettrk
	.address	netsct
	.address	netcyl
	.address	NETBLKS		;size of total disk
Closarg:
	.long	1
	.address	netchn		;for closing net channel
;
;OURPID:	.LONG	0	;PID OF THIS PROCESS
iosb:	.long	0,0,0,0	;iosb
ioprog:	.long	0	; i/o in progress flag if nonzero
; BUFFER FOR COPIES OF DRIVR DATA
BUFHDR:	.LONG	0,0,0,0,0
	.iif	df,ZRadr, .long 0	; if ZRDRV is assembled to pass 6 longs
fbufsiz=8192	;buffersize to match maxbcnt for driver
fbs4=fbufsiz/4					; in its' header area
BUF:	.BLKL	fbs4	; DATA AREA
	.blkl	fbs4	;safety, allow up to 4 times size...
	.blkl	fbs4	;safety
	.blkl	fbs4	;safety
	.LONG	0,0	;SAFETY BUFFERS
SETZR:	.LONG	0	;DECLARE PROCESS
	.LONG	0	;PID
	.LONG	1	;DISK SIZE
	.LONG	0,0,0,0	;EXTRA STUFF FOR OTHER CALLS
	.long	0,0	;(includes MB UCB, trks, sects, cyls)
SETZRL=.-SETZR
	.LONG	0,0,0,0,0	;SAFETY
;
SBUFHDR: .LONG	0,0,0,0,0,0,0
	.PSECT	ZRHostD_CODE,RD,WRT,EXE,LONG
	.ENTRY	ZRHostD,^M<R2,R3,R4,R5,R6,R7,R8,R9,R10,R11>
; only ZRn: name on command line
	clrl	ctlfgs
	PUSHAB	WRK		;PUSH LONGWORD ADDR FOR RETLENGTH
	PUSHAB	VDFNM		;ADDRESS OF DESCRIPTOR TO RETURN
	PUSHAB	P1DSC		; GET P1 (VDn: UNIT)
	CALLS	#3,G^CLI$GET_VALUE	;GET VALUE OF NAME TO VDFNM
	ON_ERR	ZRHostD_EXIT
290$:
	pushab	nsds		;see if /nospc called
	calls	#1,g^cli$present
	cmpl	r0,#cli$_present	;was it there?
	bneq	15$		;if not br
	bisl	#1,ctlfgs	;else set flags to pass
15$:
; Make /nowrite imply /nospc too.
	pushab	nwds		;/nowrite asked for?
	calls	#1,g^cli$present
	cmpl	r0,#cli$_present	;was it there?
	bneq	17$		;if not br
	bisl	#3,ctlfgs	;else set flags to pass
17$:

; MUST HAVE ASSIGNMENT TO VD: UNIT IN ANY CASE.
	$ASSIGN_S -
		DEVNAM=VDFNM,-	; GET CHANNEL FOR VDn:
		CHAN=VDCHN
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
	$GETDVI_S -
		CHAN=vdchn,-	; Command line has device name.
		ITMLST=VDV_ITEM_LIST
	BLBS	R0,140$

	BRW	ZRHostd_EXIT
140$:
; Set up mailbox channel
	$crembx_s prmflg=#0,chan=mbchn,maxmsg=#576,bufquo=#5760,-
		promsk=#0
	On_ERR	ZRhostd_exit
; need to get UCB address here somehow...
	$GETDVI_S -
		CHAN=mbchn,-	; Command line has device name.
		ITMLST=mbx_item_list
	BLBS	R0,176$
190$:	BRW	ZRHostd_EXIT
176$:
; Got now the actual device name of the mailbox
; Next set up the assignment to the remote system
; Initially allow the name to be hard coded or something in the
; subroutine we use to set this up.
	clrl	netchn
	CALLG	G^OPENARG,NETOPN	;OPEN THE NET
	tstl	netchn		;got a channel?
	beql	190$		;no. error exit.
	tstl	netblks		;nonzero size (REQUIRED!!!)
	bneq	191$		;no, lose now...
	CALLG	g^closarg,NETCLS	;close the net channel
	brb	190$		;then scram
191$:
; Let the kernel call perform the UCB lookup for us.
;
; FOUND A UNIT. NOW DECLARE EXIT HANDLER TO CLEAN UP
; IF WE GET A $FORCEX TO TERMINATE THE HOST PROCESS.
	PUSHAB	DESBLK		; ADDRESS OF DESBLK
	CALLS	#1,G^SYS$DCLEXH	; DECLARE EXIT HANDLER
; NOW GET OUR PID FOR USE LATER
;
	$CMKRNL_S -
		ROUTIN=BASHUCB,ARGLST=K_ARG
; Now we have the PID for our process in OURPID and are ready to tell
; the driver we're here!
	MOVL	OURPID,SETZR+4	;STORE PID (IPID!!!)
	movl	netblks,setZR+8	;size of disk
	movl	mbucb,setZR+12		; Comm mailbox UCB address
	CLRL	SETZR		; flag that this is the setup
	movl	#setZRl,r4	; length of buffer
	movl	nettrk,setZR+16	;tell ZRDRV about our geometry
	movl	netsct,setZR+20
	movl	netcyl,setZR+24
; Note we must modified func code from io$_format to something with
; a modifier bit set so ZRDRV will treat this as OUR special QIO.
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=R4
; Communication with the driver MUST remain OK always.
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
	clrl	ioprog		; no i/o in progress yet
; now we're ready to await work from the driver
	clrl	retcnt		;zero retry counter first
EVTLOOP:
; When ZRDRV has work, it sends the buffer header it has via a
; mailbox message. Read that here to get our indication there
; is something to do, and incidentally to get initial info on I/O
; direction and size.
;
; Read the mailbox to get our data
; Use QIOW$ to assure that we don't do anything until there is work.
; (this also avoids having to use internal routines to control
;  host execution.)
	$qiow_s efn=#10,chan=mbchn,-
	iosb=iosb,func=#io$_readlblk,p1=bufhdr,p2=#20
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
;	$qiow_s efn=#1,chan=vdchn,func=#io$_format,p1=#setZR,p2=#setZRl
;SHOULD NOW HAVE HEADER...
; Check call is not spurious. Driver sets 255 in buffer header when it
; gets done an i/o for client, and puts 0 or 1 there for a real
; transfer.
;
; check for io$_available (ignore here) or io$_unload (so we exit)
        cmpl    bufhdr,#512     ;got it?
        bneq    643$            ;if neq br
        cmpl    bufhdr+4,#1024
        bneq    643$
        cmpl    bufhdr+8,#2048
        bneq    643$
        cmpl    bufhdr+12,#4096
        bneq    643$
;if we get here, user just issued io$_available or io$_unload so is dismounting
; the disk. Therefore call the bufdmo function
; If this is an unload, by the way, bufhdr+16 will be 14747 (decimal)
        cmpl    bufhdr+16,#14747        ;unload magic number?
        bneq    654$
        brw     awscram         ;unload flag seen
654$:
644$:   brw     evtloop         ;then look for more to do
643$:
	cmpl	bufhdr,#2
	bgtru	644$		;if not really doing i/o, spurious ef
				; set, just ignore
	MOVL	#1,IOPROG	;FLAG AN I/O IN PROGRESS THAT NEEDS TO
				;BE COMPLETED
	CMPL	BUFHDR,#1	;1=WRITE, SOMETHING'S WAITING IN THE DRIVER
	beql	writeop
	jmp	readop
;	BNEQ	READOP
WRITEOP:
; BUFHDR+8 CONTAINS BYTECOUNT FOR DATA PART OF TRANSFER
;	MOVL	#20,SETZR+8	;BUFFER HEADER size
;	ADDL2	BUFHDR+8,SETZR+8	;SO ADD HEADER SIZE
	movl	bufhdr+8,setZR+8
	MOVL	#5,SETZR	;GET DATA only
	MOVL	#BUF,SETZR+4	;BUFFER HDR ADDRESS
	movl	#1,setZR+12	;success indicator
	movl	#setZRl,r4
; Get the DATA from the driver.
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=R4
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
; LOADS DATA INTO LOCAL BUFFER FROM DRIVER
; NOW HAVE TO MOVE IT INTO STORAGE HERE
;
;  Now ship the data OUT over the net to the network channel
	addl3	#20,bufhdr+8,r4
874$:	$qiow_s efn=#2,chan=netchn,-
	iosb=iosb,func=#<io$_Writevblk>,p1=bufhdr,p2=r4
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
.iif ndf,retlim,retlim=2000
	blbs	iosb,71$
875$:	incl	retcnt		;bump retry counter
	cmpl	retcnt,#retlim	;too big? If so give up on the net link.
	bgeq	873$		;give up
; close and reopen the net link. Note the netopen routine gets the size info.
	jsb	netfix
	tstl	netchn
	beql	875$
	brw	874$
873$:	jmp	ZRhostd_exit
71$:
	clrl	retcnt
; remote host interprets buffer header and will know it must write
; the buffer data to storage at the given block, then finish.
; Since we just have to write, just dump all the data in one fell
; swoop here.
;  For good design we need a positive ack that the data really got there.
;  therefore look for an IOSB back from the remote. Read it in now via
;  the net.
	$qiow_s efn=#2,chan=netchn,-
	iosb=iosb,func=#<io$_Readvblk>,p1=buf,p2=#8
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
; If the net fails sending the ack, we just let it by since the server
; comes up wanting work. We'll catch it on the next operation.
; However, let the application see that we did not get an ack that
; this particular write was OK. It MIGHT have been OK; we could have
; lost the link after our write. (Indeed, we probably did, since
; we checked the IOSB after the write and it looked OK.)
	blbs	iosb,771$
; Assume the write went OK. This will normally have been the case
; unless we give up. We lose the ability to catch hardware write
; errors on the remote if the link drops but generally this will be
; the accurate reply.
	movl	#3,bufhdr+12	;initially set success (alternate!)
	movw	bufhdr+8,bufhdr+14	;and bytecount what was written
771$:
	.iif ndf,xxiosb, blbc	iosb,cmnj	; check i/o stat blk too
	blbs	buf,cmnj
; Something went wrong at the other end. Signal it to the client via
; write to buffer header in driver.
	movl	buf,bufhdr+12	;copy IOSB longword 1
	movl	buf+4,bufhdr+16	;copy IOSB longword 2
; To avoid xqp seeing uninterpretable codes, fill in by hand
; here.
	movw	#ss$_drverr,bufhdr+12	;fill in ss$_drverr always
;Now set up to move this into driver space
	brb	fup
cmnj:	JMP	COMMON
fup:	movl	#20,SETZR+8	;bash header only incl. IOSB
	MOVL	#BUFhdr,SETZR+4	;BUFFER HDR ADDRESS
	MOVL	#2,SETZR	;HOST TO DRIVER COPY HDR/DATA
	movl	#setZRl,r4
	movl	#1,setZR+12	;success...
	movl	bufhdr+8,setZR+16	;/length sent
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=#20
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
;
READOP:
; Copy bufhdr (5 longs) to a save area in case we have to retry this all.
	pushr	#^m<r0,r1,r2,r3,r4,r5>
	movab	bufhdr,r1
	movab	sbufhdr,r2
	movc3	#20,(r1),(r2)	;copy bufhdr to sbufhdr
	popr	#^m<r0,r1,r2,r3,r4,r5>
readop2:
; READING DATA TO CLIENT. MUST GET DATA, THEN SEND TO DRIVER.
; Get data from net to send to client
;  Now ship the data OUT over the net to the network channel
	movl	#20,r4		;First write the header to the remote
	$qiow_s efn=#2,chan=netchn,-
	iosb=iosb,func=#<io$_Writevblk>,p1=bufhdr,p2=r4
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
	blbs	iosb,72$
	brw	272$
72$:
	addl3	#20,bufhdr+8,r4	;get total data length
; Now READ the data from the remote including the header.
	$qiow_s efn=#2,chan=netchn,-
	iosb=iosb,func=#<io$_Readvblk>,p1=bufhdr,p2=r4
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
	blbs	iosb,172$
; network retry area. On a network error, repeat the whole thing.
272$:
	incl	retcnt		;bump retry counter
	cmpl	retcnt,#retlim	;too big? If so give up on the net link.
	bgeq	873$		;give up
; close and reopen the net link. Note the netopen routine gets the size info.
	jsb	netfix
	tstl	netchn		;did we fail to reassign the net channel?
	beql	272$		;if so retry again
	pushr	#^m<r0,r1,r2,r3,r4,r5>
; reconstitute the buffer header so we really repeat the SAME operation.
	movab	bufhdr,r1
	movab	sbufhdr,r2
	movc3	#20,(r2),(r1)	;copy sbufhdr to bufhdr
	popr	#^m<r0,r1,r2,r3,r4,r5>
	brw	readop2		;error on either part of the operation
				;implies redo it all.
873$:	jmp	ZRhostd_exit
172$:
	clrl	retcnt
; Now dump ALL the data, including IOSB, back to the host.
	ADDL3	#20,BUFHDR+8,SETZR+8	; GET LENGTH TO XFER
	MOVL	#BUFHDR,SETZR+4	;BUFFER HDR ADDRESS
	MOVL	#2,SETZR	;HOST TO DRIVER COPY w/header
	movl	#setZRl,r4
	movl	#1,setZR+12	;success...
	movl	bufhdr+8,setZR+16	;/length sent
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=R4
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
; NOW DATA IS IN DRIVER SPACE AS REQUIRED
COMMON:
; NOW TERMINATE THE I/O AND AWAIT MORE WORK.
	MOVL	#1,SETZR	;TERMINATE I/O PACKET
	MOVL	BUFHDR,SETZR+4	;SAVE TRANSFER DIRECTION
	MOVL	BUFHDR+4,SETZR+8	; BLOCK #
	MOVL	BUFHDR+8,SETZR+12	; NO. BYTES IN BUFFER
	MOVZWL	#SS$_NORMAL,SETZR+16	; IOSB 1
	CLRL	SETZR+20	; IOSB 2	; ALWAYS SUCCESS
	movl	#setZRl,r4
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=R4
	ON_ERR	ZRHostD_EXIT	; SKIP OUT IF ERROR
; NOW DONE TRANSFER
	CLRL	IOPROG	; SAY NO I/O IN PROCESS IF WE ARE FORCED TO EXIT
	JMP	EVTLOOP
; BE SURE WE DON'T LEAVE THE CHANNELS ASSIGNED TO THE DEVICES
; EITHER...
; (damfino how this can get here, though...
awscram:
; exiting, so mark disk offline first
; First deassign the mailbox so the driver won't send us any more
; operations
        $dassgn_s chan=mbchn
; Now terminate the I/O for the user
        MOVL    #1,SETzr        ;TERMINATE I/O PACKET
        MOVL    BUFHDR+4,SETzr+8        ; BLOCK #
        MOVL    #1,SETzr+4      ;Set transfer direction=1, write, so
                                ;there will be no data copy needed at done
                                ; processing. For a real write the
                                ; data will have been copied in startio. Here
                                ; there's none to copy; we just want the
                                ; IRP to be returned.
        MOVL    #0,SETzr+12     ; NO. BYTES IN BUFFER
        MOVZWL  #SS$_NORMAL,SETzr+16    ; IOSB 1
        CLRL    SETzr+20        ; IOSB 2        ; ALWAYS SUCCESS
        movl    #setzrl,r4
        $qiow_s efn=#1,chan=vdchn, -
        iosb=iosb,func=#<io$_format+128>,p1=setzr,p2=R4
	CLRL	SETZR	;DECLARE/UNDECLARE
	PUSHAB	DESBLK		; ADDRESS OF DESBLK
	CALLS	#1,G^SYS$CANEXH	; CANCEL EXIT HANDLER
	clrl	setZR+4	;FLAG NOBODY HOME NOW
	clrl	setZR+8
	movl	#setZRl,r4
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=R4
	$DASSGN_S CHAN=VDCHN
	CALLG	g^closarg,NETCLS	;close the net channel
	RET
ZRHostd_exit:
	tstl	vdchn
	beql	15$
	calls	#0,g^xithdl
; Close connection down (if any)
15$:
	CALLG	g^closarg,NETCLS	;close the net channel
	RET

; BASHUCB - AREA TO MESS UP UCB WITH OUR FILE DATA
; BEWARE BEWARE BEWARE
;  runs in KERNEL mode ... HAS to be right.

	.ENTRY	BASHUCB,^M<R2,R3,R4,R5,R6,R7,R8>
; TAKEN LOOSELY FROM ZERO.MAR
; Obtains host's PID, and also sets up correct size in driver UCB
; both by cylinder and by block.
	.if	df,$$xdt
	jsb	g^ini$brk	;call xdt
	.endc
	.if	ndf,vms$v5
	MOVL	G^SCH$GL_CURPCB,R4	;;; NEED OUR PCB
	.iff
	MOVL	G^CTL$GL_PCB,R4		;;; NEED OUR PCB (VMS V5)
;;; (gets it in internal form, just as needed)
	.endc
;;; NEED IPID FOR DRIVER'S CALL TO SCH$POSTEF TO THIS HOST!!
	MOVL	PCB$L_PID(R4),OURPID	;;;SAVE OUR PID IN INTERNAL FORM
	JSB	G^SCH$IOLOCKW		;;; LOCK I/O DATABASE
	CLRL	HSTUCB			;;; ZERO "HOST" UCB
	movl	8(ap),r1		;;;get mailbox info first
	jsb	g^ioc$searchdev
	blbc	r0,59$			;;;on failure, give up
	movl	r1,mbucb		;;;store away mailbox UCB
	MOVL	4(AP),R1		;;; ADDRESS DVC NAME DESCRIPTORS
	JSB	G^IOC$SEARCHDEV		;;; GET UCB ADDRESS INTO R1
	BLBS	R0,60$
59$:	BRW	BSH_XIT
60$:
; BUGGER THE UCB
; ASSUMES FILE LBN AND SIZE ALREADY RECORDED
; ALSO ASSUMES THAT ZERO LBN OR SIZE MEANS THIS ENTRY NEVER CALLED.
; (REALLY ONLY WORRY ABOUT ZERO SIZE; IF WE OVERMAP A REAL DEVICE
; THEN ZERO INITIAL LBN COULD BE OK.)
;
; Do NOT set device size here; we do that in the initial connect
; code in the driver, which sets up geometry also.
	cmpl	#^xA9876543,ucb$l_sanity(r1)	;check we really have frdriver
	beql	56$
	movl	#ss$_illiofunc,r0
	brw	bsh_xit
56$:
	movl	#fbufsiz,ucb$l_maxbcnt(r1)	;;;reset max byte cnt xfer
	movl	#<dev$m_fod+dev$m_dir+dev$m_avl+dev$m_shr+dev$m_idv+dev$m_odv+dev$m_rnd>,ucb$l_devchar(r1)
;	MOVL	#ZR_blocks,UCB$L_MAXBLOCK(R1) ;;; (SAVE SIZE TWICE, FOR RMS
;	MOVL	#ZR_cyl,R0		;;; GET HOST SIZE IN CYLINDERS
;	MOVW	R0,UCB$W_CYLINDERS(R1)	;;; SAVE IN UCB FOR REST OF VMS
; This computation is redone in ZRdrv itself, but do it here also.
; It assumes in ZRdrv that there are 64 sectors/cylinder.
	movl	ctlfgs,ucb$l_ctlfgs(r1)	;save sanity stuff
	.if	ndf,evax
	BISW	#UCB$M_ONLINE,UCB$W_STS(R1) ;;; FLAG ONLINE NOW
	BISW	#UCB$M_VALID,UCB$W_STS(R1) ;;; AND VOL VALID
	.iff
	BISL	#UCB$M_ONLINE,UCB$L_STS(R1) ;;; FLAG ONLINE NOW
	BISL	#UCB$M_VALID,UCB$L_STS(R1) ;;; AND VOL VALID
	.endc
;;; THAT'S IT... SHOULD BE OK NOW.
	MOVL	#SS$_NORMAL,R0
BSH_XIT:
	PUSHL	R0
	JSB	G^SCH$IOUNLOCK		;;; UNLOCK I/O DATABASE (DROP IPL)
	POPL	R0			;;; REMEMBER R0
	RET	;;; BACK TO USER MODE NOW
; EXIT HANDLER
; CLEARS I/O ASSIGNMENT TO ZR: UNIT
;
	.ENTRY	XITHDL,^M<R2,R3,R4,R5,R6>
	TSTL	IOPROG
	BEQL	1$
	MOVL	#1,SETZR	;TERMINATE I/O PACKET
	MOVL	BUFHDR,SETZR+4	;SAVE TRANSFER DIRECTION
	MOVL	BUFHDR+4,SETZR+8	; BLOCK #
	MOVL	BUFHDR+8,SETZR+12	; NO. BYTES IN BUFFER
	MOVZWL	#SS$_DRVERR,SETZR+16	; IOSB 1
;	MOVZWL	#SS$_ACCVIO,SETZR+16	; IOSB 1
	CLRL	SETZR+20	; IOSB 2	; FAILURE
	movl	#setZRl,r4
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=R4
1$:
	CLRL	SETZR	;DECLARE/UNDECLARE
	PUSHAB	DESBLK		; ADDRESS OF DESBLK
	CALLS	#1,G^SYS$CANEXH	; CANCEL EXIT HANDLER
	clrl	setZR+4	;FLAG NOBODY HOME NOW
	clrl	setZR+8
	movl	#setZRl,r4
	$qiow_s efn=#1,chan=vdchn, -
	iosb=iosb,func=#<io$_format+128>,p1=setZR,p2=R4
; declare host no longer is home.
	CALLG	g^closarg,NETCLS	;close the net channel
; Just ignore it if the close arg fails
	movl	#1,r0		;signal all's well
	RET			; FINISH EXIT
; netfix routine closes and reopens the net link. If netchn = 0
; on return, it failed.
	.if	df,evax
netfix: .jsb_entry
	.iff
netfix:
	.endc
	pushl	r4
; First close the net channel so we can reuse it.
	CALLG	g^closarg,NETCLS	;close the net channel
	clrl	netchn
	pushab	xsec		;wait 3 seconds
	calls	#1,g^lib$wait	;to give things a chance to clear
; Now reopen the net channel (and get the size info from the server)
;(we junk the size, since we got it earlier.)
	CALLG	G^OPENARG,NETOPN	;OPEN THE NET
	tstl	netchn		;got a channel?
	beql	75$		;no. error exit.
	tstl	netblks		;nonzero size (REQUIRED!!!)
	bneq	75$		;no, lose now...
	CALLG	g^closarg,NETCLS	;close the net channel
	clrl	netchn	;flag caller we failed
		;then scram
75$:
	popl	r4		;need r4 intact for our QIO
	rsb
	.END ZRHostD