



		    bootload_disk_post.pl1          11/11/89  1105.1rew 11/11/89  0803.9       17091



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bootload_disk_post: proc (coreadd, errcode);

/* Routine to post bootload disk i/o completions.
Written in June 1983 by Keith Loepere. */

/* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */

dcl  addr			        builtin;
dcl  coreadd		        fixed bin (26) parameter; /* mem addr i/o finished into */
dcl  errcode		        fixed bin (35) parameter; /* word of flags signalling successful/bad i/o */
dcl  i			        fixed bin;		/* loop counter */
dcl  sys_info$initialization_state    fixed bin ext;
dcl  syserr		        entry options (variable);

	if sys_info$initialization_state ^= 1 then go to crash;
	disk_post_area_ptr = addr (bootload_disk_post_seg$);
	do i = 1 to disk_post_area.number;
	     if disk_post_area.buffer_coreadd (i) = coreadd then do;
		if disk_post_area.disk_complete (i) then go to crash;
		disk_post_area.disk_complete (i) = "1"b;
		disk_post_area.disk_error_code = errcode;
		return;
	     end;
	end;
crash:	call syserr (CRASH, "bootload_disk_post: Attempt to post non-requested i/o completion.");
	return;
%page;
%include bootload_post_area;
%page;
%include syserr_constants;
%page;

/* BEGIN MESSAGE DOCUMENTATION

  Message:
  bootload_disk_post: Attempt to post non-requested i/o completion.

  S: $crash

  T: $init

  M: disk_control detected an i/o completion that Bootload Multics does
  not believe it requested.

  A: Reboot.

  END MESSAGE DOCUMENTATION */

     end;




		    cam_cache.alm                   11/11/89  1105.1rew 11/11/89  0803.9       94941



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"                                                                    "
"	cam_cache					         "
"                                                                    "
"	Subroutine to clear ptw associative memory and (optionally)"
"	cache memory on this and all other processors.	         "
"	The subroutine will not return until this has been         "
"	accomplished.                                              "
"                                                                    "
"	This subroutine has two sets of entry points.  One set     "
"	consists of entry points callable only from within         "
"	bound_page_control (via tsx7).  For these, arguments are   "
"	passed via the pxss/page_fault stack frame.  The other     "
"	set consists of entry points callable externally (via      "
"	the transfer-module page.  For these, arguments are        "
"	passed in the usual (PL/1) manner.                         "
"                                                                    "
"	The only possible parameter to cam_cache entry points is   "
"	an absolute memory address for selective cache clearing    "
"	For calls from within bound_page_control, this address is  "
"	passed in cell core_add in the stack frame.  For external  "
"	calls, the PTW of the page containing the target address   "
"	for selective clearing is passed in Argument 1.            "
"                                                                    "
"	The functions performed by the subroutine are as follows,  "
"	with the internal and external entry points:               "
"                                                                    "
"	Clear all ptw associative memory, selectively clear cache  "
"		cam_cache	(internal)                             "
"		cam_cache_ext (external)                         "
"                                                                    "
"	Clear all ptw associative memory, clear all cache          "
"		cam (internal)                                   "
"		cam_ext (external)                               "
"                                                                    "
"	Clear all ptw associative memory                           "
"		cam_ptws (internal)	                             "
"		cam_ptws_ext (external)                          "
"                                                                    "
"	Clear all ptw associative memory, selectively clear cache, "
"	     set scs$cam_wait so that all other processors wait    "
"	     for scs$cam_wait to be cleared before resuming.       "
"		cam_with_wait (internal)                         "
"		cam_with_wait_ext (external)		         "
"                                                                    "
"
"                                                                    "
"	The protocol for multi-processor clearing is as follows:   "
"                                                                    "
"		This processor obtains the connect lock.         "
"                                                                    "
"		Under the connect lock, the processor            "
"		   1. sets scs$cam_pair to the instructions      "
"		      which do the clearing                      "
"		   2. sets the scs$fast_cam_pending cell         "
"		      non-zero for all other processors          "
"		   3. if this is a cam-with-wait call, sets      "
"		      the appropriate bit in scs$cam_wait for    "
"		      all other processors                       "
"		   4. sends a connect to all other processors    "
"		   5. XED's the code in scs$cam_pair             "
"		   6. waits for all scs$fast_cam_pending cells   "
"		      to clear (indicating clearing done by      "
"		      all other processors).                     "
"		   7. releases the connect lock and returns      "
"		Note - if only one processor is active, most     "
"		   of this is skipped.                           "
"                                                                    "
"		Upon receipt of a connect, all other processors  "
"		   1. if its scs$fast_cam_pending cell is set,   "
"		      XED the code in scs$cam_pending and        "
"		      clear it scs$fast_cam_pending cell         "
"		   2. if its bit in scs$cam_wait is set, wait    "
"		      for that bit to clear (this clearing is    "
"		      done by the caller of cam_cache on the     "
"		      originating processor).                    "
"                                                                    "
"                                                                    "
"	There are only two ways a conect fired to another          "
"	processor can be lost.  One is hardware failure, and the   "
"	other is a processor put into step mode before the connect "
"	and taken out of step mode after the connect.  There is    "
"	a hedge against the latter here.  If all processors have   "
"	not responded within an unreasonable amount of time, the   "
"	connects are re-issued, and the waiting begins anew.       "
"	This hedge should not be construed as implicitly condoning "
"	putting a cpu on a multi-processor in step mode.  It may   "
"	help in truly strange circumstances.                       "
"                                                                    "
"                                                                    "
"	This code was copied from page_fault and modified for      "
"	fast connects by J. Bongiovanni in February 1981.          "
"	Modified September 1983, E. N. Kittlitz per S. Harris      "
"	  (UNCA) to not destroy temp_2/x0 if lock contention       "
"                                                                    "
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

	name	cam_cache
	segdef	cam_cache,cam_cache_ext
	segdef	cam,cam_ext
	segdef	cam_ptws,cam_ptws_ext
	segdef	cam_with_wait,cam_with_wait_ext

	iftarget	adp
	  warn	(WARNING: cam_cache has not been converted for the ADP.)
	ifend

channel_mask_set:
	oct	17,17

"
cam_cache_ext:			" external entry for coreadd cache clear
	stz	pds$temp_2		turn off wait flag
	lda	ap|2,*		PTW is passed in
	tsx7	cj1b		merge with common code
.rt:	short_return		" exit

cam_cache:			" entry to cam and clear cache
	stz	pds$temp_2		turn off wait flag
cj1a:	lda	core_add		put core_add in pds
	als	coreadd_to_ptw.ls	shift to AU
cj1b:	ana	ptw_add_mask,du	mask extraneous bits
	sta	pds$temp_1
	eax0	0		set flag for PTW clear with cache
	tra 	cam_join_1	join common code

cam_ext:	push

	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+>
	lxl1	prds$processor_tag	get set for masking
	lprpab	scs$mask_ptr,1
	xec	scs$read_mask,1
	staq	temp	
	lxl1	prds$processor_tag	we may have lost the processor
	lprpab	scs$mask_ptr,1
	ldaq	scs$sys_level
	xec	scs$set_mask,1

	tsx7	cam		join common code

	ldaq	temp		retrieve previous mask
	oraq	channel_mask_set	turn on all channel mask
	anaq	scs$open_level	turn off unconfigured channel mask bits
	lxl1	prds$processor_tag
	lprpab	scs$mask_ptr,1
	xec	scs$set_mask,1
	inhibit	off	<-><-><-><-><-><-><-><-><-><-><-><->

	return

cam:				"camp and cams, clear all cache
	eax0	4
	tra	cam_join_0	set switch not to full Cam

cam_with_wait_ext:
	stc1	pds$temp_2	" external entry issue a cam 
				" and set scs$cam_wait
	eax7	.rt
	lda	ap|2,*
	tra	cj1b

cam_with_wait:			" entry from evict_page
	stc1	pds$temp_2		set wait flag
	tra	cj1a

cam_ptws_ext:			" remove only PTWs from AMs
	eax7	.rt
cam_ptws:
	eax0	2

cam_join_0:
	stz	pds$temp_2		set no wait sw
cam_join_1:
	nop	0,du		allow for lockup fault reset, other CPU connect
	nop	0,du		ditto
	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+>
	lda	prds$processor_pattern  exclude this processor
	era	=-1		..
	ana	scs$processor	find which processors are running
	tnz	hard_cam		hard case, multiple processors

	ldx1	pds$temp_1		prepare for cache selective cam, if needed
	xed	cam_table,0	execute proper type of cam
	tra	0,7

hard_cam:
	lda	pds$processid	lock the connect lock
	stac	scs$connect_lock	..
	tnz	cam_join_1	wait on other CPU without destroying x0, temp_2
	szn	pds$temp_2		see if waiting case
	tze	wait_join		tra if no
	lda	prds$processor_pattern  set flags for other processor(s)
	era	=-1		..
	ana	scs$processor	but not for this processor
	sta	scs$cam_wait	set key word in scs

wait_join: 
	eax0	0,0		test xr0 for coreadd case
	tze	hard_cam_with_coreadd
	ldaq	cam_table,0	access proper cams
	tra	cam_join_2

hard_cam_with_coreadd:
	ldaq	cam_other_for_cache	get instructions for relocation
	ora	pds$temp_1		insert selective clear addr
cam_join_2:
	staq	scs$cam_pair	set up for all cpu's
repeat:
	eax0	0		start counting with 0
	ldq	0,dl		keep track of array size
	lda	prds$processor_pattern   set up for all processors
	era	=-1		except us
	ana	scs$processor	which are running
nextp:	stz	scs$fast_cam_pending,0  clear cell just in case
	tpl	missing		processor not running or am us
	stc1	scs$fast_cam_pending,0  flag for cam/cache clear
	cioc	scs$cow_ptrs,0*	send connect
missing:	eax0	1,0		bump to next processor
	adq	4,dl		bump array size in chars
	als	1		shift bit pattern to next cpu high
	tnz	nextp		more processors running
	xed	scs$cam_pair	clear our own

	inhibit	off	<-><-><-><-><-><-><-><-><-><-><-><->
	lda	1000,dl		bail-out of loop limit
	epplb	scs$fast_cam_pending array of check-off cells
wait:	sba	1,dl		one more loop
	tmi	repeat		try entire cycle again
	cmpc	(),(pr,rl),fill(0)	check entire array clear
	desc9a	0,0
	desc9a	lb|0,ql
	nop
	nop
	tnz	wait		all cells haven't cleared

	lda	0,dl		clear the connect lock now
	ansa	scs$connect_lock	..
	tra	0,7

	even
cam_table:			"table of appropriate CAM pairs
	camp	4,1		"clear selective cache and ptws
	nop

	camp			"clear just ptws
	nop

	camp			"clear ptws
	cams	4		"and all cache

cam_other_for_cache:
	camp	4		"clear selective cache and ptws
	nop	0,du

"
	include	pxss_page_stack
	include	page_info

	end
	




		    core_queue_man.alm              11/11/89  1105.1r w 11/11/89  0803.9       56529



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

"
"	core_queue_man --- obscure program to
"	manage locks which manage the locking of locks.

"	Bernard Greenberg 12/06/76
"	Modified for concurrent scheduler, RE Mullen 5/16/77
"
"	core queue is ordered queue of postings to be done, wich
"	could not be done because ptl was locked. Since all
"	ptl unlocking is done under cql, no requests are ever lost.


	segref	page_fault,savex,unsavex,init_savex_bb,page_fault_error

	segdef	disk_post,unlock_ptl,trylock_ptl,run_core_queue,clearout

	entry	ptl_notify_return

	equ	cq,1


	include	disk_post_queue


"
disk_post:
	push			"args to stack..
	lda	ap|2,*
	sta	core_add
	lda	ap|4,*
	sta	errcode
	tsx6	init_savex_bb

	eaq	lock_and_done	assume complicated entry
	lda	pds$processid	new mylock dones?
	cmpa	sst|sst.ptl
	tnz	*+2		go on with lock_and_done if ^=
	eaq	page_fault$done_
	tsx7	0,qu
	return

"
" - - - - - - - - - - - - - - - - - - - - - - - - - -
"

unlock_ptl:			"from page fault...
				"push done, lp set, bb set, x7 is ret.
	tsx6	savex
	tra	unlock_ptl_test_postq


lock_and_done:
	tsx6	savex		save x7

	tsx7	trylock_ptl	can we get the PTL?
	 tra	done_fails_ptl	tra if not.

do_the_done:
	tsx7	page_fault$done_	have ptl, will post

unlock_ptl_test_postq:
	tsx7	looplock_cql	grab the posting queue

test_postq:
	tsx7	dequeue_posting	see if posting to be done...
	 tra	unlock_ptl_real	no, unlock ptl and cql.

	tsx7	unlock_cql	unlock cql, there is posting,
	tra	do_the_done	and do it.

"
"	Disk interrupt has failed to grab the PTL.
"	Enqueue the data from stack.
"

done_fails_ptl:
	tsx7	looplock_cql	grab cql. This assures no-one can
				"unlock ptl until we unlock cql.
	tsx7	enqueue_posting
	 tra	queue_overflow	no more room... looplock the ptl

	tsx7	trylock_ptl	see if we can get ptl, for we have no guarantee that
				"ptl holder didnt go away right before
				"line at done_fails_ptl.
	 tra	*+2		"if ptl fails, guaranteed that enqueuement
				"will be picked up.
	tra	test_postq	"However, if we get it, we can now
				"do postings (both locks locked here.)
	tsx7	unlock_cql	"don't have ptl, we deposited, so unlock cql
	tra	unsavex		and return.

"
"	Queue overflown. Loop lock the PTL.
"
queue_overflow:
	aos	cq|cq.overflows

	tsx7	unlock_cql	done with cq

	tsx7	page_fault$lock_ptl_no_lp
				"this guy doesn't kid around.
	tra	do_the_done

"
"	Can now unlock ptl, for all posting is done, and anybody
"	who's trying to enqueue must wait for cql.
"
unlock_ptl_real:
	tsx7	actual_ptl_unlock_code  he really, really does it.
	tsx7	unlock_cql

	szn	sst|sst.ptl_wait_ct	anybody wanna know?
	tze	unsavex		no, return to caller of core_queue_man

"
"	Notify single PTL waiting process via pxss.
"
	tra	pxss$ptl_notify	which returns to cqm$ptl_notify_return
ptl_notify_return:
	epp	sst,sst$		for luck ..
	tra	unsavex		return to call of core_queue_man

"
"	Entry to make sure this thing isn't stuck.
"	The thing is called from dvctl$run with the
"	entire pc environment set up and the ptl locked
"	during the entire exercise.
"
"
run_core_queue:
	tsx6	savex
	
run_core_queue_loop:
	tsx7	looplock_cql

	tsx7	dequeue_posting
	 tra	run_core_queue_done

	tsx7	unlock_cql
	tsx7	page_fault$done_	do the done
	tra	run_core_queue_loop

run_core_queue_done:
	tsx7	unlock_cql
	tra	unsavex

"
"	Entry to clear the thing out at ESD time to validate
"	assumptions of pc_recover_sst (no "fatal_error in done!")
"

clearout:
	epp	cq,disk_post_queue_seg$

	stz	cq|cq.lock
	stz	cq|cq.put_ptr
	stz	cq|cq.get_ptr
	stz	cq|cq.number_in_queue
	tra	0,7

"

"
"	Coreadd queue management.
"

looplock_cql:			"must be looplock to avoid
				"russian doll lock syndrome.

	rccl	sys_info$clock_,*
	staq	temp

	epp	cq,disk_post_queue_seg$+0
	aos	cq|cq.lockings

	lda	pds$processid
	stac	cq|cq.lock
	tze	*+5
	nop
	nop
	nop
	tnz	*-5
	cmpa	cq|cq.lock	never trust this hw
	tze	*+2
	tsx5	page_fault_error	"ERROR - MYLOCK ON DISK POST QUEUE
	rccl	sys_info$clock_,*
	staq	temp1		save for under-lock metering
	sbaq	temp
	adaq	cq|cq.looplock_time
	staq	cq|cq.looplock_time

	tra	0,7


unlock_cql:

	epp	cq,disk_post_queue_seg$+0  NO CHANCES
	rccl	sys_info$clock_,*
	sbaq	temp1
	adaq	cq|cq.process_time
	staq	cq|cq.process_time
	ldq	pds$processid
	cmpq	cq|cq.lock
	tze	*+2
	tsx5	page_fault_error	"ERROR - STAC FAILS DISK POST QUEUE
	eaa	0
	stacq	cq|cq.lock
	tze	*+2
	tsx5	page_fault_error	"ERROR - UNLOCK ERR DISK POST QUEUE
	cmpq	cq|cq.lock
	tnz	0,7
	tsx5	page_fault_error	"ERROR - STACQ HW FAILS DISK POST QUEUE
"
"
"	Enqueue and dequeue.  cq -> seg.
"

enqueue_posting:
	ldq	cq|cq.number_in_queue
	cmpq	cq_limit,dl	all full?
	tpl	0,7		error exit

	aos	cq|cq.queueings	meter

	aos	cq|cq.number_in_queue
	ldx1	cq|cq.put_ptr
	lda	core_add
	ldq	errcode

	staq	cq|cq.queue,1

	eax1	2,1
	cmpx1	2*cq_limit,du
	tmi	*+2
	eax1	0
	stx1	cq|cq.put_ptr

	tra	1,7


dequeue_posting:
	szn	cq|cq.number_in_queue
	tze	0,7		exit no stuff

	lcq	1,dl
	asq	cq|cq.number_in_queue
	tpl	*+2
	tsx5	page_fault_error	"ERROR - DISK POST QUEUE CT NEGATIVE

	ldx1	cq|cq.get_ptr
	ldaq	cq|cq.queue,1
	sta	core_add
	stq	errcode

	eax1	2,1
	cmpx1	2*cq_limit,du
	tmi	*+2
	eax1	0
	stx1	cq|cq.get_ptr

	tra	1,7
"
"
"	Real page_table lockery.
"

trylock_ptl:
	lda	pds$processid
	cmpa	sst|sst.ptl
	tze	page_error$ptl_mylock

	stac	sst|sst.ptl
	tnz	0,7		fail

	cmpa	sst|sst.ptl
	tze	1,7
	tsx5	page_fault_error	"ERROR - STAC FAILS PTL


"
"	Real page_table_lock unlockery
"

actual_ptl_unlock_code:
	ldq	pds$processid
	lda	0,dl
	stacq	sst|sst.ptl	unlock it
	tze	*+2
	tsx5	page_fault_error	"ERROR - PTL UNLOCK FAILS
	nop
	cmpq	sst|sst.ptl	double-check hw
	tnz	0,7

	tsx5	page_fault_error	"ERROR - PTL STACQ HW FAILS
"
	include	sst

	include	pxss_page_stack

	include	page_info
	end




		    dctl.alm                        11/11/89  1105.1r w 11/11/89  0804.0      373239



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(85-09-09,Fawcett), approve(85-09-09,MCR6979),
"     audit(86-01-27,CLJones), install(86-03-21,MR12.0-1033):
"     Add support for dev 0 FIPS.
"  2) change(86-05-29,Fawcett), approve(86-05-29,MCR7383),
"     audit(86-05-30,Coppola), install(86-07-17,MR12.0-1097):
"     Add code for MSU3380 and MSU3390 support. This code supports the
"     division of the devices into subvolumes. Also read 512 word sectors are
"     supported by only doing 512_word seek command (30 oct). Multics will not
"     support 64_seeks for these devices.
"  3) change(86-09-10,Farley), approve(86-10-24,MCR7544),
"     audit(86-10-27,Fawcett), install(86-10-28,MR12.0-1200):
"     Added change to properly shift the TEST I/O command in the A-reg before
"     storing in chantab.rssdcw.
"                                                      END HISTORY COMMENTS

	name	dctl

" dctl - fast path for disk control, coded in ALM for obvious reasons
"
" Written sometime by someone (possibly Mullen)
" Modified by Fawcett 1979 for shared stack frames
" Modified back by Hornig December 1980
" Modified March 1981 by J. Bongiovanni to add entry queue_length_given_pvtx
" Modified July, 1981, WOS, to implement Mike Jordan's fix to the 501 sector number
"  overflow problem (too many sectors to represent in 20 bits).
" Modified February 1982 by C. Hornig for MR10 io_manager.
" Modified March 1982 by J. Bongiovanni to remove queue_length_given_pvtx
"         (moved to disk_control) and for new PVTE
" Modified March 1982 by C. Hornig to unload disks.
" Modified July 1982 by J. Bongiovanni for read_sectors, write_sectors
" Modified April 1984 by T. Oke for system wide free_q.
" Modified April 1984 by T. Oke for dynamic channel table and the use of
"	dskdcl_chans_per_subsys to define channel idx/subsystem relation.
" Modified May 1984 by T. Oke to add pvtx in queue entry for azm analysis
"	of queue.
" Modified May 1984 by T. Oke to install adaptive optimization, modifying
"	the quentry structure.
" Modified Nov 26,1984 by R. A. Fawcett to suppoer dev 0 (fips).
" Modified February 1985 by Keith Loepere to re-install bootload_read/write
"	which was broken by one of the above recently named.
" Modified April 1985 by R. A. Fawcett to support real 512 work IO for 3380's.
" Modified July 1985 by R. A. Fawcett to support sub-volumes on 3380/3390's
" ============================================================================
	
	tempd	int_arg_list
	tempd	meter_start_time,status_time,entry_time,test_time
	tempd	ptp,mask		Used for pmut$wire_and_mask
	tempd	arglist(3)
	tempd	listp
	tempd	ima(8)
	temp	coreadd
	temp	sect_off,record_offset
	temp	devadd
	temp	errcd
	temp	real_device
	temp	sect_sw		Uses upper bit (sign) to indicate sect
	temp	bootload_sw	Ditto for bootload
	temp	sx		Subsystem index in DL
	temp	pvtx
	temp	dev
	temp	sector
	temp	cylinder
	temp	io_type		Io type stored in DL
	temp	masked		Non-zero if call side running masked
	temp	intrpt		Caller requested interrupt on complete
	temp	temp1
	temp	switches
	temp	best_seek		Also is best_pos_comb
	temp	comb_qp		DU has forward comb qp, DL has reverse
	temp	best_neg_comb
	temp	n_sectors,n_sectors_temp
"
	entry	disk_inter
	entry	disk_read
	entry	disk_write
	entry	bootload_read
	entry	bootload_write
	entry	read_sectors
	entry	write_sectors

"	REGISTER USAGE:
"	bb -> disk_seg base, disk_data
"	bp -> disktab, per subsystem info
"	ap -> chantabe
"	lb -> pvte, DCW list, devtabe (when opt_info access needed)

"	x0 = pdi
"	x1 temp
"	x2-> devtab
"	x3-> quentry
"	x4 temp
"	x5 temp
"	x6 call savex	(top level calls)
"	x7 calls		(lower level)


"     The ALM assembler must border on the least friendly assembler known
"     to man.  So some techniques are in force through this program to aid
"     in the detection of error conditions due to movement of structure
"     contents.

"     Specifically there is quite a bit of use of the construction:
"
"	equ	quentry.coreadd_shift,0
"
"     This construction will cause an error if the value of the shift is not
"     zero, AS WE ARE PRESUMING IT TO BE.  Thus we can produce fast code, with
"     extra supurflous instructions removed, but still detect if they would be
"     necessary if things move.  Hopefully these little checks will do someone
"     good in the future.

	equ	MUST_BE_ZERO,0	Used for 0 check
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	CALL SIDE OF DISK DIM -- various entries
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

write_sectors:
	push
	ldx4	VTOC_WRITE,du
	tra	go_sector

read_sectors:
	push
	ldx4	VTOC_READ,du
	tra	go_sector

bootload_read:
	push
	ldx4	BOOTLOAD_READ,du
	tra	go_sector

bootload_write:
	push
	ldx4	BOOTLOAD_WRITE,du
	tra	go_sector

go_sector:
	sxl4	io_type
	lda	ap|10,*			pick up number of sectors
	sta	n_sectors
	ldq	ap|8,*			pick up sect_off arg
	stq	sect_off
	stz	intrpt			clear interrupt desired
	ldq	bootload_mapping,du		" IO type still in x4
	qls	0,x4
	tpl	go_vtoc
	stz	masked
	tra	go_common

"     wire stack frame for vtoc_man

go_vtoc:
	epplb	mask
	sprilb	arglist+2
	epplb	ptp
	sprilb	arglist+4
	ldaq	two_args_nd
	staq	arglist
	call	pmut$wire_and_mask(arglist)
	lda	1,dl
	sta	masked			in masked environment
	tra	go_common


disk_write:
	push
	ldx4	PAGE_WRITE,du
	tra	go_page

disk_read:
	push
	ldx4	PAGE_READ,du

go_page:
	sxl4	io_type
	stz	n_sectors
	stz	sect_off			sect_off = 0
	stz	masked			not in masked environment
	stz	intrpt
	lda	ap|8,*			pick up priority arg
	tze	no_intrpt			intrpt="0"b
	lda	quentry.intrpt,du		intrpt=quentry.intrpt
no_intrpt:
	sta	intrpt

go_common:				" Common command interface
	lda	ap|4,*
	als	12			MASK FOR COREADD
	arl	12
	sta	coreadd
	lda	ap|6,*
	arl	18
	sta	devadd

	rccl	sys_info$clock_,*		get entry time for stats
	staq	entry_time	GET PVTE for device

	epplb	pvt$array
	ldq	ap|2,*			get pvtx
	stq	pvtx			save for queue entry
	mpy	pvte_size,dl
	epplb	lb|-pvte_size,ql		HENCEFORTH lb -> PVTE
	lda	lb|pvte.dim_info
	arl	pvtdi.sx_shift
	sta	sx
	tsx7	setup

	eax4	disktab.call_lock_meters	specify lock reason
	tsx7	lock

	ldq	lb|pvte.logical_area_number_word
	qrl	pvte.logical_area_number_shift
"""""	anq	pvte.logical_area_number_mask,dl  This mask bigger than next
	anq	quentry.dev_mask,dl
	stq	dev			device in sub-sys

	ldx2	devtab_subs,ql		subscript devtab
	ldq	bp|devtab.pdi_word,x2	devtab.pdi
	equ	devtab.pdi_shift,0		PRESUMED 0
"""""	qrs	devtab.pdi_shift
	anq	devtab.pdi_mask,dl
	eax0	0,ql			HENCEFORTH X0 = pdi
	ldx2	devtab_subs,x0		subscript devtab
	eax2	bp|0,x2			HENCEFORTH X2->devtab

"     The following code is out, since we will try the abandoned device
"     will get an error return, and it will be handled by disk_control
"     error processing.  Thus disk_control eventually finds out.

"""""	lda	bb|devtab.abandoned_word,x2
"""""	cana	devtab.abandoned,du
"""""	tnz	ABANDONED

"     Allocate a quentry for this operation

	aos	bp|disktab.alloc_wait_meters+disk_lock_meters.count
	tsx7	get_free_q		HENCEFORTH X3->quentry
	arg	got_fq			get_free_q success
"Failed to find free quentry. Call RUN.
	eax4	disktab.alloc_wait_meters	meter this time as alloc wait
	tsx6	lock_meter_start
retry_get_fq:
	tsx7	get_free_q
	arg	retry_got_fq
	eppap	sx
	spriap	arglist+2
	ldaq	one_arg_nd
	staq	arglist
	call	disk_control$call_run(arglist)
	tra	retry_get_fq


retry_got_fq:
	eax4	disktab.alloc_wait_meters	time metered as alloc wait
	tsx6	lock_meter_stop	Compute cylinder and sector -- remember them in stack

got_fq:	ldq	devadd
	lda	lb|pvte.is_sv_word
	cana	pvte.is_sv,du
	tze	not_subvol    " pvte does not define sv "
	div	lb|pvte.records_per_cyl
	sta	record_offset
	ldq	devadd
	sblq	record_offset
	mpy	lb|pvte.num_of_svs
	adlq	lb|pvte.record_factor
	adlq	record_offset
not_subvol: 
	lda	lb|pvte.device_type_word
	arl	pvte.device_type_shift
	ana	pvte.device_type_mask,dl
	eax1	0,al
	mpy	sec_per_rec,x1		" mpy by 16 for 64 word io and 2 for 512 word io
	stq	sector

	lda	lb|pvte.dim_info
	ars	pvtdi.usable_sect_per_cyl_shift
	ana	pvtdi.usable_sect_per_cyl_mask,dl
	sta	temp1
	div	temp1			into sector in Qreg
	stq	cylinder

	ldq	lb|pvte.dim_info
	equ	pvtdi.unused_sect_per_cyl_shift,0	PRESUMED = 0
""""""	qrs	pvtdi.unused_sect_per_cyl_shift
	anq	pvtdi.unused_sect_per_cyl_mask,dl
	mpy	cylinder
	adq	sect_off
	asq	sector

"     Fill in quentry contents
"     quentry.intrpt, used, type, coreadd
" PRESUMES that type,intrpt,used and coreadd are in the same quentry word.

	equ	quentry.type_word,1		All presumed in word 1
	equ	quentry.intrpt_word,1
	equ	quentry.used_word,1
	equ	quentry.coreadd_word,1
	equ	MUST_BE_ZERO,quentry.coreadd_shift

	lda	io_type
	als	quentry.type_shift		get io_type of operation
	ora	intrpt			Set interrupt flag
	ora	quentry.used,du		indicate entry is used
	ora	coreadd			presume shift is 0
	sta	bb|quentry.type_word,x3
	

"     quentry.pvtx, pdi, dev, cylinder
" PRESUMES that pvtx,cylinder,dev and pdi are in the same quentry word.

	equ	quentry.pvtx_word,2		Presumed in word 2
	equ	quentry.pdi_word,2
	equ	quentry.dev_word,2
	equ	quentry.cylinder_word,2
	equ	MUST_BE_ZERO,quentry.cylinder_shift

	lda	pvtx
	als	quentry.pvtx_shift
	ora	cylinder			presume cylinder shift is 0
	sta	bb|quentry.pvtx_word,x3
	eaa	0,x0			pdi from X0
	als	quentry.pdi_shift-18
	orsa	bb|quentry.pdi_word,x3
	lda	dev
	als	quentry.dev_shift
	orsa	bb|quentry.dev_word,x3


"     quentry.n_sectors, sector
" PRESUMES that n_sectors and sector are in the same quentry word.

	equ	quentry.n_sectors_word,3	Presume in word 3
	equ	quentry.sector_word,3
	equ	MUST_BE_ZERO,quentry.sector_shift

	lda	n_sectors
	als	quentry.n_sectors_shift
	ora	sector			include sector number
	sta	bb|quentry.sector_word,x3

"     Fill in queued time.

	ldaq	entry_time
	staq	bb|quentry.time,x3

"
"Provided the disk dim is functioning correctly on the interrupt side
"then if there are already requests queued for this device
"then there is no chance we can immediately issue a connect for this request.
"Therefore we merely queue the request and return.
"The same is true if the device is busy already.
"On the other hand if the device is neither busy nor has a queue already
"then if there is a free channel then we need not even add the quentry
"to the queue, but instead issue the connect forthwith.

"     X3 -> quentry, X0 = pdi, X2 -> devtab (pdi)

	ldaq	bp|disktab.dev_busy
	oraq	bp|disktab.dev_queued
	lls	0,x0			X0 has PDI ..
	tmi	call_side_queues		this PDI is busy or queued

	ldx4	bp|disktab.channels		find dynamic table
	eppap	bb|0,x4			AP -> (first)chantabe

	lxl4	bp|disktab.nchan
	tze	call_side_queues		no channels exist - queue it

	ldaq	channel_criteria		bit and mask for testing
call_chan_loop:
	cmk	ap|chantab.in_use_word
	tze	call_side_connects		channel available - use it
	eppap	ap|chantab_size		try next channel
	eax4	-1,x4			if there is another channel
	tpnz	call_chan_loop

"     Add to existing work queue for device and fast return

call_side_queues:				" io_type (DL) must be good
	tsx7	add_wq
	tra	working

"     Have channel and no queued requests for idle device - send it work

call_side_connects:
	tsx7	gotwork
working:	tsx7	unlock		unlock and return
	szn	masked		see if we are masked
	tze	unwired

"     We are wired and must clear wiring before return

	epplb	mask
	sprilb	arglist+2
	epplb	ptp
	sprilb	arglist+4
	ldaq	two_args_nd
	staq	arglist
	call	pmut$unwire_unmask(arglist)

unwired:	return


"for ldaq/cmk above:A has bits desired, Q has 1bits to mask dont-care bits
"we require a channel which is in-use, and not-active

	even
channel_criteria:
	zero	0,chantab.in_use
	zero	-1,-chantab.in_use-chantab.active-1
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	SETUP -- called with sx in Areg
"		makes bb->disk_seg
"		makes bp->devtab
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

setup:	eppbb	disk_seg$
	als	1
	eppbp	bb|disk_data.array-2,al*
	tra	0,7		setup returns



" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	LOCK -- locks bp->disktab (ie a subsystem)
"		called with x4->metercells
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

lock:	aos	bp|disk_lock_meters.count,x4
	lda	pds$processid
	stac	bp|disktab.lock	lock subsystem lock
	tze	0,x7		lock ret1

	tsx6	lock_meter_start
	lda	pds$processid
lockloop:	stac	bp|disktab.lock
	tze	lockgot
	llr	72
	llr	72
	llr	72
	llr	72
	tra	lockloop

lockgot:	tsx6	lock_meter_stop
	tra	0,x7		lock ret2

"
"	LOCK_METER_START - called via X6, X4 must specify lock reason
"

lock_meter_start:
	rccl	sys_info$clock_,*
	staq	meter_start_time
	aos	bp|disk_lock_meters.waits,x4
	tra	0,x6

"
"	LOCK_METER_STOP -called via X6, X4 must specify lock reason
"

lock_meter_stop:
	rccl	sys_info$clock_,*
	sbaq	meter_start_time
	adaq	bp|disk_lock_meters.wait_time,x4
	staq	bp|disk_lock_meters.wait_time,x4
	tra	0,x6

"
"	UNLOCK -- unlocks bp->disktab
"

unlock:	lda	pds$processid	DEBUG
	cmpa	bp|disktab.lock	DEBUG
	tze	*+2
	oct	04		DEBUG Die Die Die
	eaa	0
	ansa	bp|disktab.lock
	tra	0,x7		unlock ret
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	GET_FREE_Q -- called with bp->disktab
"		sets x3->quentry
"		note indirect return if sucessful, direct if fail!!
"
"		uses X4, X5, A
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	even

lock_disk_data.wait:
	llr	72			Read/Alter/Rewrite delay
	llr	72
	llr	72
	llr	72
lock_disk_data:
	lda	pds$processid
	stac	bb|disk_data.lock		lock disk_data
	tze	0,x4			return to caller
	tra	lock_disk_data.wait

"     Unlock disk_data.  Ensures write notification.

unlock_disk_data:
	lda	pds$processid	DEBUG
	cmpa	bb|disk_data.lock	DEBUG
	tze	*+2
	oct	04		DEBUG Die Die Dia
	eaa	0
	ansa	bb|disk_data.lock
	tra	0,x4		unlock ret



get_free_q:
	tsx4	lock_disk_data
	ldx3	bb|disk_data.free_q+qht.head
	tze	gfq_bret			bad unlock and return

	ldx4	bb|quentry.next,x3		make head point to next
	stx4	bb|disk_data.free_q+qht.head	set head
	tze	gfq_kill_tail		kill tail if no next
	ldx5	0,du			make an 18-bit zero
	sxl5	bb|quentry.prev,x4		kill new head's prev
	tra	gfq_do_stats

gfq_kill_tail:
	sxl4	bb|disk_data.free_q+qht.tail	kill tail

"     Compile statistics.

gfq_do_stats:
	lxl5	bb|disk_data.free_q+qht.depth
	eaa	0,x5
	ars	18
	asa	bb|disk_data.free_q+qht.sum	accumulate depth sum
	adx5	1,du			increment depth counter
	sxl5	bb|disk_data.free_q+qht.depth
	cmpx5	bb|disk_data.free_q+qht.max_depth
	tmoz	gfq_no_max_depth		not maximum depth seen
	stx5	bb|disk_data.free_q+qht.max_depth
gfq_no_max_depth:
	aos	bb|disk_data.free_q+qht.count

"     unlock disk_data and return good

	tsx4	unlock_disk_data
	tra	0,x7*

gfq_bret:	tsx4	unlock_disk_data		unlock disk_data
	tra	1,x7			gfq failure ret
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	ADD_FREE_Q -- add X3->quentry to queue
"
"		Uses X4, X5
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	even

add_free_q:
	tsx4	lock_disk_data
	lxl5	bb|disk_data.free_q+qht.tail	X5->oldtail
	tze	afq_empty			was none!
	stx3	bb|quentry.next,x5		make old_tail -> new_tail
	tra	afq_any
afq_empty:
	stx3	bb|disk_data.free_q+qht.head	was empty, make new head

"     make this entry's prev point to old tail

afq_any:	sxl5	bb|quentry.prev,x3		set this prev to old tail
	sxl3	bb|disk_data.free_q+qht.tail 	set tail ptr
	eax5	0
	stx5	bb|quentry.next,x3		make newtail's next->nil

"     Account for returned element

	lxl5	bb|disk_data.free_q+qht.depth	subtract for return
	sbx5	1,du
	sxl5	bb|disk_data.free_q+qht.depth

	tsx4	unlock_disk_data		unlock disk_data
	tra	0,x7			add_q ret
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	ADD_WQ -- add X3->quentry to queue
"
"     X2-> devtab (pdi), X0 = pdi
"		Uses X1, X4, X5, EAQ and lb
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

add_wq:
	lda	=o400000,du		set requests queued for dev
	ldq	0,du
	lrl	0,x0
	orsa	bp|disktab.dev_queued
	orsq	bp|disktab.dev_queued+1

"     add to work queue

	lxl5	bb|devtab.wq+qht.tail,x2 	X5->oldtail
	tze	aq_empty			was none!
	stx3	bb|quentry.next,x5		make old_tail -> new_tail
	tra	aq_any
aq_empty:
	stx3	bb|devtab.wq+qht.head,x2	was empty, make new head

aq_any:	sxl5	bb|quentry.prev,x3		set this prev to old tail
	sxl3	bb|devtab.wq+qht.tail,x2	set tail ptr
	eax5	0
	stx5	bb|quentry.next,x3		make newtail's next->nil

"     Compile statistics for queue loading.

	lxl5	bb|devtab.wq+qht.depth,x2
	eaa	0,x5
	ars	18
	asa	bb|devtab.wq+qht.sum,x2	accumulate depth sum
	adx5	1,du			increment depth
	sxl5	bb|devtab.wq+qht.depth,x2
	cmpx5	bb|devtab.wq+qht.max_depth,x2
	tmoz	gq_no_max_depth		not maximum depth seen
	stx5	bb|devtab.wq+qht.max_depth,x2
gq_no_max_depth:
	aos	bb|devtab.wq+qht.count,x2

"     compile system load stats.  Presumes io_type (DL) is good.

	tsx4	lock_disk_data		ensure counter is ours
	lxl1	io_type
	ldx5	sys_info_subs,x1		x5 is sysp offset
	ldx4	bb|sys_info.depth_map,x5	get mapped counter
	fld	bb|0,x4			increment depth
	fad	=1.0,du
	fst	bb|0,x4

"     Produce sys_info.fraction.   -(float (depth) - max_depth)/max_depth

	fsb	bb|sys_info.max_depth,x5
	fneg
	tpl	gq_pos_fraction		fraction is positive
	fld	=0.0,du			limit to 0.0
gq_pos_fraction:
	fdv	bb|sys_info.max_depth,x5
	fst	bb|sys_info.fraction,x5
	tsx4	unlock_disk_data		clear disk_data lock
"     Produce multiplier.  -(float (depth) * slope) + intercept
"     Final opt_info.multiplier is max (1.0, multiplier * sys_info.fraction)

	lxl4	opt_info_subs,x1		x4 is optp offset in devtab
	epplb	bb|0,x2			pointer to devtab
	aos	lb|opt_info.depth,x4	increment device depth

	lda	lb|opt_info.depth,x4
	als	18			clear high stuff
	lrs	72-18			float opt_info.depth
	lde	=71b25,du
	fno
	fmp	lb|opt_info.slope,x4
	fneg
	fad	lb|opt_info.intercept,x4
	fmp	bb|sys_info.fraction,x5	* fraction
	fst	lb|opt_info.multiplier,x4
	fcmp	=1.0,du			max (multiplier, 1.0)
	tpl	0,x7			add_q return
	fld	=1.0,du
	fst	lb|opt_info.multiplier,x4	set to 1.0
	tra	0,x7			add_q return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	DEL_Q -- called with x3->quentry
"
"		Uses X1, X4, X5, EAQ, lb
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

del_q:	ldx4	bb|quentry.next,x3		get next pointer
	lxl5	bb|quentry.prev,x3		is if head is previous
	tnz	dq_mid
	stx4	bb|devtab.wq+qht.head,x2	save new head
	tra	dq_head_done
dq_mid:	stx4	bb|quentry.next,x5		set previous's next
dq_head_done:
	cmpx4	0,du			test zero/non-zero
	tnz	dq_not_tail
	sxl5	bb|devtab.wq+qht.tail,x2	update tail
	tra	dq_tail_done
dq_not_tail:
	sxl5	bb|quentry.prev,x4		update next's previous

"     Compile queue loading statistics

dq_tail_done:
	lxl5	bb|devtab.wq+qht.depth,x2	decrement current depth
	sbx5	1,du
	sxl5	bb|devtab.wq+qht.depth,x2
	tpnz	dq_with_queue
	lda	=o400000,du		turn off device_queued bit
	ldq	0,du
	lrl	0,x0			X0 has PDI
	eraq	all_ones			form mask
	ansa	bp|disktab.dev_queued
	ansq	bp|disktab.dev_queued+1

"     compile system load stats.

dq_with_queue:
	lda	bb|quentry.type_word,x3	get type of IO
	ars	quentry.type_shift
	ana	quentry.type_mask,dl
	eax1	0,al			save for opt_info subs

	tsx4	lock_disk_data		lock for system update
	ldx5	sys_info_subs,x1		x5 is sysp offset
	ldx4	bb|sys_info.depth_map,x5	get mapped counter
	fld	bb|0,x4			increment depth
	fsb	=1.0,du
	tpl	dq_pos_depth		Must stay positive
	fld	=0.0,du
dq_pos_depth:
	fst	bb|0,x4

"     Produce sys_info.fraction.  -(float (depth) - max_depth)/max_depth

	fsb	bb|sys_info.max_depth,x5
	fneg
	tpl	dq_pos_fraction		fraction is positive
	fld	=0.0,du			limit to 0.0
dq_pos_fraction:
	fdv	bb|sys_info.max_depth,x5
	fst	bb|sys_info.fraction,x5
	tsx4	unlock_disk_data	
"     Produce multiplier.  -(float (depth) * slope) + intercept
"     Final opt_info.multiplier is max (1.0, multiplier * sys_info.fraction)

	lxl4	opt_info_subs,x1		x4 is optp offset in devtab
	epplb	bb|0,x2			pointer to devtab
	lxl1	lb|opt_info.depth,x4	decrement depth
	sbx1	1,du
	sxl1	lb|opt_info.depth,x4
	eaa	0,x1			load into high A
	lrs	72-18			float opt_info.depth
	lde	=71b25,du
	fno
	fmp	lb|opt_info.slope,x4
	fneg
	fad	lb|opt_info.intercept,x4
	fmp	bb|sys_info.fraction,x5	* sys_info.fraction
	fst	lb|opt_info.multiplier,x4
	fcmp	=1.0,du			max (multiplier, 1.0)
	tpl	0,x6			add_wq return
	fld	=1.0,du
	fst	lb|opt_info.multiplier,x4	max to 1.0
	tra	0,x6			add_wq_return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	GETWORK -- find something to do.
"		enter at gotwork if you already know what to do.
"
"		ap->chantabe
"		bb->disk_seg
"		bp->disktab
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

getwork:
	lda	ap|chantab.in_use_word	 Return if channel not in use
	cana	chantab.in_use,dl
	tze	gw_ret

	ldaq	bp|disktab.dev_queued 	See if any PDI with queue is not busy
	cnaaq	bp|disktab.dev_busy 	Z = AQ & ^Y-pair
	tze	gw_ret			Return if nothing to do

"     Scan through all devices round-robin til one is found which is not
"     busy, and has a queue.  We are looking at the primary device to
"     determine not_busy and queued.

	lxl5	bp|disktab.last_dev		get high drive number
	stx5	temp1			in upper for cmpx
	rccl	sys_info$clock_,*		get time for stagnate test
	staq	test_time

gw_dev.scan:
	aos	bp|disktab.dev_index	device to examine
	lxl4	bp|disktab.dev_index
	cmpx4	temp1			see if over-run
	tmoz	gw_dev.in_range
	ldx4	bp|disktab.first_dev	reset index to first dev
	sxl4	bp|disktab.dev_index

gw_dev.in_range:
	ldx4	devtab_subs,x4		subscript devtab (dev)
	ldq	bp|devtab.pdi_word,x4	get PDI
	equ	devtab.pdi_shift,0		PRESUMED 0
"""""	qrs	devtab.pdi_shift
	anq	devtab.pdi_mask,dl
	eax0	0,ql			X0 is PDI
	ldaq	bp|disktab.dev_busy		see if PDI is busy
	lls	0,x0
	tpl	gw_dev.not_busy		free for use
gw_dev.check_done:
	sbx5	1,du			count dev done
	cmpx5	bp|disktab.first_dev	more to scan
	tpl	gw_dev.scan
	tra	gw_ret			done sub-system

"     See if broken or without queue.

gw_dev.not_busy:
	ldx4	devtab_subs,x0		subscript devtab (pdi)
	eax2	bp|0,x4			X2->DEVTABE
	lxl4	bb|devtab.wq+qht.depth,x2	test depth of queue
	tze	gw_dev.check_done		no work to do
	ldq	bb|devtab.broken_word,x2	see if usable
	anq	devtab.broken,du
	tnz	gw_dev.check_done		skip this one

	ldx3	bb|devtab.wq+qht.head,x2	get head of queue
	cmpx4	1,dl
	tze	gw_dev.this_request		take the only request
	lda	bb|disk_data.stagnate_time	see if we are stagnating
	lrs	36			full 71 bit time
	adaq	bb|quentry.time,x3		plus queued time
	sbaq	test_time			minus time now
	tpl	gw_dev.seek		optimized nearest seek
"
"	COMB DEVICE FOR BEST REQUEST
"		X0 = pdi
"		X1 temp
"		X2 -> devtabe
"		X3 -> best_quentry
"		X4 temp
"		bb -> disk_seg
"		bp -> disktab
"		ap -> chantabe
"

gw_dev.comb:
	aos	bb|devtab.comb,x2		count a comb done
	lda	=o400000,du		best_neg_comb
	sta	best_neg_comb
	lda	=o377777,du		best_pos_comb
	sta	best_seek	
	stz	comb_qp			flag no best yet

comb.scan:
	ldq	bb|devtab.forward_word,x2	see if moving forward
	lda	bb|quentry.cylinder_word,x3	get queued cylinder
	ana	quentry.cylinder_mask
	sba	bb|devtab.cylinder,x2
	tze	gw_dev.this_request		take on-cylinder request
	anq	devtab.forward,du		see if forward
	tnz	comb.forward		yes - use queue-device
	neg				" use device-queue
comb.forward:
	cmpa	0,dl			test direction
	tmi	comb.move_reverse

"     This move would be in the current direction.

comb.move_forward:
	cmpa	best_seek			see if shorter move
	tpl	comb.skip			longer move
	sta	best_seek
	stx3	comb_qp			save forward best
	tra	comb.skip

"     This move would reverse our direction.

comb.move_reverse:
	cmpa	best_neg_comb		see if shorter move
	tmi	comb.skip			longer move
	sta	best_neg_comb
	sxl3	comb_qp			save reverse best
"	tra	comb.skip

"     Continue scan of queue.

comb.skip:
	ldx3	bb|quentry.next,x3		get next element
	tnz	comb.scan			continue scan

	ldx3	comb_qp			see if forward was found
	tnz	gw_dev.this_request		yes - do it
	lxl3	comb_qp			take reverse which must be here
	tra	gw_dev.this_request
"
"	FIND SHORTEST LOGICAL SEEK ON DEV
"		X0 = pdi
"		X1 = best_qp
"		X2 -> devtabe
"		X3 -> best_quentry
"		X4 temp
"		bb -> disk_seg
"		bp -> disktab
"		ap -> chantabe
"		lb -> devtabe
"

gw_dev.seek:
	fld	=1.0e30,du		high set best_seek
	fst	best_seek
	eax1	0,x3			best_qp
	epplb	bb|0,x2			form devtabe pointer

seek.scan:
	lda	bb|quentry.type_word,x3	get type of request
	ars	quentry.type_shift
	ana	quentry.type_mask,dl
	lxl5	opt_info_subs,al		subscript opt_info
	lda	bb|quentry.cylinder_word,x3	find cylinder move
	ana	quentry.cylinder_mask,dl
	sba	lb|devtab.cylinder
	tze	gw_dev.this_request		on-cylinder
	tpl	seek.pos			take absolute
	neg
seek.pos:	lrs	36			float
	lde	=71b25,du
	fno
	fmp	lb|opt_info.multiplier,x5	* multiplier
	fcmp	best_seek			see if best seek
	tpl	seek.worse		this one is worse
	eax1	0,x3			save this entry as best
	fst	best_seek			and the length

seek.worse:
	ldx3	bb|quentry.next,x3		check next entry
	tnz	seek.scan

"     The best seek is noted in X1, move to X3 and use it.

	eax3	0,x1
gw_dev.this_request:
	tsx6	del_q			delete this request from Q
"	tra	xfer_join
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	GOTWORK -- XFER JOIN  process a quentry
"		X0 = pdi
"		X2 -> devtabe (from pdi)
"		X3 -> quentry
"		X5 -> devtabe for actual device
"		X7 is return address
"		bb -> disk_seg
"		bp -> disktab
"		ap -> chantabe
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	equ	chantab.erct_shift,0	PRESUME=0

gotwork:
xfer_join:
	lda	-chantab.erct_mask-1,dl	clear error count and qrp
	ansa	ap|chantab.erct_word	zero qrp,erct leave command
	stx3	ap|chantab.qrp		save quentry index for later

	lda	bb|quentry.dev_word,x3
	ars	quentry.dev_shift
	ana	quentry.dev_mask,dl
	sta	dev			save device number
	als	idcw.device_shift		position dev in AU

"     dev value in AU is used in gw_testing below.

	equ	quentry.used_word,quentry.type_word
	ldq	bb|quentry.used_word,x3
	canq	quentry.used,du		DEBUG
	tnz	*+2
	oct	04			DEBUG Die Die Die
	qrs	quentry.type_shift
	anq	quentry.type_mask,dl
	eax4	0,ql			io_type to x4
	cmpq	TEST,dl			See if TEST io
	tze	gw_testing

	stca	ap|chantab.scdcw,20		use dev in AU
	ora	=o740000,dl		(dcdcw) idcw.code=7 idcw.ext_ctl=1
	sta	ap|chantab.dcdcw

	lxl5	dev			get device
	ldx5	devtab_subs,x5		subscript devtab
	eax5	bp|0,x5			HENCE x5 -> real devtabe

"     Determine if write IO by shifting the mask

	lda	write_mapping,du
	als	0,ql			io_type still QL
	tpl	gw_read			if positive then read
	lda	=o310000,du
	tra	gw_rw_done
gw_read:
	lda	=o250000,du
gw_rw_done:
	stca	ap|chantab.dcdcw,40		I believe an orsa would do

"dcdcwp->idcw.ext = quentry.coreadd
	lda	bb|quentry.coreadd_word,x3
	equ	MUST_BE_ZERO,quentry.coreadd_shift	PRESUMPTION
	stca	ap|chantab.dcdcw,10

"dddcwp->dcw.address = substr (quentry.coreadd,7)
	als	18
	stba	ap|chantab.dddcw,60

	lda	bb|quentry.sector_word,x3	leave sector in A for gw_put_seldata
	als	36-quentry.n_sectors_shift	mask for sectors
	arl	36-quentry.n_sectors_shift
	sta	ap|chantab.select_data

" Check for 64 or 512 type seek use x1
	ldx1	ap|chantab.scdcw
          bool	seek_64_bit,040000	"34 = seek_64 (normal) 30 = seek_512 (ibm)
	anx1	seek_64_bit,du
	tnz	seek_64		" bit was on
seek_512:
" Check io type for file system standards
	cmpx4	VTOC_WRITE,du
	tpnz	not_stan
	cmpx4	PAGE_WRITE,du
	tmoz	page_512
	ora	000100,du
	stca	ap|chantab.select_data,20     " store sector limit
	ldq	192,dl			" real vtoce size
	stcq	ap|chantab.dddcw,03		" store tally
	tra	seek_stats
page_512:
	ora	000200,du
	stca	ap|chantab.select_data,20     " store sector limit
	ldq	1024,dl
	stcq	ap|chantab.dddcw,03		" store tally
	tra	seek_stats
not_stan: 
	ldq	sector_mapping,du		io_type still in X4
	qls	0,x4
	tpl	not_sect_512		if positive then not sector

" Formulate tally and select_data.limit 512

	ldq	bb|quentry.n_sectors_word,x3
	qrl	quentry.n_sectors_shift
	stq	n_sectors
	qls	chantab.limit_shift		align for sector limit
	stq	n_sectors_temp
	ada	n_sectors_temp		n_sectors + sector
	ldq	n_sectors
	qls	9			times 512
	tra	sect_done_512
not_sect_512:
	ldq	1024,dl			page size is 1024 words
	ada	=o000200,du		add in limit bit
sect_done_512:
	stcq	ap|chantab.dddcw,03		store tally
put_seldata_512:
	sta	ap|chantab.select_data
	tra	seek_stats
seek_64:	
	ldq	sector_mapping,du		io_type still in X4
	qls	0,x4
	tpl	gw_not_sect		if positive then not sectorFormulate tally and select_data.limit

	ldq	bb|quentry.n_sectors_word,x3
	qrl	quentry.n_sectors_shift
	stq	n_sectors
	qls	chantab.limit_shift		align for sector limit
	stq	n_sectors_temp
	ada	n_sectors_temp		n_sectors + sector
	ldq	n_sectors
	qls	6			times 64
	tra	gw_sect_done
gw_not_sect:
	ldq	1024,dl			page size is 1024 words
	ada	=o002000,du		add in limit bit
gw_sect_done:
	stcq	ap|chantab.dddcw,03		store tally
gw_put_seldata:
	sta	ap|chantab.select_data

"     Formulate seek statistics and seek direction.

seek_stats: 
	epplb	bb|0,x5			form devtab (dev) pointer
	lxl4	opt_info_subs,x4		get opt_info subscript in devtab
	lda	bb|quentry.cylinder_word,x3	get quentry.cylinder
	ana	quentry.cylinder_mask,dl
	sta	cylinder
	sba	bb|devtab.cylinder,x2	subtract devtab.cylinder
	tze	gw_seek_done		on-cylinder retain forward
	tpl	gw_seek_fwd		seek from low to high
gw_seek_back:				" seek from high to low
	lcx1	devtab.forward+1,du		clear forward bit
	ansx1	bb|devtab.forward_word,x2
	neg				" take absolute cylinder move
	tra	gw_seek_done
	
gw_seek_fwd:
	ldq	devtab.forward,du
	orsq	bb|devtab.forward_word,x2

gw_seek_done:
	asa	lb|opt_info.seek_sum_word,x4	sum seek lengths
	aos	lb|opt_info.seek_count_word,x4	count seek done
	lda	cylinder
	sta	bb|devtab.cylinder,x2
	epplb	ap|chantab.scdcw

"     Perform the operation

	tsx6	connect
gw_ret:	tra	0,x7


"TESTING HERE -- note dev for idcw in AU

gw_testing:
	stca	ap|chantab.rssdcw,20	use dev in AU
	lda	bb|quentry.coreadd_word	get command from coreadd
	ana	idcw.command_mask,dl	mask for command
	als	30			shift to bits 0 - 5
	stca	ap|chantab.rssdcw,40	in IDCW

"     Statistics for TEST - io_type in X4

	epplb	bb|0,x5			devtab (dev) pointer
	lxl4	opt_info_subs,x4		convert type to subscript
	cmpa	58,dl
	tze	gw_testing.unload
	aos	lb|opt_info.seek_count_word,x4	TEST
	tra	gw_testing.connect
gw_testing.unload:
	aos	lb|opt_info.seek_sum_word,x4	UNLOAD

gw_testing.connect:
	epplb	ap|chantab.rssdcw
	tsx6	connect
	tra	gw_ret

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	CONNECT -- called via tsx6
"
"			X0 = pdi
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	even
one_arg_nd:
	zero	2,4
	zero	0

two_args_nd:
	zero	4,4
	zero	0

nullptr:	its	-1,1

" *********
"
" LB -> DCW list
"
connect:
	sprilb	ima+io_manager_arg.listp
	lda	ap|chantab.chx
	sta	ima+io_manager_arg.chx
	stz	ima+io_manager_arg.pcw
	ldaq	nullptr
	staq	ima+io_manager_arg.ptp

	ldaq	one_arg_nd
	staq	arglist
	epplb	ima
	sprilb	arglist+2
	call	io_manager$connect_abs(arglist)

	aos	ap|chantab.connects
	lda	chantab.active,dl
	orsa	ap|chantab.active_word
	rccl	sys_info$clock_,*
	staq	ap|chantab.connect_time
	lda	=o400000,du
	ldq	0,du
	lrl	0,x0		leave PDI-th bit on
	orsa	bp|disktab.dev_busy
	orsq	bp|disktab.dev_busy+1
	tra	0,x6		connect retns
"
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	DISK_INTER  -- the interrupt side of the disk_dim
"	This proc only processes the easy cases, those
"	which do not involve errors or syserr messeage production.
"	It is assumed that if this procedure did not exist, the
"	pl1 version of the disk_dim could handle all cases
"	properly.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

evil_status_bits:
	oct	002300000000

	even
simple_interrupt_criteria:
	zero	0,chantab.active
	zero	-1,-chantab.active-chantab.ioi_use-chantab.rsr-1

	even
all_ones:
	vfd	36/-1
	vfd	36/-1

	even
time_mod:	dec	1
	dec	0

disk_inter:
	push			" get a stack frame
	spriap	int_arg_list	" save arg list ptr
	eppbb	disk_seg$		need bb in case of bailout

	lxl5	ap|4,*		get interrupt level
	cmpx5	3,du		only level = 3 (terminate) handled here
	tnz	SLOW_INT

" Each subsystem has a channel address space of dskdcl_chans_per_subsys.
" If you divide the supplied channel idx by this you can arrive at the subsys
" index.

	lda	ap|2,*			get idx
	lrs	dskdcl_chans_per_subsys_shift	sx = idx/#
	tsx7	setup
	qrl	36-dskdcl_chans_per_subsys_shift	put mod(idx,#) in the q
	lxl4	chantab_subs,ql		subscript chantab
	adx4	bp|disktab.channels		locate dynamic table
	eppap	bb|0,x4			HENCEFORTH AP -> chantabe
	eax4	disktab.int_lock_meters
	tsx7	lock

	lda	ap|chantab.statusp,*	get status

	tze	NO_STATUS_TERM		someone else processed status (disk_control$run)

"CHECK 1 AGAIN

	tpl	UNLOCK_THEN_SLOW


"CHECK 8 -- handle abnormal termination status
	cana	bb|disk_data.status_mask
	tnz	UNLOCK_THEN_SLOW

"CHECK 9 -- Test for non-zero tally residue in DCW (DISCONTINUED)
"CHECK 10 -- If controller performed EDAC or auto retry
	cana	evil_status_bits
	tnz	UNLOCK_THEN_SLOW

	ldaq	simple_interrupt_criteria	pre-CHECKS 3&4&7
	cmk	ap|chantab.active_word	test channel criteria
	tnz	UNLOCK_THEN_SLOW

"
"CHECK 3 -- If status for ioi channel
"CHECK 4 -- If channel not active scream bloody murder
"CHECK 7 --If detailed status just read
"
	rccl	sys_info$clock_,*
	staq	status_time

"Now set needed registers pointing into disk_data seg
	ldx3	ap|chantab.qrp		HENCEFORTH X3->quentry
	lda	bb|quentry.pdi_word,x3
	ars	quentry.pdi_shift		AL now has PDI
	ana	quentry.pdi_mask,dl
	eax0	0,al			HENCEFORTH X0 = PDI

	ldx2	devtab_subs,x0		subscript devtab (pdi)
	eax2	bp|0,x2			HENCEFORTH X2->devtabe
"
"CHECK 11 -- Was disk previously inoperative?
	lda	bb|devtab.broken_word,x2
	cana	devtab.broken+devtab.was_broken,du
	tnz	UNLOCK_THEN_SLOW
"
" Must set sect_sw bootload_sw coreadd prior ercd before yielding quentry


"CHECK 12 -- If was test then indicate test result

	lda	bb|quentry.type_word,x3
	ars	quentry.type_shift
	ana	quentry.type_mask,dl
	sta	io_type			io_type (DL) **
	cmpa	TEST,dl
	tze	UNLOCK_THEN_SLOW		Handle through pl1 DIM

	ldq	sector_mapping,du		Determine if sector IO
	qls	0,al			shift to sign bit
	stq	sect_sw
	ldq	bootload_mapping,du		" Determine if bce IO
	qls	0,al
	stq	bootload_sw
	ldq	bb|quentry.coreadd_word,x3
	qls	36-quentry.type_shift	isolate coreaddress
	qrs	36-quentry.type_shift
	stq	coreadd

	stz	errcd

"     WE MAY NEED TO SET LB->PVTE HERE ...

"AT THIS POINT WE KNOW THAT NO ERROR OCCURED.
"AT THIS POINT WE KNOW WE WILL NOT HAVE TO PRINT ANY MESSAGES.
"AT THIS POINT WE MAY BEGIN TO MODIFY DISK_SEG TO REFLECT AN I/O COMPLETION.


	lca	chantab.active+chantab.inop+1,dl
	ansa	ap|chantab.active_word Indicate channel is no longer active|inop
	lda	=o400000,du
	ldq	0,du
	lrl	0,x0			X0=PDI -- turn off PDI-th bit
	eraq	all_ones
	ansa	bp|disktab.dev_busy
	ansq	bp|disktab.dev_busy+1

	lcx4	devtab.inop+1,du
	ansx4	bb|devtab.inop_word,x2	Clear the devtab.inop flag
"Meter this i/o completion


	lxl4	io_type			io_type in DL
	lxl4	opt_info_subs,x4		subscript opt_info
	epplb	bb|0,x2			devtab pointer (pdi)
	rccl	sys_info$clock_,*
	sbaq	ap|chantab.connect_time
	adaq	lb|opt_info.channel_wait,x4	sum channel wait
	staq	lb|opt_info.channel_wait,x4
	rccl	sys_info$clock_,*
	sbaq	bb|quentry.time,x3
	adaq	lb|opt_info.queue_wait,x4	sum queue wait
	staq	lb|opt_info.queue_wait,x4
	lcx4	quentry.used+1,du		mask out used bit
	ansx4	bb|quentry.used_word,x3

	tsx7	add_free_q

	tsx7	getwork

	tsx7	unlock


"	Post this io completion.

	epplb	coreadd
	sprilb	arglist+2
	epplb	errcd
	sprilb	arglist+4
	ldaq	two_args_nd
	staq	arglist

	szn	sect_sw		Select posting means
	tmi	sector_post
	eppap	arglist
	short_call page$done
	return

sector_post:
	lda	bb|0,3
	szn	bootload_sw
	tmi	bootload_post
	eppap	arglist
	short_call vtoc_interrupt$vtoc_interrupt
	return

bootload_post:
	eppap	arglist
	short_call bootload_disk_post$bootload_disk_post
	return


"	SLOW INT -- UNLOCK_THEN_SLOW -- bail out of hard case

UNLOCK_THEN_SLOW:
	tsx7	unlock

SLOW_INT:	aos	bb|disk_data.bail_outs	count a bail-out to PL1
	eppap	int_arg_list,*		get back arg list ptr
	short_call disk_control$disk_inter
	return

NO_STATUS_TERM:
	aos	ap|chantab.no_status_terminate;
	tsx7	unlock
	return
		
"Constants for subscript calculations

"     Subscript for sys and opt info.  Sys_info is DU, Opt_info is DL.
"     sys_info is segment offset of sys_info (i), opt_info is devtab
"     offset of opt_info (i).
sec_per_rec: 
	zero	0,0	" not used
	zero	0,0	" not used      
	zero	0,16	" 500
	zero	0,16	" 451
	zero	0,16	" 400
	zero	0,16	" 190
	zero	0,16	" 181
	zero	0,16	" 501
	zero	0,2	" 3380
	zero	0,2	" 3390
sys_info_subs:				" (0:MAX_IO_TYPE)
opt_info_subs:
	zero disk_data.sys_info+sys_info_size*0,devtab.opt_info+opt_info_size*0
	zero disk_data.sys_info+sys_info_size*1,devtab.opt_info+opt_info_size*1
	zero disk_data.sys_info+sys_info_size*2,devtab.opt_info+opt_info_size*2
	zero disk_data.sys_info+sys_info_size*3,devtab.opt_info+opt_info_size*3
	zero disk_data.sys_info+sys_info_size*4,devtab.opt_info+opt_info_size*4
	zero disk_data.sys_info+sys_info_size*5,devtab.opt_info+opt_info_size*5
	zero disk_data.sys_info+sys_info_size*6,devtab.opt_info+opt_info_size*6
	zero disk_data.sys_info+sys_info_size*7,devtab.opt_info+opt_info_size*7


"     Constants for channel table and devtab subscripting.  Current basis is
"     the limit on either is 64.

chantab_subs:			" straight subscript (1:64)
devtab_subs:			" disktab.devtab subscript
	zero disktab.devtab+devtab_size*00,chantab_size*00  " @ 1
	zero disktab.devtab+devtab_size*01,chantab_size*01
	zero disktab.devtab+devtab_size*02,chantab_size*02
	zero disktab.devtab+devtab_size*03,chantab_size*03
	zero disktab.devtab+devtab_size*04,chantab_size*04
	zero disktab.devtab+devtab_size*05,chantab_size*05
	zero disktab.devtab+devtab_size*06,chantab_size*06
	zero disktab.devtab+devtab_size*07,chantab_size*07
	zero disktab.devtab+devtab_size*08,chantab_size*08
	zero disktab.devtab+devtab_size*09,chantab_size*09
	zero disktab.devtab+devtab_size*10,chantab_size*10
	zero disktab.devtab+devtab_size*11,chantab_size*11
	zero disktab.devtab+devtab_size*12,chantab_size*12
	zero disktab.devtab+devtab_size*13,chantab_size*13
	zero disktab.devtab+devtab_size*14,chantab_size*14
	zero disktab.devtab+devtab_size*15,chantab_size*15
	zero disktab.devtab+devtab_size*16,chantab_size*16
	zero disktab.devtab+devtab_size*17,chantab_size*17
	zero disktab.devtab+devtab_size*18,chantab_size*18
	zero disktab.devtab+devtab_size*19,chantab_size*19
	zero disktab.devtab+devtab_size*20,chantab_size*20
	zero disktab.devtab+devtab_size*21,chantab_size*21
	zero disktab.devtab+devtab_size*22,chantab_size*22
	zero disktab.devtab+devtab_size*23,chantab_size*23
	zero disktab.devtab+devtab_size*24,chantab_size*24
	zero disktab.devtab+devtab_size*25,chantab_size*25
	zero disktab.devtab+devtab_size*26,chantab_size*26
	zero disktab.devtab+devtab_size*27,chantab_size*27
	zero disktab.devtab+devtab_size*28,chantab_size*28
	zero disktab.devtab+devtab_size*29,chantab_size*29
	zero disktab.devtab+devtab_size*30,chantab_size*30
	zero disktab.devtab+devtab_size*31,chantab_size*31
	zero disktab.devtab+devtab_size*32,chantab_size*32
	zero disktab.devtab+devtab_size*33,chantab_size*33
	zero disktab.devtab+devtab_size*34,chantab_size*34
	zero disktab.devtab+devtab_size*35,chantab_size*35
	zero disktab.devtab+devtab_size*36,chantab_size*36
	zero disktab.devtab+devtab_size*37,chantab_size*37
	zero disktab.devtab+devtab_size*38,chantab_size*38
	zero disktab.devtab+devtab_size*39,chantab_size*39
	zero disktab.devtab+devtab_size*40,chantab_size*40
	zero disktab.devtab+devtab_size*41,chantab_size*41
	zero disktab.devtab+devtab_size*42,chantab_size*42
	zero disktab.devtab+devtab_size*43,chantab_size*43
	zero disktab.devtab+devtab_size*44,chantab_size*44
	zero disktab.devtab+devtab_size*45,chantab_size*45
	zero disktab.devtab+devtab_size*46,chantab_size*46
	zero disktab.devtab+devtab_size*47,chantab_size*47
	zero disktab.devtab+devtab_size*48,chantab_size*48
	zero disktab.devtab+devtab_size*49,chantab_size*49
	zero disktab.devtab+devtab_size*50,chantab_size*50
	zero disktab.devtab+devtab_size*51,chantab_size*51
	zero disktab.devtab+devtab_size*52,chantab_size*52
	zero disktab.devtab+devtab_size*53,chantab_size*53
	zero disktab.devtab+devtab_size*54,chantab_size*54
	zero disktab.devtab+devtab_size*55,chantab_size*55
	zero disktab.devtab+devtab_size*56,chantab_size*56
	zero disktab.devtab+devtab_size*57,chantab_size*57
	zero disktab.devtab+devtab_size*58,chantab_size*58
	zero disktab.devtab+devtab_size*59,chantab_size*59
	zero disktab.devtab+devtab_size*60,chantab_size*60
	zero disktab.devtab+devtab_size*61,chantab_size*61
	zero disktab.devtab+devtab_size*62,chantab_size*62
	zero disktab.devtab+devtab_size*63,chantab_size*63
	zero disktab.devtab+devtab_size*64,chantab_size*64
"
	include	device_error
	include	disk_error_interp
	include	io_manager_dcls
	include	iom_ctl_words

" sectors per record must be used in seek calculations and are indexed by the pvte dev_type

"
	include	dskdcl
"
	include	pvte

	end




		    device_control.alm              11/11/89  1105.1r w 11/11/89  0804.1       50733



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " 
"
"	device_control 
"
"	Dispatcher to appropriate dim on device type.
"	The entries read, write, and run are transfered to via
"	a tsx7.
"	Index registers x2,x3,x4,x7 must be preserved.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

" Modified 2/6/74 by N. I. Morris
" Modified 4/8/74 by S. H.Webber to meter reads and writes per device
" Modified 6/6/74 by B. Greenberg for unified page_wait strategy.
" Modified 12/11/74 by B. Greenberg for cme.notify_requested and new cme/ptw protocol
" Modified 02/28/75 by BSG for NSS
" Modified 06/21/79 by BSG for stack 0 sharing
" Modified 1/80 by R.J.C. Kissel to eliminate a builtin constant
" Modified 03/29/81, W. Olin Sibert, to conditionalize Page Multilevel
" Modified 03/03/82 by J. Bongiovanni to remove Page Multilevel, and for new PVTE
" Modified 6/21/82 by E. N. Kittlitz to move core map.

	include	pxss_page_stack
	include	aste
	include	pvte
	include	add_type
	include	stack_frame
	include	stack_header
	include	page_info
	include	sst
	include	ptw
	include	cmp
	include	apte
	include	fs_dev_types
"

	name	device_control

	segdef	dev_read,dev_write,time_out,run,init,pwait,esd_reset
	segdef	disk_offlinep
	entry	ptl_waitlock
	segdef	check_ckdv,ckdv_from_pvtx
	entry	pwait_return
" 
init:
	push	"gonna call out.
	ldq	ap|2,*	get pvtx
	stq	pvtx

	tsx0	get_device_type	get from pvt

	short_call disk_init$disk_init(ap|0)
	return



esd_reset:		"this entry is called to flush out all dim I/O reqs.
			" note this works elegantly at ESD time, but does not
			"extend easily to fault recover time.
	push		"for callouts
	epp	sst,sst$
	stz	sst|sst.ptl	somebody has to do this.
	short_call disk_control$esd_reset_locks

	tsx7	core_queue_man$clearout
	return


dev_read:
	tsx0	get_device_type	get it from pvt
	aos	sst$+sst.reads-1,al


	eppap	dctl$disk_read
	tra	call_join		go call the dim

dev_write:
	tsx0	get_device_type
	aos	sst$+sst.writes-1,al
	aos	sst$+sst.wtct

	eppap	dctl$disk_write

call_join:
	eppbp	inter		pick up flag saying to interrupt
	spribp	arg+8
	eppbp	pvtx
	spribp	arg+2
	eppbp	core_add
	spribp	arg+4
	eppbp	devadd
	spribp	arg+6
	fld	=4b24,dl		4 arguments
	ora	4,dl		all arg acceptable to PL1
	staq	arg
	eppbp	ap|0		can't use ap to call
	call	bp|0(arg)
	eppbp	sst$+0,2		restore bp to point into SST
	epbpbb	bp|0		restore bb to point to base of sst
	tra	0,7




pwait:			"entry to wait for any page control event
push:	push		"no more  frame-avoiding m-mouse
	tsx6	page_fault$init_savex_bb
pwait_retry:
	lda	ap|2,*		get event in a
	cana	-1,du		global event?
	tnz	await_tc

	als	18		move to upper
	lda	sst|0,au		get ptw
	cana	ptw.os,dl		see if event still there
	tze	.ret_long		return if no longer o/s
	arl	2		get core map index
	eaa	cme.devadd,au	set to get devadd
	ldq	cme.notify_requested,dl set notify bit in cme
	orsq	sst|sst.cmp,*au	.. as we came here to wait.
	lda	sst|sst.cmp,*au	get devadd word

await_tc:
	lda	ap|2,*		get argument
	eppap	pds$apt_ptr,*	get apt ptr
	sta	ap|apte.wait_event	put it where it can get notified.

	tsx7	page_fault$unlock_ptl
				"clear postqueue, perhaps notify


	tra	pxss$waitp

ptl_waitlock:			"contract of this entry:
		" 1. Who tras to me is in his stack frame, with its own return ptr valid.
		" 2. Who tras to me has masked to sys_level and wired the (pds) stack.
		" 3. I shall execute a full Multics return (to prev frame) when
		"    and only when I have the PTL locked.

		"It is NOT necessary to stx6 init_savex here.

	push		"Establish page control frame.
pwait_return:
	epp3	sst$		don't forget!
	tsx7	core_queue_man$trylock_ptl
	 tra	pxss$dvctl_retry_ptlwait
			"patch to tra *-1 if too obscure

.ret_long:return



time_out:				"entry to call to make sure disks havn't stopped
	save
	tsx7	page_fault$lock_ptl	lock the page table lock
	tsx6	page_fault$init_savex  init x7 save stack
	tsx7	run		call run on each device
	tsx7	page_fault$unlock_ptl  unlock the page table lock
	return

run:
	tsx6	page_fault$savex
	tsx7	core_queue_man$run_core_queue
	tsx6	pc_trace$running	trace the fact that we called run

	eppap	=v18/0,18/4,18/0,18/0
	call	disk_control$disk_run
	tra	page_fault$unsavex



disk_offlinep:
	tsx0	get_device_type
	lda	lb|pvte.device_inoperative_word
	cana	pvte.device_inoperative,dl
	tze	1,7
	tra	0,7

get_device_type:
	ldq	pvtx
	tmoz	page_error$bad_device_id
	mpy	pvte_size,dl	index the pvt
	epplb	pvt$array
	epplb	lb|-pvte_size,ql	address the PVTE
	lda	lb|pvte.device_type_word
	arl	pvte.device_type_shift
	tze	page_error$bad_device_id
	cmpa	fs_dev.max_dev_type,dl
	tpnz	page_error$bad_device_id
	tra	0,0



check_ckdv:
	lda	page_fault$cme_devadd,*4 what device is this?
	lda	ast|aste.pvtx_word,3
	arl	aste.pvtx_shift
	ana	aste.pvtx_mask,dl	get disk's pvtx
ckdv_from_pvtx:
	lrl	36		move to x
	mpy	pvte_size,dl
	eppap	pvt$array
	eppap	ap|-pvte_size,ql	address the PVTE
	lda	ap|pvte.check_read_incomplete_word
	cana	pvte.check_read_incomplete,dl are we checking this dev?
	tnz	0,7
	tra	1,7		no
	end




		    disk_control.pl1                10/01/90  1629.4rew 10/01/90  1626.9      771102



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

/* DISK_CONTROL - Device Control Module for Disks.
   coded 12/1/70 by N. I. Morris
   revised 7/1/73 - Lee J. Scheffler to add metering
   revised 12/73 by N. I. Morris to add DSU-191 disks.
   revised 4/8/74 by S.H.Webber to change lockptl metering code
   revised for new storage system - 3/27/75 by Noel I. Morris
   test_drive entry by Bernard Greenberg 4/9/76
   improved error handling by Noel I. Morris - 6/3/76
   bad channel removal added by Noel I. Morris - 8/16/77
   disk offline waiting added by Bernard Greenberg - 9/20/77
   changed to use reset status command in test_drive 2/1/79 by Michael R. Jordan
   modified for new seek optimization for MSU0500/1 devices 4/79 by Michael R. Jordan
   modified for io_manager conversion February 1981 by Chris Jones
   Modified July, 1981, WOS, to install Mike Jordan's fix to the 501 sector number
   overflow problem (too many sectors to represent in 20 bits).
   Modified February 1982 by C. Hornig for MR10 io_manager.
   Modified March 1982 by C. Hornig to unload disks.
   Modified March 1982 by J. Bongiovanni for queue_length_given_pvtx, new PVTE
   Modified July 1982 by J. Bongiovanni for read_sectors, write_sectors
   Modified June 1983 by Chris Jones for ioi rewrite
   Modified January 1984 by Chris Jones to add add_channel entry
   Modified April 1984 by T. Oke for system wide free_q.
   Modified April 1984 by T. Oke for dynamic channel table and the use of
   dskdcl_chans_per_subsys to define channel idx/subsystem relation.
   Modified May 1984 by T. Oke to save pvtx in queue entry for AZM analysis
   of queue.

   Modified for adaptive optimizer by T. Oke May 1984.
   Modified call_run to poll all sub-systems by T. Oke May 1984,
   Lossage counters moved to chantab and renamed.
   Modified to reset quentry.used in add_free_q by T. Oke November 1984.
   Modified Nov 26, 1984 by R. A. Fawcett to support dev 0 (fips). Also include
   Chris Jones's change for IMU-type detailed status delivery.
   Stepped zealousness of esd_reset_locks from "call call_run (sx)" to
   merely "call run" to prevent running un-reinitialized sub-systems.
   by T. Oke November 1984.
   Modified February 1985 by Chris Jones to allow a channel to be usurped if
   of its devices are deleted.
   Modified July 1985 by Paul Farley to correctly handle IMU style detailed status.
*/

/****^  HISTORY COMMENTS:
  1) change(85-09-09,Fawcett), approve(85-09-09,MCR6979),
     audit(85-12-02,CLJones), install(86-03-21,MR12.0-1033):
     Add support for dev
     0 FIPS, Chris Jones's change for IMU-type detailed status delivery.
  2) change(86-04-01,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-27,Coppola), install(86-07-17,MR12.0-1097):
     Add support for subvolumes, and 512_word_io, devices 3380 and 3390.
  3) change(86-07-24,Fawcett), approve(86-10-30,PBF7383),
     audit(86-11-18,Beattie), install(86-11-21,MR12.0-1223):
     Add an optional third line to the disk error message that gives the
     subvolume name and logical record/sector for use with the
     record_to_vtocx command.
  4) change(86-10-29,Fawcett), approve(86-11-14,MCR7571),
     audit(86-11-18,Beattie), install(86-11-21,MR12.0-1223):
     Check the ioi_used bit before trying to place channels back in operation.
  5) change(87-05-22,Fawcett), approve(87-05-27,MCR7704),
     audit(87-07-08,Farley), install(87-07-17,MR12.1-1043):
     Move the check for the TEST type IO quentry. This allows the secondary
     channels to be used if the primary is down.
  6) change(87-05-27,Fawcett), approve(87-05-27,MCR7704),
     audit(87-07-08,Farley), install(87-07-17,MR12.1-1043):
     Set the "substat" variable to ANY so that matches in the disk_error_data
     segment can be found for such things as I/O system faults. Also display
     the I/O system fault word on the console.
  7) change(87-08-31,Fawcett), approve(87-08-31,PBF7704),
     audit(87-08-31,Farley), install(87-09-01,MR12.1-1095):
     Change to correct a bug in the sub-status reporting in the above fix.
  8) change(88-02-23,Farley), approve(88-02-23,MCR7759),
     audit(88-02-24,Fawcett), install(88-03-01,MR12.2-1029):
     Changed to set a new flag in the error code "all_paths_bad" and to give up
     if only one channel left and it is bad. At this time it will only be
     implemented for bootload_io. This is I/O done for BCE commands.
  9) change(88-02-23,Farley), approve(88-02-23,MCR7793),
     audit(88-02-24,Fawcett), install(88-03-01,MR12.2-1029):
     Changed the handle_error procedure to only display/retry TEST I/O errors
     when they are of the bad_path variety.  The retry will be done by removing
     the suspected bad path and re-queuing the I/O.  If bad_path error on all
     paths, set the device inoperative and post the I/O. Same during esd.
 10) change(88-03-18,Farley), approve(88-03-18,MCR7858),
     audit(88-04-11,Fawcett), install(88-04-19,MR12.2-1037):
     Changed disk_inter entry to set io_status_entry_ptr for all interrupt
     levels that will be processed.  A null ptr fault was occuring with level-1
     system faults.  Changed bad_dev error handling to set pvte inop when doing
     TEST I/O during an ESD.
 11) change(88-05-12,Farley), approve(88-06-03,MCR7906),
     audit(88-08-03,Fawcett), install(88-08-08,MR12.2-1080):
     Added a reconnect_announce_time variable to chantab to announce reconnect
     attempts the first time and every thirty seconds thereafter, until the I/O
     is successful.  All other times the messages will go only to the log as
     they normally do.  Also added I/O type to message.
 12) change(89-06-23,Farley), approve(89-07-26,MCR8122),
     audit(89-09-11,WAAnderson), install(89-09-22,MR12.3-1072):
     Added functionality to interpret_status and printerr procedures to
     seperate FIPS disk statuses from all others by checking the pvte.is_sv
     flag and using new fields in disk_error_data.  Also changed printerr to
     check the new "just_log" flag in disk_error_data.
 13) change(90-06-27,WAAnderson), approve(90-08-28,MCR8188),
     audit(90-09-21,Schroth), install(90-10-01,MR12.4-1035):
     Fix bug in esd_reset_locks and handle_error that caused ESD to fail.
                                                   END HISTORY COMMENTS */

/*
   ERROR RECOVERY STRATEGY

   When a fatal error is detected by  the  disk  DIM,  the
   drive  involved is placed in a temporarily inoperative state.  If
   the drive corrects the problem by itself within  several  seconds
   and  sends  a special interrupt, the drive will be placed back in
   operation.  If no special is received within the  several  second
   time  limit, the DIM will attempt to use the drive once more.  If
   it generates another fatal error, the drive  will  be  placed  in
   broken  state.   The DIM will attempt to use a broken drive every
   several minutes.  The  receipt  of  a  special  interrupt,  or  a
   successful  attempt  to use a broken drive, will place that drive
   back in operation.  Read requests that are queued  for  a  broken
   drive  will  be posted as errors.  Write requests will be left in
   the queue and ignored util the broken drive  becomes  operational
   again.

*/

/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
disk_control:
     proc;

dcl	a_pvtx		   fixed bin;		/* index of PVT entry */
dcl	a_coreadd		   fixed bin (24);		/* absolute core address */
dcl	a_devadd		   bit (18) aligned;	/* secondary storage device address */
dcl	a_intrpt		   fixed bin (1);		/* non-zero if completion interrupt desired */
dcl	a_queue_length	   fixed bin;		/* current number of elements in Q */
dcl	a_sect_off	   fixed bin (4);		/* sector offset for single sector requests */
dcl	a_n_sectors	   fixed bin;		/* number of sectors for sector I/O */

dcl	pvtx		   fixed bin;		/* copied args to prevent page faults */
dcl	coreadd		   fixed bin (24);
dcl	sect_off		   fixed bin (4);
dcl	n_sectors		   fixed bin;
dcl	record_offset	   fixed bin;

/* Local Automatic storage. */

dcl	bootload_sw	   bit (1) aligned;		/* set if I/O is being done for bootload Multics */
dcl	call_run_sx	   fixed bin;		/* a_sx saved in call_run */
dcl	channel_time	   fixed bin (52);		/* time channel spent doing I/O */
dcl	command		   bit (6) aligned;		/* peripheral device command */
dcl	cylinder		   fixed bin (12);		/* cylinder heads are currently on */
dcl	dcdcwp		   ptr;			/* pointer to data xfer IDCW */
dcl	dddcwp		   ptr;			/* pointer to data xfer DCW */
dcl	dev		   unsigned fixed bin (6);	/* disk device code */
dcl	devadd		   fixed bin (18);		/* record number part of device address */
dcl	dev_count		   fixed bin;		/* counter in getwork */
dcl	entry_time	   fixed bin (52);		/* time of call */
dcl	errcd		   fixed bin (35);		/* error code to page control */
dcl	i		   fixed bin;		/* usually channel index */
dcl	intrpt		   bit (1);		/* if interrupt required */
dcl	io_type		   fixed bin;		/* type of IO */
dcl	lcp		   ptr;			/* local channel pointer in handle_error */
dcl	level		   fixed bin (3);		/* level of interrupt from IOM */
dcl	majstat		   fixed bin (5);		/* extended major status */
dcl	mask		   fixed bin (71) aligned;	/* temp for wire and mask */
dcl	masked		   bit (1);		/* running masked */
dcl	meter_start_time	   fixed bin (52);		/* time of attempt to lock */
dcl	name_rel		   fixed bin (17);		/* rel offset of the disk_error_data ascii names */
dcl	pdi		   fixed bin (6) unsigned;	/* Primary Device Index. */
dcl	post_sw		   bit (1) aligned;		/* "1"b if posting must be done */
dcl	ptp		   ptr;			/* temp for wire_and_mask */
dcl	qrp		   bit (18) aligned;	/* rel ptr to queue entry */
dcl	qx		   fixed bin (8);		/* index to queue entry */
dcl	required		   bit (1) aligned;		/* "1"b if IOI requires specific channel */
dcl	sector		   fixed bin (21);		/* physical disk sector */
dcl	sect_sw		   bit (1);		/* if sector IO */
dcl	stat		   bit (36) aligned;	/* copy of special or fault status word */
dcl	status_time	   fixed bin (52);		/* time status received */
dcl	sx		   fixed bin (8);		/* index of disk subsystem */
dcl	sysc		   fixed bin;		/* syserr report code */
dcl	substat		   bit (6) aligned;		/* substatus */
dcl	temp_time		   fixed bin (52);		/* for real time looping on inop chnl errors */
dcl	usurped		   bit (1) aligned;		/* "1"b if IOI usurped channel successfully */
dcl	wait_time		   fixed bin (52);		/* time from queuing to I/O completion */

dcl	1 msg_buf		   like io_msg aligned;	/* for syserr data */

dcl	1 stat_entry	   like io_status_entry;	/* the whole disaster */

dcl	error_table_$bad_arg   fixed bin (35) ext static;
dcl	error_table_$io_configured
			   fixed bin (35) ext static;

dcl	pds$processid	   ext bit (36);
dcl	page_fault$disk_offline_event
			   bit (36) aligned ext;
dcl	tc_data$system_shutdown
			   ext fixed bin;

dcl	ANY		   bit (6) init ("000000"b) static options (constant);
						/* used for substatus that will match on any */
dcl	(
	BOTH		   init ("1"b),
	SINGLE		   init ("0"b),
	ON		   init ("1"b),
	OFF		   init ("0"b),
	SUCCESS		   init ("1"b),
	FAILURE		   init ("0"b)
	)		   bit (1) aligned static options (constant);
dcl	IDCW		   bit (3) init ("7"b3) static options (constant);
dcl	(
	WRITE		   init ("31"b3),
	READ		   init ("25"b3),
	RESET_STATUS	   init ("40"b3),
	UNLOAD		   init ("72"b3)
	)		   bit (6) static options (constant);
dcl	UNLOCK		   bit (36) aligned init ((36)"0"b) static options (constant);
dcl	(
	ANNOUNCE_RECONNECT_DELTA
			   fixed bin (35) init (30000000),
						/* thirty seconds for reconnect announce throttling */
	DISK_POLLING_TIME	   fixed bin (35) init (2000000),
						/* two seconds for lost interrupt */
	INOP_POLLING_TIME	   fixed bin (35) init (5000000),
						/* five seconds for dropping out of ready */
	BROKEN_POLLING_TIME	   fixed bin (35) init (180000000),
						/* three minutes for standby */
	CHANNEL_POLLING_TIME   fixed bin (35) init (60000000)
						/* one minute for bad channel */
	)		   static options (constant);

dcl	bootload_disk_post	   entry (fixed bin (24), fixed bin (35));
dcl	seek_512		   bit (6) init ("30"b3) static options (constant);
dcl	syserr		   entry options (variable);
dcl	syserr$binary	   entry options (variable);
dcl	pxss$notify	   entry (bit (36) aligned);
dcl	page$done		   entry (fixed bin (24), fixed bin (35));
dcl	pmut$wire_and_mask	   entry (fixed bin (71) aligned, ptr);
dcl	pmut$unwire_unmask	   entry (fixed bin (71) aligned, ptr);
dcl	dctl$disk_inter	   entry (fixed bin (35), fixed bin (3), bit (36) aligned);
dcl	vtoc_interrupt	   entry (fixed bin (24), fixed bin (35));
dcl	ioi_masked$online_device_count
			   entry (char (*)) returns (fixed bin);
dcl	ioi_masked$interrupt   entry (fixed bin (35), fixed bin (3), bit (36) aligned);

dcl	(abs, addr, addrel, bin, bit, clock, convert, divide, fixed, float, lbound, length, hbound, max, mod, null, ptr,
	rel, stacq, string, substr, unspec)
			   builtin;

dcl	ME		   char (16) static options (constant) init ("disk_control");

dcl	dev_mask		   (0:63) bit (72) aligned static options (constant)
			   init ("100000000000000000000000000000000000000000000000000000000000000000000000"b,
			   "010000000000000000000000000000000000000000000000000000000000000000000000"b,
			   "001000000000000000000000000000000000000000000000000000000000000000000000"b,
			   "000100000000000000000000000000000000000000000000000000000000000000000000"b,
			   "000010000000000000000000000000000000000000000000000000000000000000000000"b,
			   "000001000000000000000000000000000000000000000000000000000000000000000000"b,
			   "000000100000000000000000000000000000000000000000000000000000000000000000"b,
			   "000000010000000000000000000000000000000000000000000000000000000000000000"b,
			   "000000001000000000000000000000000000000000000000000000000000000000000000"b,
			   "000000000100000000000000000000000000000000000000000000000000000000000000"b,
			   "000000000010000000000000000000000000000000000000000000000000000000000000"b,
			   "000000000001000000000000000000000000000000000000000000000000000000000000"b,
			   "000000000000100000000000000000000000000000000000000000000000000000000000"b,
			   "000000000000010000000000000000000000000000000000000000000000000000000000"b,
			   "000000000000001000000000000000000000000000000000000000000000000000000000"b,
			   "000000000000000100000000000000000000000000000000000000000000000000000000"b,
			   "000000000000000010000000000000000000000000000000000000000000000000000000"b,
			   "000000000000000001000000000000000000000000000000000000000000000000000000"b,
			   "000000000000000000100000000000000000000000000000000000000000000000000000"b,
			   "000000000000000000010000000000000000000000000000000000000000000000000000"b,
			   "000000000000000000001000000000000000000000000000000000000000000000000000"b,
			   "000000000000000000000100000000000000000000000000000000000000000000000000"b,
			   "000000000000000000000010000000000000000000000000000000000000000000000000"b,
			   "000000000000000000000001000000000000000000000000000000000000000000000000"b,
			   "000000000000000000000000100000000000000000000000000000000000000000000000"b,
			   "000000000000000000000000010000000000000000000000000000000000000000000000"b,
			   "000000000000000000000000001000000000000000000000000000000000000000000000"b,
			   "000000000000000000000000000100000000000000000000000000000000000000000000"b,
			   "000000000000000000000000000010000000000000000000000000000000000000000000"b,
			   "000000000000000000000000000001000000000000000000000000000000000000000000"b,
			   "000000000000000000000000000000100000000000000000000000000000000000000000"b,
			   "000000000000000000000000000000010000000000000000000000000000000000000000"b,
			   "000000000000000000000000000000001000000000000000000000000000000000000000"b,
			   "000000000000000000000000000000000100000000000000000000000000000000000000"b,
			   "000000000000000000000000000000000010000000000000000000000000000000000000"b,
			   "000000000000000000000000000000000001000000000000000000000000000000000000"b,
			   "000000000000000000000000000000000000100000000000000000000000000000000000"b,
			   "000000000000000000000000000000000000010000000000000000000000000000000000"b,
			   "000000000000000000000000000000000000001000000000000000000000000000000000"b,
			   "000000000000000000000000000000000000000100000000000000000000000000000000"b,
			   "000000000000000000000000000000000000000010000000000000000000000000000000"b,
			   "000000000000000000000000000000000000000001000000000000000000000000000000"b,
			   "000000000000000000000000000000000000000000100000000000000000000000000000"b,
			   "000000000000000000000000000000000000000000010000000000000000000000000000"b,
			   "000000000000000000000000000000000000000000001000000000000000000000000000"b,
			   "000000000000000000000000000000000000000000000100000000000000000000000000"b,
			   "000000000000000000000000000000000000000000000010000000000000000000000000"b,
			   "000000000000000000000000000000000000000000000001000000000000000000000000"b,
			   "000000000000000000000000000000000000000000000000100000000000000000000000"b,
			   "000000000000000000000000000000000000000000000000010000000000000000000000"b,
			   "000000000000000000000000000000000000000000000000001000000000000000000000"b,
			   "000000000000000000000000000000000000000000000000000100000000000000000000"b,
			   "000000000000000000000000000000000000000000000000000010000000000000000000"b,
			   "000000000000000000000000000000000000000000000000000001000000000000000000"b,
			   "000000000000000000000000000000000000000000000000000000100000000000000000"b,
			   "000000000000000000000000000000000000000000000000000000010000000000000000"b,
			   "000000000000000000000000000000000000000000000000000000001000000000000000"b,
			   "000000000000000000000000000000000000000000000000000000000100000000000000"b,
			   "000000000000000000000000000000000000000000000000000000000010000000000000"b,
			   "000000000000000000000000000000000000000000000000000000000001000000000000"b,
			   "000000000000000000000000000000000000000000000000000000000000100000000000"b,
			   "000000000000000000000000000000000000000000000000000000000000010000000000"b,
			   "000000000000000000000000000000000000000000000000000000000000001000000000"b,
			   "000000000000000000000000000000000000000000000000000000000000000100000000"b);

/* format: off */
/* Assumptions:

Several variables are expected to be correct through most of this program:

   dev	Device index of the devtab entry for the current device.
   dp	Devtab Pointer, indicates the current devtab to be operating upon.
	It is typically set from addr (disktab.devtab (pdi)).
   pdi	Primary Device Index of the current dev.  Found in devtab.pdi
          Used to determine primary device of shared devices.  The primary
	device will hold queue for all its shared spindles.
   sect_sw Sector switch indication for the current IO to be entered into a
	quentry (operation entry points), or when posting a completed IO.
	Major importance when posting an IO, since it must be correct for
	the coreadd being posted.
   sx	Subsystem index.  Indicates which subsystem is in use, in order of
	definition of subsystems in the config_file.

     When a disk interrupt is received, we take info on dev, pdi, coreadd,
sect_sw from the entry in check_stat.  These should not be messed with, since
check_stat will also return the queue element to the free_q and will call
getwork to start fresh IO on the channel ASAP.  Sect_sw and coreadd must still
be good at post time.

     Since on shared devices, a single pdi's queue will hold requests for more
than a single device, the dev value is recovered from the selected queue in
getwork (after xfer_join) to ensure we know who we are dealing with.

     Add_wq will add the new request to the queue of the pdi, but will do the
appropriate statistics (other than queue stats) on the device (dev).  Same with
del_q.
*/
/* format: on */

/* Entry points to generate disk requests.  Setup the type of the IO and then
   enter common code to process entry conditions.  If we are doing testing or
   VTOCE IO, then we have to wire and mask.  If doing PAGE IO, then we are
   wired and masked. */


write_sectors:
     entry (a_pvtx, a_coreadd, a_devadd, a_sect_off, a_n_sectors);

	io_type = VTOC_WRITE;
	goto go_sector;


read_sectors:
     entry (a_pvtx, a_coreadd, a_devadd, a_sect_off, a_n_sectors);

	io_type = VTOC_READ;
go_sector:
	devadd = bin (a_devadd, 18);			/* copy device address */
	coreadd = a_coreadd;			/* copy core address */

	sect_off = a_sect_off;			/* setup offset */
	n_sectors = a_n_sectors;
	goto go_masked;				/* Enter masked env */


test_drive:
     entry (a_pvtx);				/* test drive by issuing RSS */

	io_type = TEST;
	coreadd = bin (RESET_STATUS, 24);		/* Device TEST command */
	goto go_test;



unload_drive:
     entry (a_pvtx);				/* cycle down a drive */

	io_type = TEST;
	coreadd = bin (UNLOAD, 24);			/* Device UNLOAD command */
go_test:
	sect_off = 0;				/* no offset if TEST */
	n_sectors = 0;				/* no sectors if TEST */
	devadd = 0;				/* no core if TEST */

/* Sector and Test IO must be masked and have the stack wired. */

go_masked:
	call pmut$wire_and_mask (mask, ptp);		/* mask for processing */
	masked = "1"b;				/* so we unmask */
	intrpt = "0"b;
	goto go_common;


/* Write/Read a Virtual Memory Page between Disk and a Memory Frame. */

disk_write:
     entry (a_pvtx, a_coreadd, a_devadd, a_intrpt);

	io_type = PAGE_WRITE;
	goto go_page;

disk_read:
     entry (a_pvtx, a_coreadd, a_devadd, a_intrpt);

	io_type = PAGE_READ;
go_page:
	masked = "0"b;				/* run unmasked */
	devadd = bin (a_devadd, 18);			/* copy device address */
	coreadd = a_coreadd;			/* copy core address */
	sect_off = 0;				/* no sector offset */
	n_sectors = 0;
	if a_intrpt ^= 0 then
	     intrpt = "1"b;				/* completion interrupt */
	else intrpt = "0"b;

/* Initialize indices and pointers and lock database.  Then do operation. */


go_common:
	entry_time = clock ();
	sect_sw = sector_map (io_type);
	bootload_sw = bootload_map (io_type);
	pvtep = addr (addr (pvt$array) -> pvt_array (a_pvtx));
						/* Get pointer to PVT entry for this device. */
	pvtdip = addr (pvte.dim_info);		/* Get pointer to DIM info. */
	sx = pvtdi.sx;				/* Extract index for this disk subsystem. */
	call setup;				/* Get pointers to data bases. */
	call lock (addr (disktab.call_lock_meters));	/* Lock the database. */

	dev = pvte.logical_area_number;		/* Get physical device number. */
	pdi = disktab.devtab (dev).pdi;		/* Get PDI. */
	dp = addr (disktab.devtab (pdi));		/* Get pointer to info for primary device. */

/* Test for device not to be used. */

	if devtab.abandoned then do;			/* If device is hopelessly broken ... */
	     errcd = 0;				/* Clear error code. */
	     if ^write_map (io_type) then do;		/* If about to read ... */
		erfp = addr (errcd);		/* Get pointer for mismatching dcl. */
		errflags.device_inoperative = "1"b;	/* Indicate read could not succeed. */
	     end;
	     call unlock;				/* Undo the lock. */
	     call post;				/* Pretend write was successful. */
	     go to call_exit;			/* Clean up and exit. */
	end;

/* Attempt to get free queue entry to fill in. */

	disktab.alloc_wait_meters.count = disktab.alloc_wait_meters.count + 1;
	if ^get_free_q () then do;			/* Try to grab a free queue entry. */
	     call lock_meter_start (addr (disktab.alloc_wait_meters));
	     do while (^get_free_q ());		/* Try to grab a free queue entry. */
		call call_run (sx);			/* If none, wait until some free up. */
	     end;					/* Note: run destroys value of pvtep */
	     call lock_meter_stop (addr (disktab.alloc_wait_meters));
	end;

/* Compute physical sector address from input info.  Physical sector result
   accounts for unused sectors per cylinder. */

	if pvte.is_sv then do;			/* convert the subvolume devadd to the real devadd */
	     record_offset = mod (devadd, pvte.records_per_cyl);
	     devadd = ((devadd - record_offset) * pvte.num_of_svs) + pvte.record_factor + record_offset;
	end;
	sector = devadd * sect_per_rec (pvte.device_type);/* raw sector. */
	cylinder = divide (sector, pvtdi.usable_sect_per_cyl, 12, 0);
	sector = sector + cylinder * pvtdi.unused_sect_per_cyl;
	sector = sector + sect_off;			/* sector offset, if any. */

/* Fill in the queue entry. */

	quentry.intrpt = intrpt;			/* completion? */
	quentry.used = "1"b;			/* in-use */
	quentry.type = io_type;			/* Type of IO */
	quentry.coreadd = bit (coreadd, 24);		/* Insert the memory address for data xfer. */

	quentry.pvtx = a_pvtx;			/* Save for azm */
	quentry.pdi = pdi;				/* Also save PDI for this device. */
	quentry.dev = dev;				/* Place device code in queue entry. */
	quentry.cylinder = cylinder;			/* And the cylinder number. */

	quentry.n_sectors = n_sectors;		/* And the number of sectors (sector I/O only) */
	quentry.sector = bit (sector, 21);		/* Save the disk device address. */

/* Record time for AZM and stagnation testing. */

	quentry.time = entry_time;

/* If this is the only request for this device, try to start up a free channel.
   Otherwise, queue the request for processing later. */

	if ^(disktab.dev_busy | disktab.dev_queued) & dev_mask (pdi) then
	     do i = 1 to disktab.nchan;		/* If device is free with no other requests ... */
	     cp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (i));
						/* Try to find a channel to run. */
	     if chantab.in_use & ^chantab.active then do; /* If free usable channel ... */
		call gotwork;			/* Let's do this request. */
		go to working;			/* And exit the loop. */
	     end;
	end;

	call add_wq;				/* Add item to end of appropriate queue. */

/* Clean up and exit. */

working:
	call unlock;				/* Unlock the data base now. */

call_exit:
	if masked then
	     call pmut$unwire_unmask (mask, ptp);	/* Restore vtoc_man's environment */

	return;

/* ESD_RESET_LOCKS - Reset data base locks on emergency shutdown. */

esd_reset_locks:
     entry;

	disksp = addr (disk_seg$);

	unspec (disk_data.free_q) = "0"b;		/* clear free_q */
	disk_data.free_q.depth = disk_data.free_q_size;	/* empty queue */

/* This form of unlocking is used because it causes a load of "0"b and
   and ANSA instruction.  This will do a read/alter/re-write cycle and
   correctly update cache.  We cannot STACQ since it may not have been locked
   to our processid. */

	unspec (disk_data.lock) = unspec (disk_data.lock) & "0"b;

	do qx = 1 to disk_data.free_q_size;		/* Look at each queue entry. */
	     qp = addr (disk_data.free_q_entries (qx));
	     qrp = rel (qp);

	     call add_free_q;			/* Free all entries at ESD time. */
	end;

	do sx = 1 to disk_data.subsystems;
	     call setup;				/* Get pointer to subsystem data. */
	     call unlock;				/* Undo the lock. */

	     call lock (addr (disktab.call_lock_meters)); /* Set the lock to us. */

	     do dev = disktab.first_dev to disktab.last_dev;
						/* Clear each device. */
		dp = addr (disktab.devtab (dev));	/* Get pointer to info for device. */
		devtab.broken, devtab.was_broken, devtab.inop = "0"b;
						/* Try to use broken device. */
		devtab.cylinder = 0;		/* Reset positional info. */
		unspec (devtab.wq) = "0"b;		/* Clear queue pointers */

/* reset optimizer queue depth to reflect empty queues. */

		do i = 0 to MAX_IO_TYPE;
		     devtab.forward = "1"b;
		     devtab.opt_info (i).depth = 0;
		end;
	     end;

	     cp = ptr (disksp, disktab.channels);	/* Get pointer to channel table. */
	     do i = 1 to disktab.nchan;		/* Iterate through all channels. */
		cp -> disk_channel_table (i).active = "0"b;
						/* Mark all channels as not busy. */
		cp -> disk_channel_table (i).inop = "0"b;
						/* Mark as operative */
		cp -> disk_channel_table (i).broken = "0"b;
						/* Mark as not broken */
                    if ^(cp -> disk_channel_table (i).ioi_use) &
                       ^(cp -> disk_channel_table (i).in_use) then do;
                        cp -> disk_channel_table (i).in_use = "1"b;
                        disktab.channels_online = disktab.channels_online+1;
		  end;     
		cp -> disk_channel_table (i).erct = 0;	/* clear error count */
	     end;

	     disktab.dev_busy = "0"b;			/* Clear busy device flags. */
	     disktab.dev_queued = "0"b;		/* Clear request queued flags. */

	     call run;				/* Start this subsystem rolling. */
	     call unlock;				/* Undo the lock. */
	end;

	return;

/* USURP_CHANNEL/CEDE_CHANNEL - Share disk channels with IOI. */

usurp_channel:
     entry (a_sx, a_chx, a_required, a_iom_chx, a_statusp); /* Entry to usurp channel for IOI use. */

dcl	a_sx		   fixed bin (8);		/* disk subsystem index */
dcl	a_chx		   fixed bin (35);		/* disk channel index */
dcl	a_required	   bit (1) aligned;		/* "1"b if specific channel required */

dcl	chx		   fixed bin (35);		/* chx as an integer */

	sx = a_sx;				/* Copy subsystem index. */
	required = a_required;			/* Copy argument. */
	chx = a_chx;				/* copy chx */
	call setup;				/* Get appropriate pointers. */
	cp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (chx));
						/* Get pointer to chantab entry. */

	call pmut$wire_and_mask (mask, ptp);		/* Wire stack and mask interrupts. */
	call lock (addr (disktab.call_lock_meters));	/* Lock the disk database. */

	usurped = (required | ^(chantab.broken | chantab.inop)) &
						/* Usurp if required or not defective channel, and ... */
	     ((disktab.channels_online > 1) | ^chantab.in_use
	     | (ioi_masked$online_device_count (disk_data.name (sx)) = 0));
						/* Ensure last good channel will not be usurped. */

	if usurped then do;				/* If we may, usurp the channel. */
	     if chantab.in_use then			/* If channel is being used, count it out. */
		disktab.channels_online = disktab.channels_online - 1;
	     chantab.in_use = "0"b;			/* Take channel out of operation. */
	     chantab.broken, chantab.inop = "0"b;	/* Clear flags. */
	end;

	call unlock;				/* Unlock the disk database. */
	call pmut$unwire_unmask (mask, ptp);		/* Unwire stack and unmask interrupts now. */

	if usurped then do;				/* If channel now usurped ... */
	     do while (chantab.active);		/* Wait for I/O to stop. */
	     end;
	     a_iom_chx = chantab.chx;
	     a_statusp = chantab.statusp;
	     chantab.ioi_use = "1"b;			/* Now allow IOI to use channel. */
	end;
	else do;
	     a_iom_chx = 0;
	     a_statusp = null ();
	end;

	return;

cede_channel:
     entry (a_sx, a_chx, a_iom_chx, a_statusp);		/* Entry to cede channel from IOI use. */

dcl	a_iom_chx		   fixed bin (35) parameter;
dcl	a_statusp		   ptr parameter;

dcl	iom_chx		   fixed bin (35);
dcl	statusp		   ptr;

	sx = a_sx;				/* Copy subsystem index. */
	chx = a_chx;				/* copy chx */
	iom_chx = a_iom_chx;
	statusp = a_statusp;
	call setup;				/* Get appropriate pointers. */
	cp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (chx));
						/* Get pointer to chantab entry. */

	chantab.chx = iom_chx;
	chantab.statusp = statusp;
	chantab.ioi_use = "0"b;			/* Take channel back from IOI. */
	chantab.in_use = "1"b;			/* Place channel back in operation. */
	disktab.channels_online = disktab.channels_online + 1;

	return;

/* Entry to manually add a deleted channel */

add_channel:
     entry (a_sx, a_chx, a_code);

dcl	a_code		   fixed bin (35) parameter;

	sx = a_sx;
	chx = a_chx;
	call setup;
	cp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (chx));
	call pmut$wire_and_mask (mask, ptp);
	call lock (addr (disktab.call_lock_meters));
	if chantab.broken then do;
	     chantab.broken = "0"b;
	     chantab.in_use = "1"b;
	     disktab.channels_online = disktab.channels_online + 1;
	end;
	else errcd = error_table_$io_configured;
	call unlock;
	call pmut$unwire_unmask (mask, ptp);
	if errcd = 0 then
	     call syserr (ANNOUNCE, "^a: Adding channel ^a.", ME, chantab.chanid);
	a_code = errcd;
	return;

/* DISK_RUN - External entry to poll all disk subsystems. */

disk_run:
     entry;					/* here to keep going */

	entry_time = clock ();			/* get time of entry */

	disksp = addr (disk_seg$);			/* Get pointer to disk data base. */

	do sx = 1 to disk_data.subsystems;		/* Iterate through all disk subsystems. */
	     call setup;				/* Get pointers to data base. */
	     call lock (addr (disktab.run_lock_meters));	/* Lock the database. */
	     call run;				/* Now perform run operation. */
	     call unlock;				/* Unlock the data base when finished. */
	end;

	return;



/* CALL_RUN - Entry to poll a single disk subsystem. */

call_run:
     entry (a_sx);


	entry_time = clock ();

	sx = a_sx;				/* Copy the subsystem index. */
	call setup;
	call run;

/* run the other sub-systems too.  But now we have to lock them if possible. */

	call_run_sx = a_sx;				/* save sx to return to */
	do sx = 1 to disk_data.subsystems;
	     if sx ^= call_run_sx then do;
		call setup;
		if stacq (disktab.lock, pds$processid, UNLOCK) then do;
						/* locked it */
		     call run;
		     call unlock;
		end;
	     end;
	end;
	sx = call_run_sx;
	call setup;				/* restore sub-sys */
	return;

/* RUN - Internal entry to perform polling. */

run:
     proc;

/* Perform channel polling. */

	do i = 1 to disktab.nchan;			/* Iterate through all channels. */
	     cp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (i));
						/* Generate pointer to channel info table. */

	     if chantab.inop & ^chantab.in_use then	/* If channel is inoperative ... */
		if clock () - chantab.connect_time > CHANNEL_POLLING_TIME then do;
		     chantab.in_use = "1"b;		/* Try once more. */
		     disktab.channels_online = disktab.channels_online + 1;
		end;

/* format: off */
/* Poll for disk completion.  This is required for allocation lock checks, and
   during run_locks from page control, since both are run masked, and this
   polling is the only way we would see disk completion.  This race hazard
   on normal 15-seconds run_locks will produce some interrupts without
   terminate status, but you can't win them all.  It may also produce some
   situations of interrupt wile not active. */
/* format: on */

	     if ^chantab.active then			/* If channel is inactive ... */
		call getwork;			/* Fire it up. */

	     else do;				/* Attempt to pick up status. */
		status_time = clock ();		/* For reconnect test, NOT race */
		io_status_entry_ptr = addr (stat_entry);
		call io_manager$get_status ((chantab.chx), io_status_entry_ptr);
						/* See if any status has come in. */
		io_status_word_ptr = addr (stat_entry.word1);
		if /* case */ io_status_word.t then do; /* If status is present ... */
		     chantab.status_from_run = chantab.status_from_run + 1;
		     level = 3;			/* Set terminate status level. */
		     call check_stat;		/* Go examine the status. */

		     if post_sw then do;		/* If previous I/O must be posted ... */
			call unlock;		/* Don't call out with our lock set. */
			call post;		/* Do the posting. */
			call lock (addr (disktab.call_lock_meters));
						/* Relock our data base now. */
		     end;
		end;

		else if chantab.connect_time + DISK_POLLING_TIME < status_time then do;
						/* If an interrupt has been lost ... */
		     idcwp = addr (chantab.scdcw);	/* Find out device in operation. */
		     dev = fixed (idcw.device, 6);	/* .. */
		     pdi = disktab.devtab (dev).pdi;	/* Get PDI for this device. */
		     if chantab.reconnect_announce_time < status_time then do;
			chantab.reconnect_announce_time = status_time + ANNOUNCE_RECONNECT_DELTA;
			sysc = ANNOUNCE;
		     end;
		     else sysc = LOG;
		     call syserr (sysc, "^a: Reconnected ^a I/O on ^a (channel ^a).", ME,
			IO_TYPE (ptr (disksp, chantab.qrp) -> quentry.type), disk_name (SINGLE), chantab.chanid);
		     call connect (idcwp);		/* Reconnect */
		end;
	     end;
	end;


/* Perform device polling. */

	do dev = disktab.first_dev to disktab.last_dev;	/* Poll all devices. */
	     pdi = disktab.devtab (dev).pdi;		/* Get PDI for this device. */
	     if pdi = dev then do;			/* This is primary device. */
		dp = addr (disktab.devtab (pdi));	/* Get pointer to primary device info. */

		if /* case */ devtab.inop then	/* If device is inoperative ... */
		     if clock () - devtab.time_inop > INOP_POLLING_TIME then do;
			disktab.dev_busy = disktab.dev_busy & ^dev_mask (pdi);
		     end;				/* Try to use device again. */
		     else ;

		else if devtab.broken then		/* If device is broken ... */
		     if clock () - devtab.time_inop > BROKEN_POLLING_TIME then do;
			devtab.inop = "1"b;		/* Mark as inoperative again. */
			devtab.was_broken = "1"b;	/* .. */
			pvtep = addr (addr (pvt$array) -> pvt_array (devtab.pvtx));
			call set_pvte_inop (OFF);
			devtab.broken = "0"b;	/* Turn off broken flag. */
		     end;
		     else ;
	     end;
	end;

	return;


     end run;

/* DISK_INTER - This is the interrupt side of the disk DIM. */

disk_inter:
     entry (idx, ilevel, istat);			/* called by io_manager at interrupt time */

dcl	idx		   fixed bin (35),		/* channel ID index */
	istat		   bit (36) aligned,	/* status for specials or faults */
	ilevel		   fixed bin (3);		/* level of interrupt */

dcl	int_idx		   fixed bin (35);		/* idx as an integer */

	int_idx = idx;
	sx = divide (int_idx, dskdcl_chans_per_subsys, 17, 0);
						/* Get index of this disk subsystem. */
	call setup;				/* Get pointer to data base. */

	i = int_idx - sx * dskdcl_chans_per_subsys + 1;	/* Compute expected channel table index. */
	cp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (i));

	level = ilevel;				/* copy the level */
	stat = istat;
	if level = 7 then do;
	     call check_special_stat;
	     return;
	end;


	io_status_word_ptr = chantab.statusp;		/* point to status */

	if ^io_status_word.t then
	     if level >= 3 then do;
		chantab.no_status_terminate = chantab.no_status_terminate + 1;
		return;
	     end;


	if ^chantab.ioi_use then do;			/* If terminate, marker, or fault ... */
	     call lock (addr (disktab.int_lock_meters));	/* Lock the database. */
	     io_status_entry_ptr = addr (stat_entry);	/* point to an area to return status */
	     unspec (io_status_entry) = ""b;
	     if /* case */ level = 3 then do;		/* Reget status, under lock */
		call io_manager$get_status ((chantab.chx), io_status_entry_ptr);
		io_status_word_ptr = addr (io_status_entry.word1);
		if ^io_status_word.t then do;
		     chantab.no_io_terminate = chantab.no_io_terminate + 1;
		     call unlock;
		     return;
		end;
	     end;
	     call check_stat;			/* Go process the status. */
	     call unlock;				/* Clear data base lock. */

	     if post_sw then			/* If posting previous operation ... */
		call post;
	end;

	else					/* If status for IOI channel ... */
	     call ioi_masked$interrupt ((chantab.ioi_ctx), level, stat);

	return;					/* And return to caller. */

check_special_stat:
     proc;

	io_special_status_ptr = addr (stat);		/* base our templates */
	if ^io_special_status.t then
	     return;

	dev = fixed (io_special_status.device, 6);	/* Extract device address from status. */
	if dev = 0 & disktab.first_dev ^= 0 then	/* If special for disk controller ... */
	     go to ioi_special;			/* Perhaps IOI wants this one, but we don't. */
	if dev > disktab.last_dev then
	     return;				/* Ignore this if number out-of-bounds. */

	dp = addr (disktab.devtab (dev));		/* Get pointer to device info structure. */
	pdi = devtab.pdi;				/* Get PDI. */

	pvtx = devtab.pvtx;				/* Get index to PVT entry for device. */
	if pvtx = 0 then
	     return;				/* This will occur when an MPC broadcasts
						   a special interrupt status to all LA's attached to
						   it, and the MPC controls more than one
						   subsystem as seen by the PVT. */
	pvtep = addr (pvt_array (pvtx));		/* Get pointer to PVT entry. */

	if pvte.storage_system then do;		/* If storage system volume ... */
	     call lock (addr (disktab.int_lock_meters));	/* Lock disk database. */

	     dp = addr (disktab.devtab (pdi));
	     if /* case */ devtab.broken then do;	/* If device declared broken ... */
		call syserr (ANNOUNCE, "^a: Placing ^a in operation.", ME, disk_name (BOTH));
		call set_pvte_inop (OFF);		/* Let ops get through */
		devtab.inop = "1"b;			/* Promote to inoperative state. */
		devtab.was_broken = "1"b;		/* .. */
		devtab.broken = "0"b;		/* Attempt to use device again. */
	     end;

	     else if devtab.inop then do;		/* If device is inoperative ... */
		devtab.inop = "0"b;			/* Attempt to place back in operation. */
		disktab.dev_busy = disktab.dev_busy & ^dev_mask (pdi);
	     end;

	     call call_run (sx);			/* Force run call on special interrupt. */

	     call unlock;				/* Undo the lock now. */
	end;

	else do;					/* If not storage system volume ... */
ioi_special:
	     call ioi_masked$interrupt ((chantab.ioi_ctx), level, stat);
	end;					/* Pass on the status to IOI. */

	return;

     end check_special_stat;

/* Pick up and examine the status. */

check_stat:
     procedure;

	errcd = 0;				/* Clear the error code */
	erfp = addr (errcd);
	post_sw = "0"b;				/* Clear posting required flag. */

	if ^chantab.active then do;			/* If channel wasn't active, whisper bloody murder. */
	     chantab.terminate_not_active = chantab.terminate_not_active + 1;
	     call syserr (JUST_LOG, "^a: Unexpected IOM status ^24.3b for ^a (channel ^a).", ME,
		string (io_status_word), disk_data.name (sx), chantab.chanid);
	     return;
	end;

	status_time = clock ();

	qrp = chantab.qrp;				/* Get pointer to queue entry. */
	qp = ptr (disksp, qrp);
	dev = quentry.dev;				/* Extract device address from queue entry. */
	pdi = quentry.pdi;				/* Get PDI for this request. */
	coreadd = bin (quentry.coreadd, 24);		/* Get memory address. */
	pvtx = quentry.pvtx;			/* Get PVT index. */
	sect_sw = sector_map (quentry.type);
	bootload_sw = bootload_map (quentry.type);

	pvtep = addr (addr (pvt$array) -> pvt_array (pvtx));
						/* Get pointer to PVT entry. */
	dp = addr (disktab.devtab (pdi));		/* Get pointer to primary device info structure. */


/* Remember this queue type entry so that we do the posting correctly. */

	io_type = quentry.type;


/* Process termination status. */

	if level = 3 then do;			/* If terminate status... */
	     chantab.active = "0"b;			/* Channel is no longer active. */
	     disktab.dev_busy = disktab.dev_busy & ^dev_mask (pdi);
						/* Indicate primary device no longer busy. */

/* Process completion of detailed status read. */

	     if /* case */ chantab.rsr then do;		/* If detailed status was just read ... */
		if (string (io_status_word) & disk_data.status_mask) then
						/* Don't print bad RSR's */
		     chantab.rsr = "0"b;		/* So clear this bit now. */
		unspec (io_status_entry.detailed_status (*)) = unspec (chantab.detailed_status (*));
						/* copy detail over */

		io_status_word_ptr = addr (chantab.status);
						/* Unsave previous error status. */
		command = chantab.command;		/* And previous device command. */
		call extract_status;		/* Extract status info anew. */
		call handle_error;			/* Now handle the error. */

		chantab.rsr = "0"b;			/* Turn off the bit. */
	     end;

/* Handle abnormal termination status. */

	     else if string (io_status_word) & disk_data.status_mask then do;
		call extract_status;		/* Extract status info from status word. */
		call interpret_status;		/* Get pointer to interp data. */
		call get_disk_command;		/* Extract peripheral command. */

		if disk_error_interp.rsr & (io_status_entry.detailed_status (1) = ""b) then do;
						/* If RSR required and none available ... */
		     chantab.rsr = "1"b;		/* Do it now. */
		     chantab.status = string (io_status_word);
						/* Save status info for after RSR. */
		     chantab.action_code = io_status_entry.action_code;
		     chantab.command = command;	/* Also the device command. */

		     idcwp = addr (chantab.dscdcw);
		     idcw.device = bit (dev);
		     call connect (idcwp);		/* Connect to RSR instruction. */
		end;

		else				/* If no RSR required ... */
		     call handle_error;		/* Handle error right now. */
	     end;

/* Test for nonzero tally residue in DCW. */

	     else if io_status_entry.tally_residue ^= 0 then do;
		majstat = 20;
		substat = ANY;
		call handle_error;			/* Treat like any other error. */
	     end;

/* Handle successful termination of disk operation. */

	     else do;				/* If we got here, operation was successful. */
		post_sw = "1"b;			/* Post the results. */

		if io_status_word.sub & "010011"b then do;
						/* If controller performed EDAC or auto retry ... */
		     disktab.edac_errors = disktab.edac_errors + 1;

		     if io_status_word.sub & "010000"b then
						/* If EDAC performed ... */
			majstat = 22;
		     else				/* If auto retries performed ... */
			majstat = 21;
		     substat = ANY;
		     call interpret_status;		/* Interpret status info. */
		     call get_disk_command ();	/* Get the command */
		     call printerr;			/* Enter message in syserr log. */
		end;

		devtab.inop = "0"b;			/* Clear this flag. */

		if devtab.was_broken | devtab.broken then do;
						/* Was disk previously inoperative? */
		     devtab.was_broken = "0"b;	/* Clear flag now. */
		     devtab.broken = "0"b;
		     call set_pvte_inop (OFF);
		     call syserr (ANNOUNCE, "^a: ^a now operational.", ME, disk_name (BOTH));
		end;
		chantab.inop = "0"b;		/* Clear this flag. */
	     end;

	end;					/* level 3 */

/* Handle system fault status. */

	else if level = 1 then do;			/* If system fault word  ... */
	     chantab.active = "0"b;			/* Channel is no longer active. */
	     disktab.dev_busy = disktab.dev_busy & ^dev_mask (pdi);
						/* Indicate device no longer busy. */
	     majstat = 19;
	     substat = ANY;
	     call handle_error;			/* Use standard error handler. */
	end;


	else return;				/* Ignore anything else. */

/* If no posting to be done, don't do any of the following. */

	if post_sw then do;
	     if io_type = TEST then do;
		pvte.testing = "0"b;
		post_sw = "0"b;
	     end;					/* Perform metering on completed I/O (whether successful or not). */
	     else do;
		status_time = clock ();		/* Get time now. */
		channel_time = status_time - chantab.connect_time;
						/* Compute time channel in use. */
		wait_time = status_time - quentry.time;

		optp = addr (devtab.opt_info (quentry.type));
						/* get opt_info */

		opt_info.channel_wait = opt_info.channel_wait + channel_time;
		opt_info.queue_wait = opt_info.queue_wait + wait_time;

/* Test for error */

		if errcd ^= 0			/* count a fatal error */
		     then
		     disktab.ferrors = disktab.ferrors + 1;
	     end;

	     call add_free_q;			/* Scrap queue entry now. */
	end;

	if ^chantab.active then			/* If channel is now free ... */
	     call getwork;				/* Look for more work to do. */

	return;					/* And return to caller. */

/* EXTRACT_STATUS - Extract major and substatus. */

extract_status:
	proc;

	     if /* case */ io_status_word.power then do;
		majstat = 16;
		substat = ANY;
	     end;
	     else if io_status_word.channel_stat then do;
		majstat = 17;
		substat = io_status_word.channel_stat;
	     end;
	     else if io_status_word.central_stat then do;
		majstat = 18;
		substat = io_status_word.central_stat;
	     end;
	     else do;
		majstat = bin (io_status_word.major, 4);
		substat = io_status_word.sub;
	     end;


	end extract_status;



/* INTERPRET_STATUS - Get interpretive info for status. */

interpret_status:
	proc;


	     dedp = addr (disk_error_data$);
	     if pvte.is_sv then
		dskerap = addrel (dedp, disk_error_data (majstat).finterp);
	     else dskerap = addrel (dedp, disk_error_data (majstat).interp);

/***** find first description, which is just after last used substatus array entry */
	     name_rel = fixed (rel (addrel (dedp, disk_error_data (lbound (disk_error_data, 1)).namep)), 17);
	     dskerp = addr (disk_status_interp_array (lbound (disk_status_interp_array, 1)));
	     do i = lbound (disk_status_interp_array, 1) by 1 while (bin (rel (dskerp), 18) < name_rel);
		dskerp = addr (disk_status_interp_array (i));
		if (substat & disk_error_interp.bitmask) = disk_error_interp.bitson then
		     return;
	     end;


	end interpret_status;



/* GET_DISK_COMMAND - Find Command Causing Disk Error. */

get_disk_command:
	proc;

	     idcwp = addrel (diskp, bin (io_status_entry.next_lpw_offset, 18) - disktab.abs_mem_addr - 1);
						/* Get pointer to IDCW. */
	     do while (idcw.code ^= IDCW);		/* Search backward to IDCW. */
		idcwp = addrel (idcwp, -1);
	     end;
	     command = idcw.command;			/* Extract command from IDCW. */


	end get_disk_command;

/* PRINTERR - Print disk error message. */

printerr:
	proc;

dcl	type		   fixed bin;		/* device type */
dcl	record_address	   fixed bin (18);		/* Multics page address */
dcl	mjsdp		   ptr;			/* major status description pointer */
dcl	ssdp		   ptr;			/* substatus description pointer */
dcl	imu_detailed_status	   (0:23) bit (8) based;	/* IMU detailed status bytes */
dcl	logical_rec_addr	   fixed bin (17);		/* logical record address of subvolume */
dcl	logical_sector	   fixed bin (21);		/* logical sector of subvolume */
dcl	sector_offset	   fixed bin (17);		/* used in calculation of logical_sector */

	     if devtab.broken then
		return;				/* Keep mum about broken devices. */

	     sector = bin (chantab.select_data.sector);	/* get sector number of disk address of error */
	     type = pvte.device_type;			/* get device type */
	     pvtdip = addr (pvte.dim_info);
	     record_address =
		divide (sector - (divide (sector, sect_per_cyl (type), 17, 0) * pvtdi.unused_sect_per_cyl),
		sect_per_rec (type), 17, 0);

	     if pvte.is_sv then do;
		record_offset = mod (record_address, pvte.records_per_cyl);
		logical_rec_addr =
		     divide ((record_address - pvte.record_factor - record_offset), pvte.num_of_svs, 17)
		     + record_offset;
		sector_offset = mod (sector, sect_per_cyl (type));
		logical_sector =
		     divide ((sector - (pvte.sv_num * sect_per_cyl (type)) - sector_offset), pvte.num_of_svs, 17)
		     + sector_offset;
	     end;
	     else do;
		logical_rec_addr = record_address;
		logical_sector = sector;
	     end;


	     if pvte.is_sv then
		mjsdp = addrel (dedp, disk_error_data (majstat).fnamep);
	     else mjsdp = addrel (dedp, disk_error_data (majstat).namep);
	     ssdp = addrel (dedp, disk_error_interp.namep);

	     unspec (msg_buf) = "0"b;			/* Now build data portion of syserr message */
	     io_msgp = addr (msg_buf);
	     io_msg.level = bit (level, 3);
	     io_msg.channel = chantab.chanid;
	     io_msg.device = bit (dev);
	     io_msg.type = chantab.action_code;
	     io_msg.command = command;
	     io_msg.status = string (io_status_word);
	     io_msg.devname = disk_data.name (sx);

	     if /* case */ devtab.broken | disk_error_interp.just_log then
		sysc = JUST_LOG;
	     else if mod (chantab.erct, 5) = 1 then
		sysc = ANNOUNCE;
	     else sysc = JUST_LOG;
	     call syserr$binary (sysc, io_msgp, SB_disk_err, SBL_disk_err,
		"^a: ^a ^[^12.3b^1s^;^1s^a^] for ^a (channel ^a).^/^2-rec ^o, sect ^o, main ^o^[^/^2-subvol ^a, logical rec ^o, logical sect ^o^;^3s^]^[^/^2-detailed status:^24( ^2.4b^).^;^s^]",
		ME, mjsdp -> disk_status_descrip.chr, (level = 1), stat, ssdp -> disk_status_descrip.chr,
		disk_name (SINGLE), chantab.chanid, record_address, sector, coreadd, pvte.is_sv, pvte.sv_name,
		logical_rec_addr, logical_sector, (io_status_entry.detailed_status (1) ^= ""b),
		addr (io_status_entry.detailed_status) -> imu_detailed_status);

	     return;


	end printerr;

/* HANDLE_ERROR - Handle disk errors. */

handle_error:
	proc;


	     chantab.erct = chantab.erct + 1;
	     disktab.errors = disktab.errors + 1;

	     call interpret_status;			/* Look this error up. */
	     if io_type = TEST then
		idcwp = addr (chantab.rssdcw);
	     else idcwp = addr (chantab.scdcw);

	     if ^(io_type = TEST & ^disk_error_interp.bad_path) then
		call printerr;			/* print and log error */

	     if /* case */ chantab.erct <= disk_error_interp.max_retries & io_type ^= TEST then do;
		if disk_error_interp.reseek then do;	/* If reseek desired before retry ... */
		     idcwp = addr (chantab.rstdcw);
		     idcw.device = bit (dev);
		     call connect (idcwp);		/* Connect to restore instruction. */
		end;
		else do;				/* If retrying ... */
		     if disk_error_interp.bad_path then do;
						/* Burn real time */
			temp_time = clock ();
			do while (clock () < temp_time + 750000);
						/* 3/4 sec. */
			end;
		     end;
		     call connect (idcwp);
		end;
	     end;

	     else if disk_error_interp.bad_dev then do;	/* If error indicates a bad device ... */
		if /* case */ devtab.inop | devtab.broken | io_type = TEST then do;
						/* If device is already inoperative or broken ... */
		     if ^devtab.broken then		/* If not already broken ... */
			if quentry.type ^= TEST then
			     call syserr (BEEP, "^a: ^a requires intervention.", ME, disk_name (SINGLE));
		     devtab.broken = "1"b;		/* Break the device altogether. */
		     call set_pvte_inop (ON);
		     devtab.was_broken = "0"b;
		     devtab.inop = "0"b;		/* And clear this flag. */
		     devtab.time_inop = clock ();	/* Note the current time. */

		     errflags.device_inoperative = "1"b;/* Set error code. */
		     post_sw = "1"b;		/* Going to post this as error. */
		end;

		else if tc_data$system_shutdown = 0 then do;
						/* Device was not previously inoperative. */
		     devtab.inop = "1"b;		/* Mark it as inoperative. */
		     disktab.dev_busy = disktab.dev_busy | dev_mask (pdi);
						/* Mark as busy to prevent further use. */
		     devtab.time_inop = clock ();	/* Note the current time. */
		     call add_wq;			/* Place request at tail of queue. */
		end;

		else do;				/* If during shutdown ... */
		     if quentry.type = TEST then
			call set_pvte_inop (ON);
		     errflags.device_inoperative = "1"b;
		     post_sw = "1"b;		/* Post this fact without further ado. */
		end;
	     end;
	     else if disk_error_interp.bad_addr then do;	/* If disk address is no good ... */
		if write_map (quentry.type) then	/* If writing ... */
		     errflags.reassign_address = "1"b;	/* Try another disk address. */
		else				/* If reading ... */
		     errflags.seg_unusable = "1"b;	/* Mark segment as unusable. */
		post_sw = "1"b;			/* Post this as error. */
	     end;

	     else if disk_error_interp.bad_path then do;	/* If error indicates a bad channel or controller ... */
		if chantab.inop then do;		/* If channel previously in trouble ... */
		     chantab.broken = "1"b;
		     chantab.inop = "0"b;
		end;
		else do;				/* If channel just started to act up ... */
		     chantab.inop = "1"b;		/* Mark channel inoperative. */
		     chantab.connect_time = clock ();	/* Record the time. */
		end;

		if disktab.channels_online > 1 then do;
		     call syserr (BEEP, "^a: Removing channel ^a.", ME, chantab.chanid);
		     chantab.in_use = "0"b;
		     disktab.channels_online = disktab.channels_online - 1;
		end;
		else do;
		     if bootload_sw then do;		/* for this type I/O, give up. */
			errflags.all_paths_bad = "1"b;
			post_sw = "1"b;
		     end;
		     else if io_type = TEST then do;
			call set_pvte_inop (ON);	/* effectively inop */
                              if (tc_data$system_shutdown ^= 0) then do;
                                  post_sw = "1"b;
                                  errflags.device_inoperative = "1"b;
                                  errflags.all_paths_bad = "1"b;
                                  return;
                              end;

		     end;
		     else if tc_data$system_shutdown ^= 0 then do;
			errflags.device_inoperative = "1"b;
						/* effectively inop */
			errflags.all_paths_bad = "1"b;
			post_sw = "1"b;
		     end;
		     else do;			/* Just keep trying. */
			chantab.erct = 0;
			chantab.inop = "0"b;
			call connect (addr (chantab.scdcw));
		     end;

/* Every polling time re-ready channel entries for another try.  This way we
   are not stuck with just the last channel. */

		     do i = 1 to disktab.nchan;
			lcp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (i));
			if ^(lcp -> chantab.ioi_use) then do;
						/* If channel really belongs to disk dim (not ioi or deleted) */
			     if (lcp -> chantab.connect_time + CHANNEL_POLLING_TIME < clock ())
				| post_sw /* time to give up */ then do;
						/* time to open up */

				lcp -> chantab.broken = "0"b;
						/* not broken */
				lcp -> chantab.inop = "0"b;
						/* operative */
				lcp -> chantab.erct = 0;
						/* no errors */
				lcp -> chantab.active = "0"b;
						/* not active */

				lcp -> chantab.in_use = "1"b;

/* can use */
				lcp -> chantab.connect_time = clock ();
				disktab.channels_online = disktab.channels_online + 1;

			     end;
			end;
		     end;
		     return;
		end;

		post_sw = "0"b;			/* Don't post this operation. */
		call add_wq;			/* Requeue the operation. */

/* We should like to call call_run here, but this is indefinitely recursive. */


		do i = 1 to disktab.nchan;		/* Iterate thru all channels. */
		     cp = addr (ptr (disksp, disktab.channels) -> disk_channel_table (i));
						/* Find an idle channel */
		     if chantab.in_use & ^chantab.active then do;
			call getwork;
			return;
		     end;
		end;
	     end;
	     else if disk_error_interp.bad_mem then do;	/* Too bad, core lost. */
		errflags.fatal_error = "1"b;
		errflags.memory_unusable = "1"b;
		post_sw = "1"b;
	     end;
	     else do;				/* Very random error. */
		errflags.fatal_error = "1"b;
		post_sw = "1"b;			/* Tell _s_o_m_ebody. */
	     end;

	     return;


	end handle_error;

     end check_stat;

/* GETWORK - Look for more work to keep channel busy. */

getwork:
     proc;

	if ^chantab.in_use then
	     return;				/* chnl ^in use. */

	if ^disktab.dev_busy & disktab.dev_queued = "0"b then
	     return;				/* no work to do */

/* Scan drives in sequence to determine one which needs service. */

	do dev_count = lbound (disktab.devtab, 1) to hbound (disktab.devtab, 1);
	     disktab.dev_index = disktab.dev_index + 1;	/* drive to check */
	     if disktab.dev_index > hbound (disktab.devtab, 1) then
		disktab.dev_index = lbound (disktab.devtab, 1);

	     dev = disktab.dev_index;
	     pdi = disktab.devtab (dev).pdi;

	     if ^disktab.dev_busy & dev_mask (pdi) then do;
						/* If primary device free */
		dp = addr (disktab.devtab (pdi));	/* Get pointer to primary device info table. */
		if ^devtab.broken			/* Device usable */
		     then
		     if devtab.wq.depth > 0		/* work to do */
		     then do;
			qp = ptr (disksp, devtab.wq.head);

/* If only one element in queue, then we are as optimal as you get. */
/* Stagnation control.  Head of queue is oldest request.  If it is older than
   disk_data.stagnate_time then we optimize with disk combing. */

			if devtab.wq.depth > 1 then
			     if quentry.time >= (clock () - disk_data.stagnate_time) then
				call find_shortest_seek;
			     else call comb;	/* stagnation */

			call del_q;		/* Remove from queue. */
			go to xfer_join;
		     end;
	     end;
	end;

	return;					/* Nothing to do, so just return. */

/* FIND_SHORTEST_SEEK - Procedure to Get Request Closest to Current Arm Position. */

find_shortest_seek:
	proc;

dcl	(
	best_seek,				/* best nearest seek */
	this_seek					/* seek distance for comparison */
	)		   float bin (27),
	(
	best_pos_comb,				/* best pos comb */
	best_neg_comb,				/* best neg comb */
	this_comb					/* seek distance for comparison */
	)		   fixed bin (35),
	best_qp		   ptr,			/* pointer to best request */
	best_neg_qp	   ptr,			/* best neg comb */
	type		   fixed bin;		/* type of this request */

	     cylinder = devtab.cylinder;
	     best_seek = 1.0e+30;			/* maximum */

/* Get type of queue entry to locate fraction and multipliers.  Determine
   Logical Seek Length for Nearest-Seek calculations. */

seek_loop:
	     type = quentry.type;
	     this_seek = float (abs (quentry.cylinder - cylinder) * devtab.opt_info (type).multiplier);
	     if this_seek = 0.0 then
		goto seek_on_cylinder;		/* ON-CYLINDER */

	     if this_seek < best_seek then do;		/* pick best */
		best_seek = this_seek;
		best_qp = qp;
	     end;

/* Step to next queue entry as we scan the queue. */

	     qrp = quentry.next;
	     if qrp = "0"b then
		goto seek_found;			/* we have best */

	     qp = ptr (disksp, qrp);			/* pointer to entry. */
	     goto seek_loop;


seek_found:
	     qp = best_qp;				/* pick up best .. */
seek_on_cylinder:					/* qp -> entry */
	     qrp = rel (qp);
	     return;

/* Combing optimization eliminates possible IO stagnation by moving the head
   in and out continuously in a combing motion. */

comb:
	entry;

	     devtab.comb = devtab.comb + 1;
	     cylinder = devtab.cylinder;
	     best_pos_comb = 34359738367;
	     best_neg_comb = -34359738367;

/* Attempt to maintain direction by appropriately setting comparison order
   between this cylinder and the current cylinder. */

comb_loop:
	     if devtab.forward then
		this_comb = quentry.cylinder - cylinder;
	     else this_comb = cylinder - quentry.cylinder;

	     if this_comb = 0 then			/* ON-CYLINDER */
		goto seek_on_cylinder;		/* Pick this one */
	     else if this_comb > 0			/* same direction */
	     then do;
		if this_comb < best_pos_comb then do;
		     best_pos_comb = this_comb;
		     best_qp = qp;
		end;
	     end;
	     else do;				/* reverse direction */
		if this_comb > best_neg_comb then do;
		     best_neg_comb = this_comb;
		     best_neg_qp = qp;
		end;
	     end;

	     qrp = quentry.next;
	     if qrp = "0"b then
		goto comb_found;			/* search complete */
	     qp = ptr (disksp, qrp);
	     goto comb_loop;


comb_found:
	     if best_pos_comb ^= 34359738367 then	/* if we found forward. */
		qp = best_qp;			/* pick up best .. */
	     else qp = best_neg_qp;
	     qrp = rel (qp);
	     return;
	end find_shortest_seek;

/* GOTWORK - Found queue entry.  Start the I/O. */

/* Presumes
   dp -> devtab(pdi)	Current devtab for this request's pdi.
   qp -> quentry		Quentry which has request to connect.
   cp -> chantab		Current channel table to connect request to.
*/

gotwork:
     entry;

xfer_join:
	if ^quentry.used then			/* This must never happen. */
	     call syserr (CRASH, "^a: Queuing error.", ME);

	chantab.qrp = rel (qp);			/* Save queue entry index for later. */
	chantab.erct = 0;				/* Clear the retry error count. */
	chantab.reconnect_announce_time = 0;		/* force first reconnect to be announced */

	dev = quentry.dev;				/* extract device */

	if quentry.type = TEST then do;
	     idcwp = addr (chantab.rssdcw);		/* Get pointer to RSS. */
	     idcw.command = substr (quentry.coreadd, 19, 6);
	     idcw.device = bit (dev);			/* Set device address. */

/* Count TEST or UNLOAD calls. */

	     optp = addr (disktab.devtab (dev).opt_info (quentry.type));
	     if bin (quentry.coreadd, 24) = 58 then
		opt_info.seek_sum = opt_info.seek_sum + 1;
						/* UNLOAD */
	     else opt_info.seek_count = opt_info.seek_count + 1;
						/* TEST */


	     call connect (idcwp);			/* Get device status. */
	end;

	else do;					/* Normal seek op - */
	     dcdcwp = addr (chantab.dcdcw);		/* Get pointer to data xfer IDCW. */
	     dddcwp = addr (chantab.dddcw);		/* Get pointer to data xfer DCW. */
	     idcwp = addr (chantab.scdcw);		/* Get pointer to SEEK or RSS IDCW. */

	     idcw.device = bit (dev);			/* Set device address */

	     unspec (dcdcwp -> idcw) = "0"b;		/* clear idcw */
	     dcdcwp -> idcw.code = IDCW;
	     dcdcwp -> idcw.ext_ctl = "1"b;
	     if write_map (quentry.type) then		/* set data transfer direction */
		dcdcwp -> idcw.command = WRITE;
	     else dcdcwp -> idcw.command = READ;

	     dcdcwp -> idcw.ext = substr (quentry.coreadd, 1, length (idcw.ext));
						/* Set address extension in IDCW. */
	     dddcwp -> dcw.address = substr (quentry.coreadd, 7);
						/* Set DCW address. */
	     dcdcwp -> idcw.device = bit (dev);		/* Set up device address */
						/* idcw.chan_cmd = "00"b3 is ok, = data xfer */


	     chantab.select_data.sector = quentry.sector; /* set disk sector address */
						/* At this point the check is made for the type of seek (512 or 64) */
	     if idcw.command = seek_512 then do;	/* sector size is 512 */
		if quentry.type = VTOC_READ | quentry.type = VTOC_WRITE then do;
		     dddcwp -> dcw.tally = bit (bin (192, 12));
		     chantab.select_data.limit = bit (bin (1, 12));
		end;
		else if quentry.type = PAGE_READ | quentry.type = PAGE_WRITE then do;
		     dddcwp -> dcw.tally = bit (bin (1024, 12));
		     chantab.select_data.limit = bit (bin (2, 12));
		end;
		else if sector_map (quentry.type) then do;
		     dddcwp -> dcw.tally = bit (bin ((512 * quentry.n_sectors), 12));
		     chantab.select_data.limit = bit (bin (quentry.n_sectors, 12));
		end;
	     end;
	     else do;				/* sector size must be 64 */
		if sector_map (quentry.type) then do;	/* If 64-word I/O ... */
		     dddcwp -> dcw.tally = bit (bin (64 * quentry.n_sectors, 12));
						/* Set DCW tally. */
		     chantab.select_data.limit = bit (bin (quentry.n_sectors, 12));
						/* Set sector count limit. */
		end;
		else do;				/* If 1024-word I/O ... */
		     dddcwp -> dcw.tally = bit (bin (1024, 12));
						/* Set DCW tally. */
		     chantab.select_data.limit = bit (bin (16, 12));
						/* Set sector count limit. */
		end;
	     end;

	     call connect (addr (chantab.scdcw));	/* Start up the channel. */

/* find opt_info */

	     optp = addr (disktab.devtab (dev).opt_info (quentry.type));
	     cylinder = devtab.cylinder - quentry.cylinder;
	     devtab.cylinder = quentry.cylinder;

/* Determine direction of seek.  If going low cylinder to high, then
   devtab.forward is set true, if going  high to low it is set false.  If
   we stay on-cylinder, then we leave the direction as what it was. */
/* We use this information to maintain combing. */

	     if cylinder > 0			/* Backward comb */
		then
		devtab.forward = "0"b;
	     else if cylinder < 0			/* Forward comb */
		then
		devtab.forward = "1"b;

	     opt_info.seek_sum = opt_info.seek_sum + abs (cylinder);
	     opt_info.seek_count = opt_info.seek_count + 1;
	end;
     end getwork;

/* CONNECT - Start Up the Channel. */

connect:
     procedure (listp);

dcl	listp		   ptr parameter;
dcl	1 ima		   aligned like io_manager_arg;

	ima.chx = chantab.chx;
	ima.pcw = ""b;
	ima.ptp = null ();
	ima.listp = listp;
	call io_manager$connect_abs (ima);		/* Fire up the channel. */
						/* Fire up the channel. */
	chantab.connects = chantab.connects + 1;	/* Keep count of number of connects */
	chantab.active = "1"b;			/* Indicate channel now active */
	chantab.connect_time = clock ();		/* set time of connect */

	disktab.dev_busy = disktab.dev_busy | dev_mask (pdi);
						/* Indicate primary device now busy. */

	return;


     end connect;



/* POST - Notify system of completed operation. */

post:
     proc;

	if /* case */ io_type = TEST then do;

/*  test results have been indicated by this time. */
	     post_sw = "0"b;
	     return;
	end;


	if sect_sw then				/* If 64-word I/O ... */
	     if bootload_sw then
		call bootload_disk_post (coreadd, errcd);
	     else call vtoc_interrupt (coreadd, errcd);
	else					/* If page I/O ... */
	     call page$done (coreadd, errcd);

	post_sw = "0"b;				/* Clear switch to prevent double posting. */

	return;


     end post;

/* queue_length_given_pvtx - that says it all */

queue_length_given_pvtx:
     entry (a_pvtx, a_queue_length);

	pvtep = addr (addr (pvt$array) -> pvt_array (a_pvtx));
						/* PVTE for this device */
	pvtdip = addr (pvte.dim_info);		/* Get pointer to DIM info */
	sx = pvtdi.sx;				/* Extract index for this disk subsystem */

	call setup;				/* Get pointers to databases */

	dev = pvte.logical_area_number;		/* Device number */
	pdi = disktab.devtab (dev).pdi;		/* Primary device number */
	dp = addr (disktab.devtab (pdi));		/* Get pointer to info for primary device */

	a_queue_length = devtab.wq.depth;		/* current amount queued */

	return;

/* TUNING control.  Externally accessible entry with which to setup tuning
   parameters in disk_seg.  It ensures valid parameters. */

tune:
     entry (a_op, a_ptr, reason, ec);

dcl	a_op		   char (*);		/* type of tuning */
dcl	a_ptr		   ptr;			/* pointer to structure */
dcl	reason		   char (*) varying;	/* textual description of error */
dcl	ec		   fixed bin (35);

dcl	stagnate_time	   fixed bin (35) based (cptr);
						/* for setting time */
dcl	response		   fixed bin (35);
dcl	load		   fixed bin;
dcl	cptr		   ptr;
dcl	op		   char (16);

%include disk_tune;
%page;
	disksp = addr (disk_seg$);
	cptr = a_ptr;
	op = a_op;

	if op = STAGNATE_TIME then do;		/* limit 6 min. */
	     if stagnate_time > 360000000 | stagnate_time < 0 then do;
		if stagnate_time < 0 then
		     reason = "stagnate time must be >= 0";
		else reason = "stagname time must be <= 6 minutes";
		ec = error_table_$bad_arg;
		return;
	     end;
	     else disk_data.stagnate_time = a_ptr -> stagnate_time;
	end;
	else if op = SYS_TUNE then do;
	     io_type = cptr -> sys_info_tune.type;
	     if io_type < 0 | io_type > MAX_IO_TYPE then
		goto bad_io_type;

	     sysp = addr (disk_data.sys_info (io_type));

	     if cptr -> sys_info_tune.map > MAX_IO_TYPE then
		goto bad_map_type;

/* if map is positive, then we update counter mapping. */

	     if cptr -> sys_info_tune.map >= 0 then
		sys_info.depth_map = rel (addr (disk_data.sys_info (cptr -> sys_info_tune.map)));

/* if max_depth is > 1 then we update it.  If 0 we would divide by 0. */

	     if cptr -> sys_info_tune.max_depth > 0 then
		sys_info.max_depth = float (cptr -> sys_info_tune.max_depth);
	end;
	else if op = OPT_TUNE then do;
	     io_type = cptr -> opt_info_tune.type;
	     if io_type < 0 | io_type > MAX_IO_TYPE then
		goto bad_io_type;

	     do sx = 1 to disk_data.subsystems;
		if cptr -> opt_info_tune.sub_sys = disk_data.array (sx).name then
		     goto tune_sub_sys;
	     end;
	     goto bad_io_sub_sys;

tune_sub_sys:
	     call setup;				/* locate disktab */
	     dev = cptr -> opt_info_tune.dev;
	     if dev < lbound (disktab.devtab, 1) | dev > hbound (disktab.devtab, 1) then
		goto bad_io_dev;

	     pdi = disktab.devtab (dev).pdi;		/* only tune pdi */
	     if pdi ^= dev then
		goto bad_io_dev;

	     response = cptr -> opt_info_tune.response;
	     if response < 1 then
		goto response_range;
	     load = cptr -> opt_info_tune.load;

	     optp = addr (disktab.devtab (pdi).opt_info (io_type));
	     if load > 1 then do;
		opt_info.slope = float (response - 1) / float (load - 1);
		opt_info.intercept = float ((response * load) - 1) / float (load - 1);
	     end;
	     else do;
		opt_info.slope = 0.0;
		opt_info.intercept = float (response);
	     end;
	end;
	else if op = RESET_SYS then do;
	     do i = 0 to MAX_IO_TYPE;			/* sys_info.depth's */
		disk_data.sys_info (i).depth = 0;
	     end;
	end;
	else if op = RESET_MAX then do;
	     disk_data.max_depth_reset_time = clock ();
	     disk_data.free_q.max_depth = 0;
	     do i = 1 to disk_data.subsystems;		/* each sub-sys */
		diskp = ptr (disksp, disk_data.array (i).offset);
		disktab.wq.max_depth = 0;
	     end;
	end;
	reason = "";
	ec = 0;
	return;

bad_io_type:
	reason = "invalid I/O type";
	ec = error_table_$bad_arg;
	return;

bad_map_type:
	reason = "invalid map I/O type";
	ec = error_table_$bad_arg;
	return;

bad_io_sub_sys:
	reason = "unknown subsystem";
	ec = error_table_$bad_arg;
	return;

bad_io_dev:
	reason = "invalid device number";
	ec = error_table_$bad_arg;
	return;

response_range:
	reason = "response value must be >= 1";
	ec = error_table_$bad_arg;
	return;

/* SETUP - Internal Procedure to set data base pointers. */

setup:
     proc;


	disksp = addr (disk_seg$);			/* Get a pointer to disk data segment. */
	pvt_arrayp = addr (pvt$array);		/* Get a pointer to the PVT array. */
	diskp = ptr (disksp, disk_data.offset (sx));	/* Get pointer to info for this subsystem. */

	return;


     end setup;



/* DISK_NAME - Internal Procedure to generate name of disk drive. */

disk_name:
     proc (both) returns (char (21) aligned);

dcl	both		   bit (1) aligned;
dcl	pic99		   pic "99";
dcl	this_name		   char (8);
dcl	other_name	   char (12);
dcl	other_dev		   fixed bin;


	if dev = pdi				/* If this is the priamry, we must rely on buddy */
	     then
	     other_dev = disktab.devtab (pdi).buddy;
	else other_dev = pdi;

	this_name = disk_data.name (sx) || "_" || convert (pic99, dev);
	if other_dev = 0 then
	     other_name = "";
	else other_name = " and " || disk_data.name (sx) || "_" || convert (pic99, other_dev);

	if both					/* return both device names, if appropriate */
	     then
	     return (this_name || other_name);
	else return (this_name);


     end disk_name;


/* LOCK/UNLOCK - Internal Procedures to Lock & Unlock Disk Database. */

lock:
     proc (lmp);

dcl	1 dlm		   like disk_lock_meters based (lmp) aligned,
						/* database lock meters */
	lmp		   ptr;


	dlm.count = dlm.count + 1;			/* Count locking attempt. */
	if ^stacq (disktab.lock, pds$processid, UNLOCK) then do;
						/* Attempt to lock database. */
	     call lock_meter_start (lmp);
	     do while (^stacq (disktab.lock, pds$processid, UNLOCK));
	     end;					/* Lock the disk data base. */
	     call lock_meter_stop (lmp);
	end;

	return;


unlock:
     entry;

	if ^stacq (disktab.lock, UNLOCK, disktab.lock) then
	     ;					/* Unlock the data base. */

	return;


     end lock;



/* LOCK_METER_START / LOCK_METER_STOP - Metering Procedures. */

lock_meter_start:
     proc (lmp);

dcl	1 dlm		   like disk_lock_meters based (lmp) aligned,
	lmp		   ptr;


	meter_start_time = clock ();			/* Get time now. */
	dlm.waits = dlm.waits + 1;			/* Count a wait. */

	return;


lock_meter_stop:
     entry (lmp);

	dlm.wait_time = dlm.wait_time + (clock () - meter_start_time);
						/* Meter time spent waiting. */
	return;


     end lock_meter_start;

/* GET_FREE_Q - Get a Queue Entry from the Free List. */

get_free_q:
     proc returns (bit (1) aligned);

dcl	type		   fixed bin;

/* SPIN-LOCK til queue available. */

	do while (^stacq (disk_data.lock, pds$processid, UNLOCK));
	end;

	qrp = disk_data.free_q.head;			/* Get rel ptr to head of free queue. */
	if qrp then do;				/* queue ^empty */
	     qp = ptr (disksp, qrp);			/* entry pointer */
	     disk_data.free_q.head = quentry.next;	/* new Q head */

/* if queue is now empty ground the tail, else ground our next's previous */

	     if disk_data.free_q.head = "0"b then
		disk_data.free_q.tail = "0"b;
	     else ptr (disksp, quentry.next) -> quentry.prev = "0"b;

/* Compile queue statistics.  Depth is really depth assigned from free_q. */

	     disk_data.free_q.sum = disk_data.free_q.sum + disk_data.free_q.depth;
	     disk_data.free_q.depth = disk_data.free_q.depth + 1;
	     if disk_data.free_q.depth > disk_data.free_q.max_depth then
		disk_data.free_q.max_depth = disk_data.free_q.depth;
	     disk_data.free_q.count = disk_data.free_q.count + 1;

	     if ^stacq (disk_data.lock, UNLOCK, disk_data.lock) then
		;				/* Unlock the database */
	     return (SUCCESS);
	end;
	else do;					/* If queue is empty ... */
	     if ^stacq (disk_data.lock, UNLOCK, disk_data.lock) then
		;				/* Unlock the database */
	     return (FAILURE);
	end;

/* ADD_FREE_Q - Add Entry to End of Free Queue. */

add_free_q:
     entry;

	quentry.used = "0"b;			/* Queue entry is no longer in use. */

/* SPIN-LOCK til queue is available to add free entry to it. */

	do while (^stacq (disk_data.lock, pds$processid, UNLOCK));
	end;					/* lock database */

/* If queue is ^empty, then add to tail, else create head and tail to element. */

	if disk_data.free_q.tail ^= "0"b then
	     ptr (disksp, disk_data.free_q.tail) -> quentry.next = qrp;
	else disk_data.free_q.head = qrp;

	quentry.prev = disk_data.free_q.tail;		/* link to prev */
	disk_data.free_q.tail = qrp;			/* New tail */
	quentry.next = "0"b;			/* clear next ptr. */

/* Indicate element returned from system. */

	disk_data.free_q.depth = disk_data.free_q.depth - 1;

	if ^stacq (disk_data.lock, UNLOCK, disk_data.lock) then
	     ;					/* Unlock the database */
	return;

/* ADD_WQ - Add Entry to End of Work Queue. */

add_wq:
     entry;

/* Indicate requests queued for device. */
/* If queue is not empty, then add to tail, else create queue. */

	disktab.dev_queued = disktab.dev_queued | dev_mask (pdi);
	if devtab.wq.tail ^= "0"b then
	     ptr (disksp, devtab.wq.tail) -> quentry.next = qrp;
	else devtab.wq.head = qrp;

	quentry.prev = devtab.wq.tail;
	quentry.next = "0"b;
	devtab.wq.tail = qrp;

/* Compile queue statistics. */

	devtab.wq.sum = devtab.wq.sum + devtab.wq.depth;
	devtab.wq.depth = devtab.wq.depth + 1;
	if devtab.wq.depth > devtab.wq.max_depth then
	     devtab.wq.max_depth = devtab.wq.depth;
	devtab.wq.count = devtab.wq.count + 1;

/* Compile system loading statistics.
   Find map of counter to be used. */

	type = quentry.type;
	sysp = addr (disk_data.sys_info (type));
	do while (^stacq (disk_data.lock, pds$processid, UNLOCK));
	end;
	ptr (disksp, sys_info.depth_map) -> sys_info.depth = ptr (disksp, sys_info.depth_map) -> sys_info.depth + 1.0;
	optp = addr (devtab.opt_info (type));
	opt_info.depth = opt_info.depth + 1;

/* Common processing for system IO loading and drive IO loading. */

wq_common:
	sys_info.fraction =
	     (sys_info.max_depth - ptr (disksp, sys_info.depth_map) -> sys_info.depth) / sys_info.max_depth;
	if sys_info.fraction < 0.0 then
	     sys_info.fraction = 0.0;
	if ^stacq (disk_data.lock, UNLOCK, disk_data.lock) then
	     ;					/* Unlock disk_data. */

/* Compile drive load multiplier for this IO type.  The multiplier cannot drop
   below 1.0 to give a true PHYSICAL=LOGICAL mapping.  */

	opt_info.multiplier = (opt_info.intercept - float (opt_info.depth) * opt_info.slope) * sys_info.fraction;
	if opt_info.multiplier < 1.0 then
	     opt_info.multiplier = 1.0;		/* LIMIT to 1.0 */
	return;

/* DEL_Q - Delete Item from Queue. */

del_q:
     entry;

/* Remove item from queue, fixing previous and next entries, or head or tail */

	if quentry.prev = "0"b then			/* head is prev */
	     devtab.wq.head = quentry.next;
	else ptr (disksp, quentry.prev) -> quentry.next = quentry.next;

	if quentry.next = "0"b then			/* tail is next */
	     devtab.wq.tail = quentry.prev;
	else ptr (disksp, quentry.next) -> quentry.prev = quentry.prev;

/* Fix queue statistics.  If queue is empty, indicate this for fast check. */

	devtab.wq.depth = devtab.wq.depth - 1;
	if devtab.wq.depth <= 0 then
	     disktab.dev_queued = disktab.dev_queued & ^dev_mask (pdi);

/* Do load statistics, use map of depth accumulator. */

	type = quentry.type;
	sysp = addr (disk_data.sys_info (type));
	do while (^stacq (disk_data.lock, pds$processid, UNLOCK));
	end;					/* lock disk_data */

/* prevent possible -ve depth if map is changed on the fly. */

	ptr (disksp, sys_info.depth_map) -> sys_info.depth =
	     max (0.0, ptr (disksp, sys_info.depth_map) -> sys_info.depth - 1.0);

	optp = addr (devtab.opt_info (type));
	opt_info.depth = opt_info.depth - 1;
	go to wq_common;				/* will unlock disk_data */

     end get_free_q;

/* set_pvte_inop ...  Internal procedure to deal with pvte.inoperative, notifying
   the global disk offline event as necessary.  */

set_pvte_inop:
     proc (setting);

dcl	setting		   bit (1) aligned;


/* pvtep is set */

	call set (addr (addr (pvt$array) -> pvt_array (devtab.pvtx)));
						/* Set the first one (^)inop */
	if devtab.buddy ^= 0			/* Must also do it to the buddy */
	     then
	     call set (addr (addr (pvt$array) -> pvt_array (disktab.devtab (devtab.buddy).pvtx)));

set:
	proc (pvte_ptr);

dcl	pvte_ptr		   ptr;


	     if pvte_ptr -> pvte.device_inoperative & ^setting then do;
		pvte_ptr -> pvte.device_inoperative = "0"b;
		call pxss$notify (page_fault$disk_offline_event);
	     end;
	     else pvte_ptr -> pvte.device_inoperative = setting;

	     return;


	end set;

     end set_pvte_inop;

%include device_error;
%page;
%include disk_error_interp;
%page;
%include dskdcl;
%page;
%include fs_dev_types;
%page;
%include io_manager_dcls;
%page;
%include io_special_status;
%page;
%include io_status_entry;
%page;
%include io_syserr_msg;
%page;
%include iom_dcw;
%page;
%include iom_pcw;
%page;
%include pvte;
%page;
%include syserr_binary_def;
%page;
%include syserr_constants;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   disk_control: Adding channel ICC.

   S:	$info

   T:	$run

   M:	A message to confirm that channel ICC has been added to the system
   in response to a reconfigure command.

   A:	$ignore

   Message:
   disk_control: Reconnected IO_TYPE I/O on dskX_NN (channel ICC).

   S:	$info and/or $log

   T:	$run

   M:	A disk interrupt was apparently lost.
   Status for the disk did not arrive within the expected time.
   This may be an indication of a channel or controller malfunction.
   The system restarts the disk operation.

   A:	$ignore Unless these messages persist, which may indicate
   a hardware malfunction that needs investigation.  Some types of
   channel adapters and/or disk controllers can be "reset" in an attempt
   to correct the condition.

   Message:
   disk_control: Placing dskX_NN in operation.

   S:	$info

   T:	$run

   M:	A special interrupt has been received for a disk drive marked as
   broken. The system will attempt to use the device.

   A:	$ignore

   Message:
   disk_control: Unexpected IOM status SSSS for dskX_NN (channel ICC).

   S:	$info

   T:	$run

   M:	Status has been received from a channel which was not marked active.
   This is due to a disk subsystem or IOM problem,
   or to a logic error in the supervisor.
   See manual AN87, System Formats, for an interpretation
   of the status SSSS.
   The system ignores the status and attempts to continue operation.

   A:	$ignore

   Message:
   disk_control: dskX_NN now operational.

   S:	$info

   T:	$run

   M:	A disk drive which required intervention has successfully completed
   an I/O operation. The system will again use its contents.

   A:	$ignore

   Message:
   disk_control: MAJOR_STAT SUBSTAT for dskX_NN (channel ICC).
   .br
   rec RRRR, sect SSSS, main AAAA
   .br
   detailed status: XX XX XX XX XX XX XX XX

   S:	$info

   T:	$run

   M:	A disk error has occurred on drive dskX_NN.
   The major status and substatus are interpreted as character strings.
   The disk address is given both as a Multics record address in octal,
   and as an absolute sector number in octal.
   The main store address being used was AAAA octal.
   The third line gives the hexadecimal value of the detailed status
   in cases where this data is useful.
   See manual AN87, System Formats, for interpretation of this information.

   A:	Note for Customer Service action.
   The segment involved in a disk error can often be identified by
   an application of the "record_to_vtocx" tool to the Multics
   record number given in the message.

   Message:
   disk_control: MAJOR_STAT SUBSTAT for dskX_NN (channel ICC).
   .br
   rec RRRR, sect SSSS, main AAAA
   .br
   subvol V, logical rec OOOO, logical sect TTTT
   .br
   detailed status: XX XX XX XX XX XX XX XX

   S:	$info

   T:	$run

   M:	A disk error has occurred on drive dskX_NN.
   The major status and substatus are interpreted as character strings.
   The disk address is given both as a Multics record address in octal,
   and as an absolute sector number in octal.
   The main store address being used was AAAA octal.
   The subvolume name is V (the logical device name is dskX_NNV),
   the logical record address is OOOO octal
   and the logical sector number is TTTT octal.
   The fourth line gives the hexadecimal value of the detailed status
   in cases where this data is useful.
   See manual AN87, System Formats, for interpretation of this information.

   A:	Note for Customer Service action.
   The segment involved in a disk error can often be identified by
   an application of the "record_to_vtocx" tool to the Multics
   logical record number given in the message.

   Message:
   disk_control: dskX_NN requires intervention.

   S:	$beep

   T:	$run

   M:	A disk error has occurred which
   could have been caused by the pack or drive being broken
   or requiring operator attention.
   The system has retried the operation an appropriate number of times
   without success.
   The system will try the device
   periodically to check if it has been repaired.

   A:	Inspect the device.
   If it is not ready, ready it.
   If it is ready, try unreadying and re-readying it.
   If the drive cannot be made ready, contact Customer Service personnel.

   Message:
   disk_control: Removing channel ICC.

   S:	$beep

   T:	$run

   M:	Errors occurred indicative of a defective disk channel or MPC.
   The channel receiving the errors is placed offline.

   A:	$inform
   Also inform Customer Service personnel.

   Message:
   disk_control: Queuing error.

   S:	$crash

   T:	$run

   M:	$err

   A:	$recover

   END MESSAGE DOCUMENTATION */

     end disk_control;




		    disk_error_data.cds             10/01/90  1629.4rew 10/01/90  1627.6      170325



/* ***********************************************************
   *                                                         *
   * Copyright, (C) BULL HN Information Systems Inc., 1989   *
   *                                                         *
   * Copyright, (C) Honeywell Bull Inc., 1987                *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   * Copyright (c) 1972 by Massachusetts Institute of        *
   * Technology and Honeywell Information Systems, Inc.      *
   *                                                         *
   *********************************************************** */


/* HISTORY COMMENTS:
  1) change(87-05-27,Fawcett), approve(87-05-27,MCR7704),
     audit(87-07-08,Farley), install(87-07-17,MR12.1-1043):
     Change the wording for the major status number 19. This is not a real
     major status but rather the entry uesd for I/O system faults. The old
     wording was just system fault.
  2) change(88-02-23,Farley), approve(88-02-23,MCR7793),
     audit(88-02-24,Fawcett), install(88-03-01,MR12.2-1029):
     Removed "rsr" from the "power off" major status. If the path is bad
     attempting to do a RSR will only complicate things..
  3) change(89-06-23,Farley), approve(89-07-26,MCR8122),
     audit(89-09-11,WAAnderson), install(89-09-22,MR12.3-1072):
     Added functionality to seperate some of the FIPS status interpretations,
     while still keeping the space required to a minimum.
  4) change(90-06-27,WAAnderson), approve(90-08-28,MCR8188),
     audit(90-09-21,Schroth), install(90-10-01,MR12.4-1035):
     Added substat 'count field uncorrectable'.
                                                   END HISTORY COMMENTS */


/* DISK_ERROR_DATA - This is the Database for Interpreting Disk Error Status.
	created 5/19/76 by Noel I. Morris	

   Last Modified:

   November 1982, J. Bongiovanni, to fix bug in dev busy, alt channel in control
*/


disk_error_data: proc;

dcl 1 cdsa like cds_args aligned auto;
dcl  xnames (1) char (32) aligned auto init ("*");

dcl 1 data based (tempp (1)) aligned,
    2 maj_array (0: 23) like disk_error_data,
    2 sub_array (nsub) like disk_error_interp;

dcl  nsub fixed bin,				/* number of substatuses */
     charwds fixed bin,				/* number of words of characters allocated */
     tempp (2) ptr,					/* temp segs pointers */
     i fixed bin,					/* iteration variable */
     rcode fixed bin (35),				/* error code */
     nulldescriprel bit (18) aligned,			/* rel ptr to null char string */
     deirel bit (18) aligned,				/* rel pointer to interpretation data */
     dsdrel bit (18) aligned;				/* rel pointer to charactr string */

dcl  get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)),
     release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)),
     create_data_segment_ entry (ptr, fixed bin (35)),
     com_err_ entry options (variable);

dcl  copy_chars (charwds) fixed bin (35) based;		/* structure for copying characters */

dcl (NRETRIES init (5),
     NONE init (0),
     ONCE init (1)) fixed bin (5) static options (constant);

dcl (addr, addrel, bin, bit, divide, hbound, index, length, rel, size, translate, string, unspec) builtin;



% include disk_error_interp;



% include cds_args;



	call get_temp_segments_ ("disk_error_data", tempp, rcode);
	if rcode ^= 0 then
	     call com_err_ (rcode, "disk_error_data", "get_temp_segments_");

	dedp = tempp (1);
	dsdp = tempp (2);

	nsub = 1;
	dskerp = addr (data.sub_array (1));
	charwds = 0;

	nulldescriprel = allocate_dsd ("");
	deirel = compute_rel (dedp, dskerp);
	dsdrel = allocate_dsd ("error");
	do i = 0 to hbound (data.maj_array, 1);
	     data.maj_array (i).interp = deirel;
	     data.maj_array (i).namep = dsdrel;
	     data.maj_array (i).finterp = deirel;
	     data.maj_array (i).fnamep = dsdrel;
	end;
	call set_substat ("XXXXXX", NONE, "", "");



	call set_majstat (1, "dev busy");
	call set_fmajstat (1, "dev busy");
	call set_substat ("000000", NRETRIES, "dev positioning",                "reseek");
	call set_substat ("100000", NRETRIES, "alt chan in control",            "bad_dev,reseek,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "reseek,rsr");

	call set_majstat (2, "dev attention");
	call set_fmajstat (2, "dev attention");
	call set_substat ("0000X1",     NONE, "write inhib",                    "bad_dev");
	call set_substat ("00001X", NRETRIES, "seek incomplete",                "bad_dev,reseek,rsr");
	call set_substat ("001000",     NONE, "dev inop",                       "bad_dev,reseek,rsr");
	call set_substat ("010000",     NONE, "dev in standby",                 "bad_dev,rsr");
	call set_substat ("100000",     NONE, "dev offline",                    "bad_dev");
	call set_substat ("XXXXXX",     ONCE, "",                               "reseek,rsr");

	call set_majstat (3, "dev data alert");
	call set_fmajstat (3, "dev data alert");
	call set_substat ("000001", NRETRIES, "xfer timing alert",              "bad_path");
	call set_substat ("000010", NRETRIES, "xmission parity alert",          "bad_path");
	call set_substat ("000100", NRETRIES, "invalid seek addr",              "bad_addr,reseek,rsr");
	call set_substat ("0X1000", NRETRIES, "hdr ver failure",                "bad_addr,reseek,rsr");
	call set_substat ("X1X000", NRETRIES, "check char alert",               "bad_addr,reseek,rsr");
	call set_substat ("1X0000", NRETRIES, "compare alert",                  "bad_addr,reseek,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "reseek,rsr");

	call set_majstat (4, "end of file");
	call set_fmajstat (4, "end of file");
	call set_substat ("000000",     ONCE, "good track",                     "bad_addr,reseek,rsr");
	call set_substat ("0000X1",     ONCE, "last consec block",              "bad_addr,reseek,rsr");
	call set_substat ("00001X",     ONCE, "sect limit exceeded",            "bad_path,reseek,rsr");
	call set_substat ("000100",     ONCE, "defect trk, alt assnd",          "bad_addr,reseek,rsr");
	call set_substat ("001000",     ONCE, "defect trk, no alt",             "bad_addr,reseek,rsr");
	call set_substat ("010000",     ONCE, "alt trk detected",               "bad_addr,reseek,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "reseek,rsr");

	call set_majstat (5, "cmd reject");
	call set_substat ("000XX1",     ONCE, "invalid op code",                "bad_path,rsr");
	call set_substat ("000010",     ONCE, "invalid dev code",               "bad_path,rsr");
	call set_substat ("000100", NRETRIES, "invalid IDCW parity",            "bad_path,rsr");
	call set_substat ("001000",     ONCE, "invalid instruction seq",        "bad_path,reseek,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "reseek,rsr");

	call set_fmajstat (5, "cmd reject");
	call set_substat ("000XX1",     ONCE, "invalid op code",                "bad_path,rsr");
	call set_substat ("000010",     ONCE, "invalid dev code",               "bad_path,rsr");
	call set_substat ("001000",     ONCE, "invalid instruction seq",        "bad_path,reseek,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "reseek,rsr");

	call set_majstat (8, "channel busy");
	call set_fmajstat (8, "channel busy");
	call set_substat ("XXXXXX",     ONCE, "",                               "bad_path,rsr");

	call set_majstat (10, "MPC attention");
	call set_substat ("000001",     NONE, "config switch err",              "bad_path,rsr");
	call set_substat ("000010",     NONE, "multiple devs",                  "bad_path,rsr");
	call set_substat ("000011",     NONE, "illeg dev no",                   "bad_path,rsr");
	call set_substat ("001011",     NONE, "CA err or OPI down",             "bad_path,rsr");
	call set_substat ("001100",     ONCE, "unexpected EN1",                 "bad_dev,reseek,rsr");
	call set_substat ("001101",     ONCE, "CA EN1 err",                     "bad_dev,reseek,rsr");
	call set_substat ("001110",     ONCE, "no EN1",                         "bad_dev,reseek,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "bad_path,rsr");

	call set_fmajstat (10, "IPC-FIPS device attention");
	call set_substat ("000010",     NONE, "multiple devs",                  "bad_path,rsr");
	call set_substat ("000011",     NONE, "illeg dev no",                   "bad_path,rsr");
	call set_substat ("001011",     ONCE, "usage/error stat overflow",      "just_log,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "bad_path,rsr");

	call set_majstat (11, "MPC data alert");
	call set_substat ("000001", NRETRIES, "xmission parity alert",          "bad_path,rsr");
	call set_substat ("000010",     ONCE, "inconsistent command",           "bad_path,rsr");
	call set_substat ("000011",     ONCE, "sum check err",                  "bad_path,rsr");
	call set_substat ("000100",     ONCE, "byte locked out",                "bad_path,rsr");
          call set_substat ("001010", NRETRIES, "count field uncorrectable",      "bad_addr,rsr");
	call set_substat ("001110", NRETRIES, "EDAC parity err",                "bad_addr,rsr");
	call set_substat ("010001", NRETRIES, "sect size err",                  "bad_addr,rsr");
	call set_substat ("010010", NRETRIES, "nonstandard sect size",          "bad_addr,rsr");
	call set_substat ("010011", NRETRIES, "search alert (first)",           "bad_addr,rsr");
	call set_substat ("010100", NRETRIES, "cyclic code err",                "bad_addr,rsr");
	call set_substat ("010101", NRETRIES, "search err (not first)",         "bad_addr,rsr");
	call set_substat ("010110", NRETRIES, "sync byte not HEX 19",           "bad_addr,rsr");
	call set_substat ("010111", NRETRIES, "auto alt trk err",               "bad_addr,rsr");
	call set_substat ("011001", NRETRIES, "EDAC, last sect",                "bad_addr,rsr");
	call set_substat ("011010", NRETRIES, "EDAC, not last sect",            "bad_addr,rsr");
	call set_substat ("011011", NRETRIES, "EDAC, block count limit",        "bad_addr,rsr");
	call set_substat ("011100", NRETRIES, "uncorrectable err",              "bad_addr,rsr");
	call set_substat ("011101", NRETRIES, "EDAC, short block",              "bad_addr,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "bad_path,rsr");

	call set_fmajstat (11, "IPC-FIPS device data alert");
	call set_substat ("010001", NRETRIES, "sect size err",                  "bad_addr,rsr");
	call set_substat ("010010", NRETRIES, "nonstandard sect size",          "bad_addr,rsr");
	call set_substat ("010011", NRETRIES, "search alert (first)",           "bad_addr,rsr");
	call set_substat ("010100", NRETRIES, "cyclic code err",                "bad_addr,rsr");
	call set_substat ("010101", NRETRIES, "search err (not first)",         "bad_addr,rsr");
	call set_substat ("010111", NRETRIES, "auto alt trk err",               "bad_addr,rsr");
	call set_substat ("100001", NRETRIES, "write buffer parity err",        "bad_path,rsr");
	call set_substat ("100010", NRETRIES, "uncorrectable read substatus",   "bad_path,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "bad_path,rsr");

	call set_majstat (13, "MPC cmd reject");
	call set_substat ("000001",     NONE, "illeg procedure",                "bad_path,rsr");
	call set_substat ("000010",     NONE, "illeg log chan",                 "bad_path,rsr");
	call set_substat ("000011",     NONE, "illeg susp log chan",            "bad_path,rsr");
	call set_substat ("000100",     NONE, "continue bit not set",           "bad_path,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "bad_path,rsr");

	call set_fmajstat (13, "IPC-FIPS cmd reject");
	call set_substat ("000001",     NONE, "invalid operation code",         "bad_path,rsr");
	call set_substat ("XXXXXX",     ONCE, "",                               "bad_path,rsr");

	call set_majstat (16, "power off");
	call set_fmajstat (16, "power off");
	call set_substat ("XXXXXX", NRETRIES, "",                               "bad_path");

	call set_majstat (17, "chan stat");
	call set_fmajstat (17, "chan stat");
	call set_substat ("001000",     ONCE, "connect while busy",             "");
	call set_substat ("010000",     ONCE, "illeg chan instruct",            "");
	call set_substat ("011000",     ONCE, "incorrect DCW",                  "");
	call set_substat ("100000",     ONCE, "incomplete instruct seq",        "bad_path");
	call set_substat ("110000", NRETRIES, "PSI parity err",                 "bad_path");
	call set_substat ("111000", NRETRIES, "parity err, I/O bus to chan",    "bad_path");
	call set_substat ("XXXXXX", NRETRIES, "",                               "bad_path,rsr");

	call set_majstat (18, "central stat");
	call set_fmajstat (18, "central stat");
	call set_substat ("111000",     ONCE, "parity err, I/O bus from chan",  "bad_path");
	call set_substat ("XXXXXX", NRETRIES, "",                               "bad_path,rsr");

	call set_majstat (19, "I/O system fault");
	call set_fmajstat (19, "I/O system fault");
	call set_substat ("XXXXXX",     ONCE, "",			  "bad_path");

	call set_majstat (20, "nonzero tally residue");
	call set_fmajstat (20, "nonzero tally residue");
	call set_substat ("XXXXXX",     ONCE, "",			  "bad_dev");

	call set_majstat (21, "Auto retries");
	call set_fmajstat (21, "Auto retries");
	call set_substat ("XXXXXX",     ONCE, "",			  "just_log");

	call set_majstat (22, "EDAC performed");
	call set_fmajstat (22, "EDAC performed");
	call set_substat ("XXXXXX",     ONCE, "",			  "just_log");

	call set_majstat (23, "Data parity");
	call set_fmajstat (23, "Data parity");
	call set_substat ("XXXXXX",     ONCE, "",			  "bad_mem");



	dskerp -> copy_chars = tempp (2) -> copy_chars;	/* copy the characters now. */

	nsub = nsub - 1;				/* back down one */

	do i = 0 to hbound (data.maj_array, 1);
	     call relocate_rel (data.maj_array (i).namep);
	     call relocate_rel (data.maj_array (i).fnamep);
	end;

	do i = 1 to nsub;
	     call relocate_rel (data.sub_array (i).namep);
	end;


	cdsa.sections (1).p = tempp (1);
	cdsa.sections (1).len = size (data) + charwds;
	cdsa.sections (1).struct_name = "data";

	cdsa.seg_name = "disk_error_data";
	cdsa.num_exclude_names = 1;
	cdsa.exclude_array_ptr = addr (xnames);

	string (cdsa.switches) = "0"b;
	cdsa.switches.have_text = "1"b;

	call create_data_segment_ (addr (cdsa), rcode);
	if rcode ^= 0 then
	     call com_err_ (rcode, "disk_error_data", "create_data_segment_");

nl_exit:
	call release_temp_segments_ ("disk_error_data", tempp, rcode);
	if rcode ^= 0 then
	     call com_err_ (rcode, "disk_error_data", "release_temp_segments_");

	return;




set_majstat: proc (mjs, descrip);			/* proc to fill in major status array */

dcl  mjs fixed bin (5),				/* major status */
     descrip char (*) aligned;			/* major status description */


	if mjs > hbound (data.maj_array, 1) then do;
	     call com_err_ (0, "disk_error_data", "The bounds of the major status array have been exceeded.");
	     call com_err_ (0, "disk_error_data", "Current value = ^d, must be at least ^d.",
		hbound (data.maj_array, 1), mjs);
	     go to nl_exit;
	end;
	data.maj_array (mjs).interp = compute_rel (dedp, dskerp);
	data.maj_array (mjs).namep = allocate_dsd (descrip);

	return;


     end set_majstat;

set_fmajstat: proc (mjs, descrip);			/* proc to fill in FIPS major status array items */

dcl  mjs fixed bin (5),				/* major status */
     descrip char (*) aligned;			/* major status description */


	if mjs > hbound (data.maj_array, 1) then do;
	     call com_err_ (0, "disk_error_data", "The bounds of the major status array have been exceeded.");
	     call com_err_ (0, "disk_error_data", "Current value = ^d, must be at least ^d.",
		hbound (data.maj_array, 1), mjs);
	     go to nl_exit;
	end;
	data.maj_array (mjs).finterp = compute_rel (dedp, dskerp);
	data.maj_array (mjs).fnamep = allocate_dsd (descrip);

	return;


     end set_fmajstat;



set_substat: proc (stat, retry, descrip, errs);		/* proc to allocate disk_error_interp structure */

dcl  stat char (6) aligned,
     retry fixed bin (5),
     descrip char (*) aligned,
     errs char (*) aligned;


	unspec (disk_error_interp) = "0"b;

	disk_error_interp.bitson = bit (translate (stat, "0", "X"), 6);
	disk_error_interp.bitmask = bit (translate (stat, "10", "0X"), 6);
	disk_error_interp.max_retries = retry;
	if descrip ^= "" then
	     disk_error_interp.namep = allocate_dsd (descrip);
	else
	     disk_error_interp.namep = nulldescriprel;

	call seterr (errs, "bad_addr", disk_error_interp.bad_addr);
	call seterr (errs, "bad_path", disk_error_interp.bad_path);
	call seterr (errs, "bad_dev", disk_error_interp.bad_dev);
	call seterr (errs, "bad_mem", disk_error_interp.bad_mem);
	call seterr (errs, "just_log", disk_error_interp.just_log);
	call seterr (errs, "reseek", disk_error_interp.reseek);
	call seterr (errs, "rsr", disk_error_interp.rsr);

	nsub = nsub + 1;				/* Count one more. */
	dskerp = addr (data.sub_array (nsub));

	return;


     end set_substat;


seterr: proc (errstring, errname, errbit);		/* procedure to set error bit */

dcl  errstring char (*) aligned,
     errname char (*) aligned,
     errbit bit (1) unal;


	if index (errstring, errname) > 0 then
	     errbit = "1"b;

	return;


     end seterr;



allocate_dsd: proc (descrip) returns (bit (18) aligned);	/* procedure to allocate character string */

dcl  descrip char (*) aligned;

dcl  old_dsdp ptr,
     temp_dsdp ptr,
     chlth fixed bin;

/**** Scan existing strings for a match.  Allocate new string only when no match is found. */

	do temp_dsdp = tempp(2)
	     repeat addrel (temp_dsdp, divide (temp_dsdp -> disk_status_descrip.lth, 4, 17, 0) + 1)
	     while (rel (temp_dsdp) < rel (dsdp));
	     if temp_dsdp -> disk_status_descrip.chr = descrip
		then return (compute_rel (tempp(2), temp_dsdp));
	end;

	disk_status_descrip.lth = length (descrip);
	disk_status_descrip.chr = descrip;

	chlth = divide (length (descrip), 4, 17, 0) + 1;
	charwds = charwds + chlth;
	old_dsdp = dsdp;
	dsdp = addrel (dsdp, chlth);

	return (compute_rel (tempp (2), old_dsdp));


     end allocate_dsd;



compute_rel: proc (basep, strucp) returns (bit (18) aligned);  /* procedure to compute relative offset */

dcl  basep ptr,					/* pointer to database */
     strucp ptr;					/* pointer to structure */


	return (bit (bin (bin (rel (strucp), 18) - bin (rel (basep), 18), 18), 18));


     end compute_rel;



relocate_rel: proc (relp);				/* proc to relocate name pointers */

dcl  relp bit (18) unal;				/* name relative pointer */


	relp = bit (bin (bin (relp, 18) + bin (rel (dskerp), 18), 18), 18);

	return;


     end relocate_rel;



     end disk_error_data;




		    evict_page.alm                  11/11/89  1105.1r w 11/11/89  0804.1       97272



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

""""""""""""""""""""""""""""""""""""""""""""""""""
"
"	call page$evict (cmep, event);
"
"	forces current occupant out of core pointed to by cmep
"	Event returned non-zero if waiting necessary.
"
"	May take 2 calls for wired os page.
"
"	Bernard Greenberg, May 16, 1974
"	Adjusted for pc_recover_sst, BSG, 9/3/77
"	Modified for cam_cache by J. Bongiovanni 2/23/81
"	Modified 03/14/81, W. Olin Sibert, for ADP conversion
"	Modified for read_page_abs calling sequence by J. Bongiovanni 2/26/82
"	Modified to move core map, E. N. Kittlitz, 6/21/82.
"	Modified to call page_synch$move, Chris Jones, 05/09/84.
"
""""""""""""""""""""""""""""""""""""""""""""""""""


	include	ptw
	include	sdw
	include	aste
	include	stack_frame
	include	mc
	include	null_addresses
	include	add_type
	include	page_info
	include	sst
	include	cmp
	include	pxss_page_stack

" 

	name	evict_page


	segdef	evict,wire_abs


	link	abs_seg_link,abs_seg$

"
evict:	push	"		set up stack frame
	lda	evict_entry,dl	set up entry flag
	sta	entry_sw
	eppbp	ap|2,*		point to first arg
	eppbp	bp|0,*		point to cme of interest
	stz	ap|4,*		zero wait event
	eax4	bp|0		get cmep into x4
	epbpbb	sst$		bb -> SST through out page
	tsx6	page_fault$init_savex	set up for internal calls
	stx4	pre_temp		save cmep

	tsx6	make_ptw		compute coreadd
	stq	pre_temp+1	save coreadd
	stq	core_add

	ldx2	page_fault$cme_ptwp,*4 see if in use
	tze	.ret		no, can return
	lxl3	page_fault$cme_astep,*4 pick up astep
	stx2	ptp_astep		save page pointer
	sxl3	ptp_astep		and astep
	eppbp	sst|0,2		point to ptw with bp
	lda	ptw|0		now inspect ptw
	cana	ptw.os,dl		read or write going on?
	tnz	await_ptw		yes, must wait for ptw event
	cana	ptw.wired,dl	wired page, not out of service
	tnz	move_wired

	lca	ptw.valid+1,dl	set to turn off access
	ansa	ptw|0		turn off access
	tsx7	cam_cache$cam_cache	tell world, blast out of caches
				"core_add set by make_ptw call above
	lda	ptw|0		look at ptw now
	cana	ptw.phm+ptw.phm1,dl	see if modified at _a_n_y time previous
	tze	not_mod_ptw	no, very easy case

	tsx7	page_fault$find_core_	get a page to move into
	tsx7	set_up_abs_seg_2	get destination abs seg on ab
	tsx6	make_from_abs_seg	get ap abs seg together
	tsx7	move_page		move page into new location
	tsx7	swap_cme		fix core map
	lda	page_fault$cme_flags,*x5
	cana	cme.synch_held,dl
	tze	2,ic
	tsx7	page_synch$move	" update dm_journal_seg_
	tsx7	swap_ptw		change ptw and open it
	szn	dev_signal	did parity wipe page out?
	tnz	parity_destroys_page tough _.
.ret:	return	"		done
"

not_mod_ptw:	"		page was not modified - make find_core_ look guilty
	tsx7	page_fault$cleanup_page	do find-core wrap-up
	return


await_ptw:	"		come here to wait for out of service
	eppap	sp|stack_frame.arg_ptr,*	get ptr to arglist
	sxl2	ap|4,*		set wait event
	return


move_wired:	"		very hard case- move wired page
	tsx7	page_fault$find_core_	get new place for page
	tsx7	set_up_abs_seg_2	get ab-based abs-seg
	tsx6	make_from_abs_seg	set up 'from' abs seg
	ldx2	ptp_astep		restore original ptw ptr
	eppbp	sst|0,2

move_merge:
	lda	ptw|0		get ptw
	ana	ptw.phm,dl	isolate mod bit
	sta	sst|sst.evict_phmbit	save for pcrsst
	stx2	sst|sst.evict_ptp	now recoverable till stz, then ok.
	ersa	ptw|0		possibly turn off, in an RAR way
	eax5	0,al		save state of modified bit

	tsx7	cam_cache$cam_ptws		drive page out of cache and ptwams
	tsx7	move_page
	tsx7	cam_cache$cam_with_wait	stop the world
	lda	ptw|0		look at ptw once more now
	cana	ptw.phm,dl	see if moved any time in between
	tze	not_mod_during_move

	tsx7	move_page		move with world stopped
	increment	sst|sst.recopies	meter

not_mod_during_move:
	eaa	0,5		restore old mod bit
	arl	18
	orsa	ptw|0
	stz	sst|sst.evict_ptp	tell pcrsst its safe.
	tsx7	swap_cme		move core map data around.
	lda	page_fault$cme_flags,*x5
	cana	cme.synch_held,dl
	tze	2,ic
	tsx7	page_synch$move	" update dm_journal_seg_
	tsx7	swap_ptw		fix the ptw
	stz	scs$cam_wait	release everybody
	camp
	cams	4		CLEAR CACHE
	szn	dev_signal	did parity galumph the page?
	tnz	parity_destroys_page
	return	"		and we are done
"  "
"
"	Damage segment due to parity error.
"	Continue to use page.
"
parity_destroys_page:

	lda	aste.fmchanged,du
	orsa	ast|aste.fmchanged_word,3	"damage seg
	lda	aste.damaged,dl
	orsa	ast|aste.damaged_word,3

	lda	pre_temp+1	set up params for report call
	sta	core_add
	ldx4	pre_temp		old frame of interest

	lda	ptw|0		wired case?
	cana	ptw.wired,dl
	tnz	page_error$wired_parity_error crash

	tsx7	page_error$page_move_parity
	tsx7	page_fault$delete_mm_frame 	take mem out of use
	tra	.ret
"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"							"
"							"
"	call page$wire_abs (cmep, event, astep, i);		"
"							"
"	wires page (astep, i) into core pointed to by cmep	"
"	may take up to 3 calls, as per convention.		"
"							"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

wire_abs:	push			"get stack together
	lda	abs_wire_entry,dl	set entry indr
	sta	entry_sw
	tsx6	page_fault$init_savex	set up call stack
	eppbp	ap|6,*		bp -> astep
	eppbp	bp|0,*		bp -> aste
	eax3	bp|0		set x3 to aste
	epbpbb	bp|0		bb		-> sst$+0
	lxl0	ap|8,*		x0 contains i
	eppbp	bp|aste_size,0	bp -> ptw
	eax2	bp|0		x2 -> ptw

	stz	ap|4,*		init wait event
	epplb	ap|2,*		lb -> cmep
	eax4	lb|0,*		x4 -> cme
	stx2	ptp_astep		save x2 similarly
	sxl3	ptp_astep		and astep

	lda	ptw.wired,dl	attempt to wire page wherever it is -
				"This deterministically  suppresses further writes,
				" causes page to stay in if os on read.

	cana	ptw|0		see if already wired
	tnz	already_wired	dont wire it, already wired
	orsa	ptw|0
	increment	sst|sst.wired	maintain meter

already_wired:
	lda	ptw|0		inspect the ptw
	cana	ptw.os,dl		see if reading or writing
	tnz	await_ptw		wait for ptw event
	cana	ptw.valid,dl	see if in core now
	tnz	in_core_now	already in - move if not already in place
	cana	ptw.er,dl		previous error?
	tze	absread.not_prev_error

	tsx7	page_fault$disk_offlinep
	 tra	absread.await_any
absread.not_prev_error:
	tsx7	page_fault$read_page_abs	attempt to read page in
	 tra	await_a		wait for event
	 tra	absread.no_wait
	 tra	absread.await_any	volmap event

"
"	If read_page_abs said no event, then page is in.
"
absread.no_wait:
	return

await_a:
	eax2	0,au		wait for event in a
	tra	await_ptw

absread.await_any:
	eppap	sp|stack_frame.arg_ptr,*
	sta	ap|4,*
	return



in_core_now:			"page already in core, might be in right place,
				"then again, might not
	tsx6	make_ptw		get current ptw for cme
	era	ptw|0		compare with real ptw
	ana	ptw_add_mask,du	look at only address
	tze	.ret		in core, right place, access on, abs wired. GREAT!

	tsx7	set_up_abs_seg_2	set up 'to' abs_seg
	lda	ptw|0		get current home of page
	ana	ptw_add_mask,du	get only address bits
	arl	ptw_to_coreadd.rl	align to coreadd (ADP/L68 OK)
	sta	core_add		set up for set_up_abs_seg
	als	coreadd_to_cmep.ls	get in cmep units (ADP/L68 OK)
	eaa	sst|sst.cmp,*au	get cmep
	sta	pre_temp
	tsx6	page_fault$set_up_abs_seg	set up 'from' abs seg
	tra	move_merge	move the page
" "
"
"
"	subroutines
"
move_page:	"		move a page from the ap abs seg to the ab abs seg
	stz	dev_signal	init parity check
	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+>
	ldi	scu.ir.bm+scu.ir.parm,dl	clear out inds, set parmask
	lda	1024*4,dl
	mlr	(pr,rl),(pr,rl)
	desc9a	ap|0,al
	desc9a	ab|0,al
	nop	0
	nop	0		allow cp and cx boards to synchronize
	sti	temp
	ldi	scu.ir.bm,dl
	nop	0
	inhibit	off	<-><-><-><-><-><-><-><-><-><-><-><->
	lda	temp		get ir
	ana	scu.ir.par,dl
	orsa	dev_signal	store it
	tra	0,7


set_up_abs_seg_2:			" set up abs seg on ab - assumes x4 -> cme
	ldx0	lp|abs_seg_link
	adlx0	lp|abs_seg_link	" get 2*segno in x0
	eaa	0,x4		" Get CMEP in A, and
	sbla	sst|sst.cmp+1	" convert to CME offset
	als	cmep_to_sdw.ls	" Convert to SDW address (ADP/L68 OK)

	eaq	0		" zero the q
	oraq	sdw_bits
	staq	dseg$+0,x0	" store in dseg

	iftarget	l68		" CAM is different on ADP/L68
	  cams	0		" clear am of segs
	  camp	0		" and poss abs-seg pages
	ifend
	iftarget	adp
	  cams	0		" clear am of segs
	  camp	0		" and poss abs-seg pages
	ifend

	eppab	lp|abs_seg_link,*	" Point PR1 at the abs_seg
	tra	0,x7		" and return

" 

swap_ptw:
				"makes ptw point at cme of x4
	tsx6	make_ptw
	ora	add_type.core,dl
	staddra	ptw|0		store in ptw
	lda	ptw.valid,dl	get access bit
	orsa	ptw|0		turn on access if not there already
	tra	0,7

swap_cme:	"			cleans up cme's for swap_ptw
	ldx2	ptp_astep		restore ptw if clobbered
	lxl3	ptp_astep		restore astep
	eppbp	sst|0,2
	ldx5	pre_temp		"old" cme

	lda	page_fault$cme_devadd,*5 get "old" (only) devadd
	staddra	page_fault$cme_devadd,*4 move to "new" cme, which is still free.
	sxl3	page_fault$cme_astep,*4 still unofficial
	eax0	0		get a zero ready.

"
"	The interval between the next two instructions is unsafe
"	with respect to pc_recover_sst. If somehow (only possibility is
"	operand cpu error on this cpu) we lose control between them, pcrsst
"	will clobber this page. This is not bad.
"
	even
	inhibit	on <+><+><+><+><+><+><+><+><+><+><+><+>
	stx0	page_fault$cme_ptwp,*5 It's not in old one,
	stx2	page_fault$cme_ptwp,*4 It's now in new one.
	inhibit	off <-><-><-><-><-><-><-><-><-><-><-><->

	sxl0	page_fault$cme_astep,*5 for cleanliness only.
	tra	0,7

make_ptw: 			" subr to make ptw (and addr in QL) from x4
	eaa	0,x4		get cmep
	sbla	sst|sst.cmp+1	get offset

	iftarget	l68		" L68 & ADP shift differently here
	  als	cmep_to_ptw.ls	" make PTW addr from cmep offset
	ifend
	iftarget	adp
	  arl	cmep_to_ptw.rl	" make PTW addr from cmep offset
	ifend

	eaq	0,au		make lower in q
	qrl	ptw_to_coreadd.rl (ADP/L68 OK)
	tra	0,x6

make_from_abs_seg:	" Common, TSX6 subroutine, relys on page_fault to TRA back
	ldq	pre_temp+1	get 'from' core_add
	stq	core_add		set for page_fault routine
	tra	page_fault$set_up_abs_seg	finish same


"  "
"
"	constants
"
	even
sdw_bits: 		" Bits for abs-seg SDW -- it is
			" Address 0, read/write, one unpaged page

	iftarget	L68	" SDW is different format for each
	  vfd	18/0,18/sdw.valid
	  vfd	1/0,14/(1024/16)-1,3/sdw.read+sdw.write,18/sdw.unpaged
	ifend

	iftarget	ADP
	  vfd	18/0,18/sdw.valid
	  vfd	14/(1024/16)-1,4/0,18/sdw.read+sdw.write+sdw.unpaged
	ifend

	end




		    free_store.alm                  11/11/89  1105.1r w 11/11/89  0804.2      156123



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	free_store - disk address management routines
"
"	Entries
"
"
"             withdraw     - allocate a disk address from stock/volmap
"
"	    withdraw_list_ext - allocate a bunch of disk addresses from
"		         stock/volmap for a non-ALM-page-control caller
"
"	    deposit      - return an address to stock/volmap
"
"	    deposit_list - return a list of addresses to stock/volmap
"
"
"	Rewritten for stock management by J. Bongiovanni, February 1982
"	Modified July 1982, J. Bongiovanni, for scavenger
"	Modified 831219, E. N. Kittlitz, withdraw_list_ext
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	free_store

	segdef	withdraw
	segdef	withdraw_list_ext
	segdef	deposit
	segdef	deposit_list

	equ	deposit_list_no_args,6
	equ	deposit_list_argl_chars,8+8*deposit_list_no_args
	even
segno_offset_mask:
	oct	077777000000
	oct	777777000000
strip_null_addr:
	oct	377777777777
"
	include	add_type
"
	include	apte
"
	include	page_info
"
	include	pvte
"
	include	pxss_page_stack
"
	include	scavenger_data
"
	include	stack_frame
"
	include	stock_seg
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	withdraw
"
"	tsx7	free_store$withdraw
"	<return if out-of-physical-volume>
"	<return if must wait>
"	<return if address allocated>
"
"	On entry,
"	    PVTE index in pvtx
"
"	On exit,
"	    if must wait, event in APTE
"	    if address allocated, in devadd
"
"	Must be called with PTL held
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

withdraw:
	tsx6	page_fault$savex		" Recursive use of x7
	tsx6	setup			" Save/establish registers
	lda	bp|pvte.pc_vacating_word
	cana	pvte.pc_vacating,dl
	tnz	withdraw_oopv

withdraw_retry:
	tsx7	stock$withdraw		" Attempt to withdraw from stock
	tra	withdraw_out_of_stock	" Failed
	als	18			" Succeed - address in AU
	ora	add_type.disk,dl	
	sta	devadd
	tsx6	check_address_range		" Make sure it's in the paging region

	lda	devadd
	tsx6	withdraw_scav_check		" Check for conflict with online scavenge in progress
	tra	withdraw_retry		" Conflict - grab another
					" No conflict

	tsx7	lock_volmap$lock_wired_nowait	" Lock volmap to check for threshold
	tra	unsavex_2			" Couldn't get it - no problem

	tsx7	stock$check_low_threshold	" Check stock to be replenished
	tra	withdraw_unlocks		" Doesn't need to be or can't
	sta	free_store_temp		" Volmap page number

	tsx7	volmap_page$start_async_read	" Read in volmap page
	tra	withdraw_in_mem		" Already in memory
	tra	withdraw_unlocks		" Not in memory

withdraw_in_mem:
	lda	free_store_temp		" Volmap page number
	tsx7	volmap$withdraw_from_volmap	" Volmap to stock

	lda	free_store_temp		" Volmap page number
	tsx7	volmap_page$start_async_write	" Write it back
	tra	withdraw_unlocks		" Unlock and return
	tra	page_error$volmap_async_error	" Not in memory

withdraw_unlocks:
	tsx7	lock_volmap$unlock_wired
	tra	unsavex_2			" Return with devadd

"
withdraw_out_of_stock:
	tsx7	lock_volmap$lock_wired_wait	" Try for lock, state idle
	tra	unsavex_1			" Failed - wait for it

	tsx7	stock$check_low_threshold	" Find volmap page for withdrawal
	tra	withdraw_unlocks_oopv	" None left
	sta	free_store_temp		" Volmap page number

	tsx7	volmap_page$start_async_read	" Read in page
	tra	withdraw_os_in_mem		" Already in memory
	tra	withdraw_unlocks_waits	" Not yet - wait for it

withdraw_os_in_mem:
	lda	free_store_temp		" Volmap page
	tsx7	volmap$withdraw_from_volmap	" Volmap to stock

	lda	free_store_temp		" Volmap page
	tsx7	volmap_page$start_async_write	" Write it back
	tra	withdraw_unlocks_waits	" Can't go until it's done
	tra	page_error$volmap_async_error	" Not in memory

withdraw_unlocks_oopv:
	tsx7	lock_volmap$unlock_wired
	lda	bp|pvte.used_word		" Check for out of HC PART
	cana	pvte.used,dl
	tze	page_error$out_of_hc_part	" Indeed
withdraw_oopv:
	tra	unsavex			" Normal OOPV

withdraw_unlocks_waits:
	tsx7	lock_volmap$unlock_wired
withdraw_unlocks_retry:
	ldq	bp|pvte.volmap_idle_notify_word
	lda	bp|pvte.volmap_idle_notify_word
	ora	pvte.volmap_idle_notify,dl
	stacq	bp|pvte.volmap_idle_notify_word
	tnz	withdraw_unlocks_retry

	eaa	bp|0			" PVTE offset
	arl	18
	ora	pvt$volmap_idle_wait_constant	" Wait event
	eppap	pds$apt_ptr,*		" Stash in APTE ourselves, to
	sta	ap|apte.wait_event		"  avoid race
	tra	unsavex_1

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	withdraw_list_ext
"
"	call page$withdraw_list (pvtx, arrayp, offset, count, event, code);
"
"	Where
"	    pvtx = index of PVTE
"	    arrayp = ptr to array of addresses (lbound = 0)
"	    offset = (input) first address of array to use
"		  (output) next address of array to use
"	    count = (input) number of pages to withdraw
"		= (output) number of pages still to be withdrawn
"	    event = non-zero => wait event
"	    code  = non-zero if allocation cannot be performed
"
"	Must be called with PTL held
"	This entry is designed to be called repeatedly until count = 0.
"	If an out-of-volume condition arises, the caller should deposit
"	all addresses after releasing the PTL.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

withdraw_list_ext:
	push
	tsx6	page_fault$init_savex	" Recursive use of x7
	stz	ap|10,*			" event = ""b
	stz	ap|12,*			" code = 0
	lda	ap|2,*			" PVTE index
	sta	pvtx
	lda	ap|8,*			" count
	tmoz	withdraw_list_end		" silly person

withdraw_list_loop:
	tsx7	withdraw			" withdraw calls setup!
	tra	withdraw_list_oopv		" foo
	tra	withdraw_list_waits
	eppap	sp|stack_frame.arg_ptr,*	" restore ap
	epplb	ap|4,*			" pointer to arrayp
	epplb	lb|0,*			" arrayp
	lda	ap|6,*			" array offset
	ldq	devadd			" this evening's guest star
	stq	lb|0,al			" put it away
	aos	ap|6,*			" bump array offset
	lca	1,dl			" and lower count left
	asa	ap|8,*
	tpnz	withdraw_list_loop		" still more

withdraw_list_end:
	tsx6	meter
	return

withdraw_list_waits:
	eppap	sp|stack_frame.arg_ptr,*	" restore ap
	epplb	pds$apt_ptr,*		" return wait event
	lda	lb|apte.wait_event
	sta	ap|10,*
	tra	withdraw_list_end

withdraw_list_oopv:
	eppap	sp|stack_frame.arg_ptr,*	" restore ap
	lda	error_table_$log_vol_full	" close enough
	sta	ap|12,*			" gimme a break
	tra	withdraw_list_end

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	deposit
"
"	call page$deposit (pvtx, devadd, vtocx, pageno)
"
"	Where
"	    pvtx = index of PVTE
"	    devadd = address to deposit
"	    vtocx = index of VTOCE (-1 if unknown)
"	    pageno = page number within segment
"
"	NOTE: vtocx and pageno are used only by the scavenger
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

deposit:
	push
	tsx6	page_fault$init_savex	" Recursive use of x7
	lda	ap|2,*			" PVTE index
	sta	pvtx
	tsx6	setup			" Establish registers

	lda	bp|pvte.deposit_to_volmap_word " Slow deposit?
	cana	pvte.deposit_to_volmap,dl
	tnz	call_pl1_deposit		" Yes

	tsx6	deposit_check_scav		" This volume being scavenged
	tra	call_pl1_deposit		" Yes

	lda	ap|4,*			" Record address
	tsx7	deposit_try		" Attempt deposit to stock
	tra	call_pl1_deposit		" Too much for me

	tsx6	meter_deposit
	return

call_pl1_deposit:
	call	pc_deposit$pc_deposit(ap|0)
	tsx6	meter_deposit
	return

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	deposit_list
"
"	call page$deposit_list (pvtx, arrayp, first, last, vtocx, pagenop)
"
"	Where
"	    pvtx = index of PVTE
"	    arrayp = ptr to array of addresses (lbound = 1)
"	    first = first array element to be deposited
"	    last = last array element to be deposited
"	    vtocx = VTOCE index (-1 if unknown)
"	    pagenop = ptr to array of page numbers within segment (lbound=1),
"	              or null
"
"	NOTE: vtocx and pagenop are used only by the scavenger
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

deposit_list:
	push
	tsx6	page_fault$init_savex	" Recursive use of x7
	lda	ap|2,*			" Index of PVTE
	sta	pvtx	
	tsx6	setup			" Establish registers

	spriap	free_store_temp_1		" Save argument pointer
	ldq	ap|6,*			" First element
	stq	free_store_temp		" Save

	lda	bp|pvte.deposit_to_volmap_word " Slow deposit?
	cana	pvte.deposit_to_volmap,dl
	tnz	call_pl1_deposit_list	" Yes

	tsx6	deposit_check_scav		" Is this volume being scavenged
	tra	call_pl1_deposit_list	" Yes

deposit_list_loop:
	eppap	free_store_temp_1,*		" Restore argument pointer
	ldq	free_store_temp		" Next element
	cmpq	ap|8,*			" Done last
	tpnz	deposit_list_returns	" Yes
	eppap	ap|4,*			" ap -> ptr -> array (1)
	eppap	ap|0,*			" ap -> array (1)
	lda	ap|-1,ql			" Next address
	tsx7	deposit_try		" Attempt to deposit to stock
	tra	call_pl1_deposit_list	" Call the big guy
	aos	free_store_temp		" Bump to next array element
	tra	deposit_list_loop

call_pl1_deposit_list:
	eppap	free_store_temp_1,*		" Restore argument pointer
	ldx0	ap|0			" x0 = 2 * (# args)
	cmpx0	2*deposit_list_no_args,du	" The right number?
	tnz	page_error$invalid_deposit_list_args " No
	mlr	(pr),(pr)			" Copy arg list
	desc9a	ap|0,deposit_list_argl_chars
	desc9a	arg,deposit_list_argl_chars
	eppap	free_store_temp		" And change first
	spriap	arg+6
	stz	arg+1			" No descriptors
	call	pc_deposit$deposit_list(arg)

deposit_list_returns:
	tsx6	meter_deposit

	return

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	deposit_try - internal procedure to attempt a deposit to the
"		stock
"
"	tsx7	deposit_try
"	<return if fail>
"	<return if succeed>
"
"	On entry,
"	    bp -> PVTE
"	    bb -> record stock
"	    ab -> stock_seg$meters
"	    Areg = disk address
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

deposit_try:
	tsx6	page_fault$savex		" Recursive use of x7
	ana	strip_null_addr		" Make address live
	cana	add_type.disk,dl		" Is it a disk address
	tze	page_error$deposit_invalid_addtype " No - bad news

	tsx6	check_address_range		" Make sure it's in the paging region

	arl	18			" Address to AL
	tsx7	stock$deposit		" Attempt to deposit to stock
	tra	page_fault$unsavex		" Failed
	tra	page_fault$unsavex_1	" Succeeded


"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	setup - internal procedure to save/establish registers
"
"	tsx6	setup
"
"	On entry,
"	    pvtx contains index of PVTE
"
"	On return,
"	    bp -> pvte
"	    bb -> record stock
"	    ab -> stock_seg$meters
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

setup:
	stx2	savx2_3			"Save PC registers
	sxl3	savx2_3
	
	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+>

	read_clock
	sbaq	pds$cpu_time		" AQ = Total CPU Time
	sbaq	pds$virtual_delta		" AQ = Total VCPU Time
	staq	free_store_start_time	" Save for metering

	inhibit	off	<-><-><-><-><-><-><-><-><-><-><-><-><-><-><-><->

	eppbp	pvt$array			" PVTE array
	ldq	pvte_size,dl
	mpy	pvtx			" Offset of one beyond
	eppbp	bp|-pvte_size,ql		" bp -> PVTE
	spribp	free_store_temp_1

	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> record stock
	lprpab	bb|record_stock.pvtep	" Check synchronization
	epaq	ab|0			" PVTE ptr
	eraq	free_store_temp_1		" Compare with other PVTE ptr
	canaq	segno_offset_mask		" Interesting bits only
	tnz	page_error$stock_out_of_synch	" Don't point to each other

	epbpab	bb|0			" ab -> base of stock_seg
	eppab	ab|stock_seg.meters		" ab -> meters
	tra	0,x6

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	check_address_range - internal procedure to validate that an
"	     address is within the paging region of the device
"
"	tsx6	check_address_range
"
"	On entry,
"	    bp -> pvte
"	    AU contains non-null address (AL is not relevant)
"
"	On return,
"	    Areg is not changed
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

check_address_range:

	sta	devadd			" For page_error

	ldx0	bp|pvte.baseadd		" Begin of paging region
	cmpx0	devadd			" Above beginning
	tpnz	page_error$address_out_of_range " No
	lxl0	bp|pvte.totrec		" Size of paging region
	adlx0	bp|pvte.baseadd		" Address 1 beyond end of region
	cmpx0	devadd			" Below end
	tmoz	page_error$address_out_of_range " No

	tra	0,x6			" Address within paging region

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	withdraw_scav_check - internal procedure to check for a conflict
"	     in the address just withdrawn with a scavenge in progress.
"	     A conflict exists if the address is marked as in-user or
"	     conflict.
"
"	tsx6	withdraw_scav_check
"	<return if conflict>
"	<return if no scavenge or no conflict>
"
"	On entry,
"	    bp -> PVTE
"	    ab -> stock_seg$meters
"	    AU contains non-null address
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

withdraw_scav_check:
	lxl0	bp|pvte.scavenger_block_rel	" Scavenge in progress
	tze	1,x6			" No
	ldq	bp|pvte.scav_check_address_word
	canq	pvte.scav_check_address,dl	" Does scavenger want us to check the address
	tze	1,x6			" No

	aos	ab|rsmeters.withdraw_check_scav " Meter
	eppap	scavenger_data$+0,x0	" ap -> scavenger block
	eax0	0,au			" Record address
	sblx0	bp|pvte.baseadd		" Record address w/i paging region
	eppap	ap|scavenger_block.records,x0	" ap -> record block for this record address

withdraw_scav_lock:				" Lock record block
	ldq	ap|0
	lda	ap|0
	canq	record_block.lock,dl	" Locked
	tnz	withdraw_scav_lock		" Yes
	ora	record_block.lock,dl
	stacq	ap|0			" Try to lock
	tnz	withdraw_scav_lock		" Failed

	arl	record_block.state_shift	" Extract state of address
	ana	record_block.state_mask,dl
	tra	withdraw_check_state,al	" And do state-ly things

withdraw_check_state:
	tra	withdraw_unseen
	tra	withdraw_free
	tra	withdraw_in_use
	tra	withdraw_conflict

withdraw_unseen:
withdraw_free:				" Mark in use to this vtocx, page number
	stz	free_store_temp
	lda	vtocx			" Faulting VTOCE index
	ana	record_block.vtocx_mask,dl
	als	record_block.vtocx_shift
	orsa	free_store_temp
	lda	pageno			" Faulting page number
	ana	record_block.pageno_mask,dl
	als	record_block.pageno_shift
	orsa	free_store_temp
	lda	STATE_IN_USE,dl
	als	record_block.state_shift
	ora	free_store_temp

	ldq	ap|0
	stacq	ap|0			" Unlock address
	tnz	page_error$scav_stacq_fails
	tra	1,x6

withdraw_in_use:

	lda	STATE_CONFLICT,dl		" Change state to conflict
	ldq	record_block.state_mask,dl
	als	record_block.state_shift
	qls	record_block.state_shift
	orq	record_block.lock,dl
	erq	=-1			" Q has mask to reset state, lock
	stq	free_store_temp
	ldq	ap|0			" Pick up address block
	ansq	free_store_temp		" Reset state, lock
	ora	free_store_temp		" Address block with state, lock reset
	ldq	ap|0
	stacq	ap|0			" Unlock address block
	tnz	page_error$scav_stacq_fails
withdraw_conflict:
	aos	ab|rsmeters.withdraw_conflict	" Meter
	tra	0,x6
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	deposit_check_scav - Internal procedure to determine whether this
"		           volume is being scavenged and addresses being
"			 deposited need to be checked.
"
"	tsx6	deposit_check_scav
"	<return if addresses must be checked>
"	<return if address need not be checked>
"
"	On entry,
"	    bp -> PVTE
"
"	
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

deposit_check_scav:
	lxl0	bp|pvte.scavenger_block_rel	" Scavenge going on?
	tze	1,x6			" No
	ldq	bp|pvte.scav_check_address_word
	canq	pvte.scav_check_address,dl	" Check addresses?
	tze	1,x6			" No
	tra	0,x6			" Yes

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Returns to page control, restoring registers
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

unsavex:
	tsx6	restore_regs
	tra	page_fault$unsavex

unsavex_1:
	tsx6	restore_regs
	tra	page_fault$unsavex_1

unsavex_2:
	tsx6	restore_regs
	tra	page_fault$unsavex_2

restore_regs:
	ldx2	savx2_3
	lxl3	savx2_3
	eppbb	sst$
	eppbp	bb|0,x2

"	Fall through to meter

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	meter CPU time
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
meter:
	eax0	0			" Withdraw
	tra	meter_common

meter_deposit:
	eax0	1			" Deposit

	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+>

meter_common:
	read_clock
	sbaq	pds$cpu_time		" AQ = Total CPU time
	sbaq	pds$virtual_delta		" AQ = Total VCPU time
	sbaq	free_store_start_time	" AQ = VCPU in free_store
	eax0	0,x0			" Withdraw
	tnz	meter_deposit_exit		" No
	adaq	ab|rsmeters.withdraw_time
	staq	ab|rsmeters.withdraw_time
	increment	ab|rsmeters.withdraw_calls
	tra	0,x6

meter_deposit_exit:
	adaq	ab|rsmeters.deposit_time
	staq	ab|rsmeters.deposit_time
	increment	ab|rsmeters.deposit_calls
	tra	0,x6

	inhibit	off	<-><-><-><-><-><-><-><-><-><-><-><-><-><-><-><->

	end




		    get_ptrs_.alm                   11/11/89  1105.1r w 11/11/89  0804.2       41796



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

"
"	GET_PTRS_ -- Program to remap page and segment control pointers
"
"	Modification history:
"	Modified for followon by Dick Snyder Aug 5, 1972
"	Modified to fix get_ptrs_$given_astep bugs by Dick Snyder Sept 6, 1972
"	New Storage System. given_cmep and given_ptp deleted. March 21, 1975 by BSG.
"	Modified to remove SDW alignment assumption, 5/14/75 by Mabee
"	Modified for ADP conversion, 03/17/81, W. Olin Sibert
"	Modified for $given_sdw, unpaged segment check, 03/21/81, WOS
"	Modified for $ptw_to_cmep, 04/17/81, WOS
"	Modified for paged unpaged segments, October 1983, Keith Loepere.
"

	name	get_ptrs_

	entry	given_astep	" ASTEP to SDW conversion
	entry	given_sdw 	" SDW to ASTEP conversion
	entry	given_segno	" SEGNO to ASTEP conversion
	entry	ptw_to_cmep	" PTWP to CMEP conversion

"
"	GET_PTRS_$GIVEN_ASTEP
"
"	   Returns an SDW containing the proper address for a segment, given
"	   its ASTE pointer. Call is:
"
"		sdw = get_ptrs_$given_astep (astep);

given_astep:
	epp1	sst$+0		get pointer to SST
	epp2	ap|2,*		get ptr to astep
	eaa	pr2|0,*		get word offset of aste in au

	ldq	pr1|aste.ptsi_word,au get page table size for bound field
	qrs	aste.ptsi_shift
	anq	aste.ptsi_mask,dl	leave only page table size index
	ldq	sst$pts,ql	pick up page table size from SST header
	qls	page_power-4	Convert to 16 word block count
	sblq	1,dl		Subtract 1 for bound field format
	qls	sdw.bound_shift	and put it in the right region of the SDW

	adla	aste_size,du	add in size of an AST entry
	arl	18		and put in AL to get page table offset

	adla	sst$ptwbase	add in absolute offset of page table array
	als	coreadd_to_sdw.ls	position page table address

	oraq	read_write_valid	set correct bits in sdw
	epp2	ap|4,*		return the SDW to the caller
	sta	pr2|0		in a possibly unaligned word pair
	stq	pr2|1

return:	short_return

" 
"
"	GET_PTRS_$GIVEN_SDW
"
"	   Given a pointer to an SDW, returns the AST entry pointer for the
"	   (necessarily paged) segment. Call is:
"
"		astep = get_ptrs_$given_sdw (sdw_ptr);
"
"	GET_PTRS_$GIVEN_SEGNO
"
"	   Like get_ptrs_$given_sdw, but returns an AST entry pointer when
"	   given a segment number. Call is:
"
"		astep = get_ptrs_$given_segno (segno);
"

given_sdw:
	epp2	ap|2,*		Get the pointer argument
	epp2	pr2|0,*

join_given_sdw:
	ldq	pr2|0		Get the first (address) word of the SDW
	epp1	sst$+0		get pointer to SST
	qrl	sdw_to_coreadd.rl	right justify address
	anq	=v36/coreadd_mask	and leave only the address portion
	tze	return_null

	cmpq	unpaged_page_tables$0+upt.sst_last_loc	test for pagedness -- 
	tpl	return_null	this call invalid for unpaged segments
	sbq	unpaged_page_tables$0+upt.sst_absloc	make relative to SST segment
	tmi	return_null

	epp3	pr1|-aste_size,ql	generate final pointer

return_sdwadd:
	spri3	ap|4,*		return to user
	short_return



given_segno:
	lda	ap|2,*		pick up the segment number
	als	1		multiply segno by sdw size
	epp2	dseg$+0,al	get a pointer to the SDW,
	tra	join_given_sdw	and join common code



return_null:
	epp3	=its(-1,1),*	get a null pointer
	spri3	ap|4,*		and return it
	short_return

" 

"	GET_PTRS_$PTW_TO_CMEP
"
"	   Returns a pointer to the CME describing the page frame for the given
"	   PTW, or returns null if the PTW is not a valid (in-core) PTW
"
"		cmep = get_ptrs_$ptw_to_cmep (ptwp);

ptw_to_cmep:
	epp1	ap|2,*		address ptw pointer
	lda	pr1|0,*		get the PTW
	cana	ptw.valid,dl	is the page in core?
	tze	return_null	nope.

	ana	ptw_add_mask,du	mask off all but the address
	arl	ptw_to_cmep_lower.rl and convert to a CMEP
	epp3	sst$cmp,*al	the CME pointer itself

	spri3	ap|4,*		return it
	short_return


" 

	even
read_write_valid:	" Bits for a valid (incore) SDW with read/write access

	iftarget	l68	" Bits are in different halfwords
	  vfd	18/0,18/sdw.valid
	  vfd	18/sdw.read+sdw.write,18/sdw.not_a_gate
	ifend

	iftarget	adp
	  vfd	18/0,18/sdw.valid
	  vfd	18/0,18/sdw.read+sdw.write+sdw.not_a_gate
	ifend



	include	page_info

	include	sdw
	include	ptw
	include	aste
	include	cmp
	include	unpaged_page_tables
	end




		    hc_dm_util.pl1                  11/11/89  1105.1rew 11/11/89  0804.2      174852



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(85-07-17,CLJones), approve(86-01-26,MCR7330),
     audit(86-01-16,Tague), install(86-07-17,MR12.0-1097):
     to perform security auditing.
  2) change(86-07-10,Dupuis), approve(86-01-26,MCR7330),
     audit(86-07-14,GDixon), install(86-07-17,MR12.0-1097):
     Changed the 85-07-17 auditing code so that it wouldn't take a page fault
     while it had the page table locked, and to audit the GRANT'ing in all
     cases.
                                                   END HISTORY COMMENTS */


/* format: style5,^indcomtxt */

hc_dm_util$activate:
        proc (Ptsi);

/* DESCRIPTION:
Utility routines for Data Management Support

activate - note activation of a synchronized segment of a given size.

allocate_journal_index - get ring-2 Data Management a free journal index.

check_activate - determine whether a synchronized segment of a given size
	   can be activated.

deactivate - note deactivation of a synchronized segment of a given size.

free_journal_index - free a previously allocated journal index.

get_journal_stamp - given a journal index, returns the current time stamp.
 
get_n_journals - return the number of journal slots allocated, i.e,
	   dm_journal.n_journal.

get_max_held_per_journal - returns the value of dm_journal.max_held_per_journal

set_journal_stamp - set the time stamp of a journal for Page Control.

validate_bj_uid - Checks the supplied uid against the uid in the 
	   dm_journal_seg_.
*/

/* HISTORY:
Written October 1982 by J. Bongiovanni.
Modified:
May 1983 by E. N. Kittlitz to fix free to not write Journal_Idx.
05/13/85 by R. Michael Tague to use limit_covert_channel on
	   calls to $allocate_journal_index.  Upgraded access check in
	   set_journal_stamp and free_journal_index to check for seg privs.
	   Added dm_journal_seg_ locking in set_time_stamp.  Generally
	   cleaned up dm_journal_seg_ locking for all entries.  Added the
	   entries $validate_bj_uid, $get_journal_stamp, $get_n_journals,
	   and $get_max_held_per_journal so that ring-2 DM would not need
	   to read the dm_journal_seg_.  Reformatted.
05/20/85 by R. Michael Tague to get the AIM checking on $free_journal, 
             $get_journal_stamp, and $validate_journal_stamp right.
*/

/*  Parameter  */

        dcl     Code		fixed bin (35) parameter;
					      /* Standard Error Code */
        dcl     Journal_Idx		fixed bin parameter;
					      /* Journal Index */
        dcl     Ptsi		fixed bin (3) parameter;
					      /* Page Table Size index */
        dcl     Time_Stamp		fixed bin (71) parameter;
					      /* New time stamp */
        dcl     Uid			bit (36) aligned;
					      /* Ring-2 Unique ID for Journal */

/*  Automatic  */

        dcl     code		fixed bin (35);
        dcl     journal_idx		fixed bin;
        dcl     jx			fixed bin;
        dcl     me			char (40);
        dcl     old_mask		fixed bin (71);
        dcl     ptwp		ptr;
        dcl     time_stamp		fixed bin (71);
        dcl     uid			bit (36) aligned;
        dcl     validated		bit (1) aligned;

/*  External  */

        dcl     access_operations_$dm_journal_allocate
				bit (36) aligned ext static;
        dcl     access_operations_$dm_journal_free
				bit (36) aligned ext static;
        dcl     access_operations_$dm_journal_read_attr
				bit (36) aligned ext static;
        dcl     access_operations_$dm_journal_write_attr
				bit (36) aligned ext static;

        dcl     error_table_$bad_arg	fixed bin (35) external;
        dcl     error_table_$dm_journal_pages_held
				fixed bin (35) external;
        dcl     error_table_$dm_not_enabled
				fixed bin (35) external;
        dcl     error_table_$invalid_dm_journal_index
				fixed bin (35) external;
        dcl     error_table_$no_journals_free
				fixed bin (35) external;
        dcl     error_table_$synch_seg_limit
				fixed bin (35) external;
        dcl     pds$access_authorization
				bit (72) aligned external;
        dcl     pds$validation_level	fixed bin (3) external;
        dcl     sst$dm_enabled	bit (1) aligned external;
        dcl     tc_data$end_of_time	fixed bin (71) external;

/*  Entry  */

        dcl     access_audit_$log_obj_class
				entry options (variable);
        dcl     limit_covert_channel	entry (fixed bin);
        dcl     lock$lock_fast	entry (ptr);
        dcl     lock$unlock_fast	entry (ptr);
        dcl     page_synch$unlink_journal
				entry (fixed bin);
        dcl     pmut$lock_ptl		entry (fixed bin (71), ptr);
        dcl     pmut$unlock_ptl	entry (fixed bin (71), ptr);
        dcl     (read_allowed_, write_allowed_, read_write_allowed_)
				entry (bit (72) aligned,
				bit (72) aligned)
				returns (bit (1) aligned);

/*  Builtin  */

        dcl     addr		builtin;
        dcl     char		builtin;
        dcl     clock		builtin;
        dcl     divide		builtin;
        dcl     ltrim		builtin;

/*  Constants  */

        dcl     DENY		bit (1) aligned static
				options (constant) init ("0"b);
        dcl     GRANT		bit (1) aligned static
				options (constant) init ("1"b);
%page;
/* ************************************************************************
   * $activate - Notes activation of a synchronized segment. It is	    *
   * assumed that that Global AST Lock is held by the process.	    *
   ************************************************************************ */

        dm_journal_segp = addr (dm_journal_seg_$);
        dm_journal.per_aste_pool (Ptsi).n_active =
	  dm_journal.per_aste_pool (Ptsi).n_active + 1;
        return;
%page;
/* ************************************************************************
   * $allocate_journal_index - give ring-2 an unused journal index.	    *
   * Possible covert channel corrected by call to limit_covert_channel.   *
   ************************************************************************ */

allocate_journal_index:
        entry (Uid, Journal_Idx, Code);

        if ^sst$dm_enabled then
	      do;
	      Code = error_table_$dm_not_enabled;
	      return;
	      end;

        Journal_Idx = 0;
        uid = Uid;
        journal_idx = 0;
        me = "hc_dm_util$allocate_journal_index";
        code = 0;

        if uid = ""b then
	      do;
	      Code = error_table_$bad_arg;
	      return;
	      end;

        call limit_covert_channel (1);
        dm_journal_segp = addr (dm_journal_seg_$);
        call lock$lock_fast (addr (dm_journal.lock));
        dm_journal.allocate_calls = dm_journal.allocate_calls + 1;
        if dm_journal.n_journals <= dm_journal.n_journals_inuse then
	      code = error_table_$no_journals_free;
        else
	      do;
	      do jx = 1 to dm_journal.n_journals
		while (dm_journal.per_journal (jx).uid ^= ""b);
	      end;
	      if jx > dm_journal.n_journals then
		    code = error_table_$no_journals_free;
	      else
		    do;
		    dm_per_journalp = addr (dm_journal.per_journal (jx));
		    dm_journal.n_journals_inuse =
		        dm_journal.n_journals_inuse + 1;
		    dm_per_journal.time_stamp = clock ();
		    dm_per_journal.access_class = pds$access_authorization;
		    dm_per_journal.uid = uid;
		    call RECOMPUTE_THRESH;
		    journal_idx = jx;
		    call AUDIT (GRANT,
		        access_operations_$dm_journal_allocate, journal_idx,
		        dm_per_journal);
		    end;
	      end;

        call lock$unlock_fast (addr (dm_journal.lock));
        Journal_Idx = journal_idx;
        Code = code;
        return;
%page;
/* ************************************************************************
   * $check_activate - checks whether a synchronized segment of a given   *
   * size may be activated.  It is assumed that the Global AST Lock is    *
   * held.						    *
   ************************************************************************ */

check_activate:
        entry (Ptsi, Code);

        if ^sst$dm_enabled then
	      do;
	      Code = error_table_$dm_not_enabled;
	      return;
	      end;

        Code = 0;

        dm_journal_segp = addr (dm_journal_seg_$);
        dm_journal.activate_calls = dm_journal.activate_calls + 1;
        if dm_journal.per_aste_pool (Ptsi).n_active
	  >= dm_journal.per_aste_pool (Ptsi).threshold then
	      do;
	      dm_journal.activate_denied = dm_journal.activate_denied + 1;
	      Code = error_table_$synch_seg_limit;
	      end;
        return;
%page;
/* ************************************************************************
   * $deactivate - Note deactivation of a synchronized segment.	    *
   ************************************************************************ */

deactivate:
        entry (Ptsi);

        dm_journal_segp = addr (dm_journal_seg_$);
        dm_journal.deactivate_calls = dm_journal.deactivate_calls + 1;
        dm_journal.per_aste_pool (Ptsi).n_active =
	  dm_journal.per_aste_pool (Ptsi).n_active - 1;
        return;
%page;
/* ************************************************************************
   * $free_journal_index - frees a previously allocated journal index.    *
   * Authorization check is performed.				    *
   ************************************************************************ */

free_journal_index:
        entry (Journal_Idx, Code);

        if ^sst$dm_enabled then
	      do;
	      Code = error_table_$dm_not_enabled;
	      return;
	      end;

        journal_idx = Journal_Idx;
        me = "hc_dm_util$free_journal_index";
        code = 0;

        dm_journal_segp = addr (dm_journal_seg_$);
        call lock$lock_fast (addr (dm_journal.lock));
        dm_journal.free_calls = dm_journal.free_calls + 1;

        if (journal_idx <= 0) | (journal_idx > dm_journal.n_journals) then
	      code = error_table_$invalid_dm_journal_index;
        else
	      do;
	      dm_per_journalp = addr (dm_journal.per_journal (journal_idx));
	      if dm_per_journal.uid = ""b then
		    code = error_table_$invalid_dm_journal_index;
	      else if
		^(
		read_write_allowed_ (pds$access_authorization,
		dm_per_journal.access_class)
		| (addr (pds$access_authorization) -> aim_template.seg))
		then
		    do;
		    call AUDIT (DENY, access_operations_$dm_journal_free,
		        journal_idx, dm_per_journal);
		    code = error_table_$invalid_dm_journal_index;
		    end;
	      else
		    do;
		    call AUDIT (GRANT,
		         access_operations_$dm_journal_free,
		         journal_idx, dm_per_journal);
		    code = error_table_$dm_journal_pages_held;
		    call pmut$lock_ptl (old_mask, ptwp);
		    if dm_per_journal.n_held = 0 then
			  do;
			  dm_per_journal.time_stamp = tc_data$end_of_time;
			  dm_per_journal.uid = ""b;
			  dm_per_journal.access_class = ""b;
			  code = 0;
			  end;
		    call pmut$unlock_ptl (old_mask, ptwp);
		    if code = 0 then
			  do;
			  dm_journal.n_journals_inuse =
			      dm_journal.n_journals_inuse - 1;
			  call RECOMPUTE_THRESH;
			  end;
		    end;
	      end;
        call lock$unlock_fast (addr (dm_journal.lock));
        Code = code;
        return;
%page;
/* ************************************************************************
   * get_journal_stamp - Returns the value of the journal stamp for a     *
   * given dm_journal_seg_ index.  An access class check is performed	    *
   * before the information is returned.			    *
   ************************************************************************ */

get_journal_stamp:
        entry (Journal_Idx) returns (fixed bin (71));

        journal_idx = Journal_Idx;
        time_stamp = 0;
        me = "hc_dm_util$get_journal_stamp";

        if ^sst$dm_enabled then
	      return (time_stamp);

        dm_journal_segp = addr (dm_journal_seg_$);
        call lock$lock_fast (addr (dm_journal.lock));
        if (journal_idx > 0) & (journal_idx <= dm_journal.n_journals) then
	      do;
	      dm_per_journalp = addr (dm_journal.per_journal (journal_idx));
	      if dm_per_journal.uid ^= ""b then
		    if read_allowed_ (pds$access_authorization,
		        dm_per_journal.access_class)
		        | (addr (pds$access_authorization)
		        -> aim_template.seg) then
			  do;

/****			  call AUDIT (GRANT,
			      access_operations_$dm_journal_read_attr,
			      journal_idx, dm_per_journal);
	We'd audit if the performance implications weren't horrendous. ****/

			  time_stamp = dm_per_journal.time_stamp;
			  end;
		    else
			  call AUDIT (DENY,
			      access_operations_$dm_journal_read_attr,
			      journal_idx, dm_per_journal);
	      end;
        call lock$unlock_fast (addr (dm_journal.lock));
        return (time_stamp);
%page;
/* ************************************************************************
   * get_max_held_per_journal - Return the value of		    *
   * dm_journal.max_held_per_journal from dm_journal_seg_.		    *
   ************************************************************************ */

get_max_held_per_journal:
        entry () returns (fixed bin);

        if ^sst$dm_enabled then
	      return (0);
        else
	      return (addr (dm_journal_seg_$)
		-> dm_journal.max_held_per_journal);
%page;
/* ************************************************************************
   * get_n_journals - Return the value of dm_journal.get_n_journals from  *
   * dm_journal_seg_.					    *
   ************************************************************************ */

get_n_journals:
        entry () returns (fixed bin);

        if ^sst$dm_enabled then
	      return (0);
        else
	      return (addr (dm_journal_seg_$) -> dm_journal.n_journals);
%page;
/* ************************************************************************
   * $set_journal_stamp - sets the time stamp for a specified journal.    *
   ************************************************************************ */

set_journal_stamp:
        entry (Journal_Idx, Time_Stamp, Code);
        journal_idx = Journal_Idx;
        time_stamp = Time_Stamp;

        if ^sst$dm_enabled then
	      do;
	      Code = error_table_$dm_not_enabled;
	      return;
	      end;

        me = "hc_dm_util$set_journal_stamp";
        code = 0;
        dm_journal_segp = addr (dm_journal_seg_$);
        call lock$lock_fast (addr (dm_journal.lock));
        dm_journal.set_stamp_calls = dm_journal.set_stamp_calls + 1;
        if (journal_idx <= 0) | (journal_idx > dm_journal.n_journals) then
	      code = error_table_$invalid_dm_journal_index;
        else
	      do;
	      dm_per_journalp = addr (dm_journal.per_journal (journal_idx));
	      if dm_per_journal.uid = ""b then
		    code = error_table_$invalid_dm_journal_index;
	      else if
		^(
		write_allowed_ (pds$access_authorization,
		dm_per_journal.access_class)
		| (addr (pds$access_authorization) -> aim_template.seg))
		then
		    do;
		    call AUDIT (DENY,
		        access_operations_$dm_journal_write_attr,
		        journal_idx, dm_per_journal);
		    code = error_table_$invalid_dm_journal_index;
		    end;
	      else
		    do;

/****		    call AUDIT (GRANT,
		        access_operations_$dm_journal_write_attr,
		        journal_idx, dm_per_journal);
	We'd audit if the performance implications weren't horrendous. ****/

		    dm_per_journal.time_stamp = time_stamp;

		    call pmut$lock_ptl (old_mask, ptwp);
		    call page_synch$unlink_journal (journal_idx);
		    call pmut$unlock_ptl (old_mask, ptwp);
		    end;
	      end;
        call lock$unlock_fast (addr (dm_journal.lock));
        Code = code;
        return;
%page;
/* ************************************************************************
   * validate_bj_uid - Given a dm_journal_seg_ index and BJ uid, this	    *
   * entry returns true if the supplied uid matches the uid indexed in    *
   * the dm_journal_seg_ and the caller has authorization to know this.   *
   ************************************************************************ */

validate_bj_uid:
        entry (Uid, Journal_Idx) returns (bit (1) aligned);

        uid = Uid;
        journal_idx = Journal_Idx;
        validated = "0"b;

        if ^sst$dm_enabled then
	      return ("0"b);

        me = "hc_dm_util$validate_bj_uid";
        dm_journal_segp = addr (dm_journal_seg_$);
        call lock$lock_fast (addr (dm_journal.lock));
        if (journal_idx > 0) & (journal_idx <= dm_journal.n_journals) then
	      do;
	      dm_per_journalp = addr (dm_journal.per_journal (journal_idx));
	      if read_allowed_ (pds$access_authorization,
		dm_per_journal.access_class)
		| (addr (pds$access_authorization) -> aim_template.seg) then
		    do;

/****		    call AUDIT (GRANT,
		        access_operations_$dm_journal_read_attr,
		        journal_idx, dm_per_journal);
	We'd audit if the performance implications weren't horrendous. ****/

		    if uid ^= ""b & uid = dm_per_journal.uid then
			  validated = "1"b;
		    end;
	      else
		    call AUDIT (DENY,
		        access_operations_$dm_journal_read_attr,
		        journal_idx, dm_per_journal);
	      end;
        call lock$unlock_fast (addr (dm_journal.lock));
        return (validated);
%page;
/* ************************************************************************
   * RECOMPUTE_THRESH - Internal Procedure to recompute max held pages    *
   * per journal, which is used by ring-2 Data Management to prevent	    *
   * flooding the system with held pages.			    *
   ************************************************************************ */

RECOMPUTE_THRESH:
        proc;

        if dm_journal.n_journals_inuse = 0 then
	      dm_journal.max_held_per_journal = dm_journal.max_held_pages_mem;
        else
	      dm_journal.max_held_per_journal =
		divide (dm_journal.max_held_pages_mem,
		dm_journal.n_journals_inuse, 17);

        end RECOMPUTE_THRESH;
%page;
/* ************************************************************************
   * AUDIT - Internal procedure to audit security-related events relating *
   * to journals.						    *
   ************************************************************************ */

AUDIT:
        proc (outcome, operation, id, journal_entry);

        dcl     outcome		bit (1) aligned parameter;
					      /* (I) signifies whether or not the operation was granted */
        dcl     operation		bit (36) aligned parameter;
					      /* (I) the operation in question */
        dcl     id			fixed bin parameter;
					      /* (I) the journal index */
        dcl     1 journal_entry	like dm_per_journal parameter aligned;
					      /* (I) for auditing */

        dcl     event_flags		bit (36) aligned;
        dcl     object_name		char (32);

        event_flags = ""b;			      /* clear all flags */
        addr (event_flags) -> audit_event_flags.grant = (outcome = GRANT);
        object_name = "DM journal #" || ltrim (char (id));

        call access_audit_$log_obj_class (me, pds$validation_level, event_flags,
	  operation, journal_entry.access_class, object_name, 0, null (), 0,
	  "UID=^w", journal_entry.uid);
        return;

%include access_audit_eventflags;

        end AUDIT;
%page;
%include dm_journal_seg_;
%page;
%include aim_template;
        end hc_dm_util$activate;




		    lock_volmap.alm                 11/11/89  1105.1r w 11/11/89  0804.2       71361



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lock_volmap
"
"	Routines for manipulating the per-volume volume map lock.
"	Lock succeeds if the lock can be obtained and the asynchronous
"	state is idle. Otherwise, it fails. The asynchronous state
"	is protected in the following way:
"
"	   To change the state from IDLE requires both the volume map
"	   lock and the Page Table Lock.
"
"	   To change the state from anything else requires the Page
"	   Table Lock.
"
"	Entries:
"
"	   lock_unwired      - lock from outside of page control
"	   lock_wired_nowait - lock from page control, don't wait
"	   lock_wired_wait   - lock from page control, set wait event
"	   unlock_unwired    - unlock from outside of page control
"	   unlock_wired      - unlock from page control
"
"	Written February 1982 by J. Bongiovanni
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	lock_volmap

	segdef	lock_unwired
	segdef	unlock_unwired

	segdef	lock_wired_nowait
	segdef	lock_wired_wait
	segdef	unlock_wired

	even
notify_arg_list:
	vfd	o18/2,o18/4,o36/0

"
	include	apte
"
	include	page_info
"
	include	pvt
"
	include	pvte
"
	include	pxss_page_stack
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lock_unwired
"
"	call page$lock_volmap (pvtep)
"
"	pvtep -> PVTE
"
"	Returns with lock held and async state idle
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

lock_unwired:
	push
	eppbp	ap|2,*			" bp -> ptr -> PVTE
	eppbp	bp|0,*			" bp -> PVTE

lock_unwired_retry:
	tsx7	lock_wired_wait		" Try to lock lock
	tra	lock_unwired_fails		" Didn't get it
	return				" Got it

lock_unwired_fails:
	call	pxss$wait			" Wait event already set
	tra	lock_unwired_retry		" Go for it again

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	unlock_unwired
"
"	call page$unlock_volmap (pvtep)
"
"	pvtep -> PVTE
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

unlock_unwired:
	push
	eppbp	ap|2,*			" bp -> ptr -> PVTE
	eppbp	bp|0,*			" bp -> PVTE
	tsx7	unlock_wired
	return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lock_wired_nowait
"
"	tsx7	lock_volmap$lock_wired_nowait
"	<return if failed>
"	<return if succeed>
"
"	On entry,
"	    bp -> PVTE
"
"	On return,
"	    if succeeded, then lock owned by process and async state is idle
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

lock_wired_nowait:
	increment	pvt$volmap_lock_nowait_calls
	tsx6	lock_try			" Attempt to lock
	tra	lock_wired_fails		" Failed
	tra	1,x7			" Succeeded

lock_wired_fails:
	increment	pvt$volmap_lock_nowait_fails
	tra	0,x7
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lock_wired_wait
"
"	tsx7	lock_volmap$lock_wired_wait
"	<return if failed>
"	<return if succeeded>
"
"	On entry,
"	    bp -> PVTE
"
"	On return,
"	    if succeeded, lock help by process and async state is idle
"	    if failed, appropriate wait event is in APTE, notify switch set
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

lock_wired_wait:
	increment	pvt$volmap_lock_wait_calls
	tsx6	lock_try			" Try to get lock
	tra	lock_set_wait		" Failed
	tra	1,x7			" Succeeded

lock_set_wait:
	increment	pvt$volmap_lock_wait_fails
	stq	lock_volmap_temp		" Notify switch bit
	eppap	pds$apt_ptr,*		" ap -> APTE
	sta	ap|apte.wait_event		" Set wait event

lock_wired_retry:
	ldq	bp|0,x0			" Notify switch word
	lda	bp|0,x0
	ora	lock_volmap_temp		" Set notify switch
	stacq	bp|0,x0			" Into PVTE
	tnz	lock_wired_retry		" Lost race, retry

	tsx6	lock_try			" Try again, in case race
	tra	0,x7			" Failed again
	eppap	pds$apt_ptr,*		" Got it this time, reset wait
	stz	ap|apte.wait_event
	tra	1,x7
"

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	unlock_wired
"
"	tsx7	lock_volmap$unlock_wired
"
"	On entry,
"	    bp -> PVTE
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

unlock_wired:
	ldq	pds$processid
	lda	0,dl
	stacq	bp|pvte.volmap_lock		" Unlock
	tnz	page_error$volmap_stacq_fails

	epbpap	bp|0			" ap -> PVT
unlock_wired_retry:
	ldq	ap|pvt.n_volmap_locks_held	" Meter total lock time
	tze	0,x7			" Something wrong
	lda	ap|pvt.n_volmap_locks_held
	sta	lock_volmap_temp		" Save old value
	sba	1,dl			" One fewer lock held
	stacq	ap|pvt.n_volmap_locks_held	" Update
	tnz	unlock_wired_retry		" Lost race

	ldaq	ap|pvt.last_volmap_time	" Last lock/unlock
	staq	lock_volmap_temp_1		" Save
	rccl	sys_info$clock_,*		" Current time
	staq	ap|pvt.last_volmap_time
	sbaq	lock_volmap_temp_1		" Delta
	mpy	lock_volmap_temp		" Integral
	adaq	ap|pvt.total_volmap_lock_time
	staq	ap|pvt.total_volmap_lock_time " Total integral

unlock_wired_notify_retry:
	ldq	bp|pvte.volmap_lock_notify_word " Check for notify
	lda	bp|pvte.volmap_lock_notify_word
	cana	pvte.volmap_lock_notify,dl
	tze	0,x7			" Nobody to notify
	era	pvte.volmap_lock_notify,dl	" Reset notify bit
	stacq	bp|pvte.volmap_lock_notify_word " Into PVTE
	tnz	unlock_wired_notify_retry	" Lost race

	eaa	bp|0			" PVTE offset
	arl	18			" Into AL
	epbpap	bp|0			" ap -> PVT
	ora	ap|pvt.volmap_lock_wait_constant " Event to notify

	sta	arg+4
	eppap	arg+4
	spriap	arg+2
	ldaq	notify_arg_list
	staq	arg

	call	pxss$notify(arg)

	tra	0,x7

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	lock_try
"
"	Internal procedure to attempt lock
"
"	tsx6	lock_try
"	<return if fail>
"	<return if succeed>
"
"	On entry,
"	    bp -> PVTE
"
"	On successful return,
"	    Lock help by process
"	    Async state is idle
"
"	On failure return,
"	    Areg contains wait event
"	    Qreg contains notify bit
"	    x0 is offset into PVTE of notify word
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

lock_try:
	epbpap	bp|0			" ap -> PVT
	lda	pds$processid
	cmpa	bp|pvte.volmap_lock		" MYLOCK?
	tze	page_error$volmap_mylock	" Yes

	stac	bp|pvte.volmap_lock		" Go for it
	tze	lock_try_got		" Got it
	eaa	bp|0			" AU = PVTE offset
	arl	18			" AL = PVTE offset
	ora	ap|pvt.volmap_lock_wait_constant " Areg = wait event
	ldq	pvte.volmap_lock_notify,dl	" Notify bit
	eax0	pvte.volmap_lock_notify_word	" Notify word
	tra	0,x6

lock_try_got:
	ldx0	bp|pvte.volmap_async_state
	cmpx0	VOLMAP_ASYNC_IDLE,du	" Is asynchronous state idle
	tnz	lock_try_not_idle		" No

	aos	ap|pvt.n_volmap_locks	" Meter
lock_try_retry:
	ldq	ap|pvt.n_volmap_locks_held	" Meter total lock time
	lda	ap|pvt.n_volmap_locks_held
	sta	lock_volmap_temp		" Save old value
	ada	1,dl			" One more lock held
	stacq	ap|pvt.n_volmap_locks_held	" Update
	tnz	lock_try_retry		" Lost race

	ldaq	ap|pvt.last_volmap_time	" Last lock/unlock
	staq	lock_volmap_temp_1		" Save
	rccl	sys_info$clock_,*		" Current time
	staq	ap|pvt.last_volmap_time
	sbaq	lock_volmap_temp_1		" Delta
	mpy	lock_volmap_temp		" Integral
	adaq	ap|pvt.total_volmap_lock_time
	staq	ap|pvt.total_volmap_lock_time	" Total integral
	tra	1,x6

lock_try_not_idle:
	lrl	36			" Areg = 0, Qreg = processid
	stacq	bp|pvte.volmap_lock		" Unlock
	tnz	page_error$volmap_stacq_fails	" Bad news

	eaa	bp|0			" AU = PVTE offset
	arl	18			" AL = PVTE offset
	ora	ap|pvt.volmap_idle_wait_constant " Areg = wait event
	ldq	pvte.volmap_idle_notify,dl	" Notify bit
	eax0	pvte.volmap_idle_notify_word	" Notify word
	tra	0,x6

	end




		    page.alm                        11/11/89  1105.1rew 11/11/89  0804.2       28737



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " "
"
"	page	This program is a transfer vector to the various
"		component procedures referenced as entries to 'page'.
"
"		All transfers are made to 'segdef'ed locations in
"		the component procedures.
"
" " " " " " " " " " " " " " " " " " " " " "

"	Last Modified (Date and Reason)
"
"	Modified 4/8/74 by S.H.Webber as part of merging unprivileged
"	   and privileged code of pc
"	Modified 6/10/74 by B. Greenberg for accessible lock/unlock and cam,
"	   and also iobm
"	Modified 5/3/77 by B. Greenberg for macro alm.
"	Deleted unload_old_process, RE Mullen 5/16/77
"	Modified 01/24/81, J. Bongiovanni, for new cam
"	Modified 03/29/81, W. Olin Sibert, for conditional Page Multi-level
"	Modified 03/07/82, J. Bongiovanni, to remove PML and for record stocks
"	Modified 07/28/82, J. Bongiovanni, for scavenger side-door
"	Modified 831219, E. N. Kittlitz, for pc withdraw side-door

	name	page

	macro	pagentry
	entry	&1
&1:
	tra	&2

	&end

	pagentry	cam_wait,cam_cache$cam_with_wait_ext
	pagentry	cam,cam_cache$cam_ext
	pagentry	cam_cache,cam_cache$cam_cache_ext
	pagentry	cam_ptws,cam_cache$cam_ptws_ext
	pagentry	deposit,free_store$deposit
	pagentry	deposit_list,free_store$deposit_list
	pagentry	done,page_fault$done
	pagentry	drain_record_stock,volmap$drain_stock
	pagentry	enter_data,page_fault$enter_data
	pagentry	esd_reset,device_control$esd_reset
	pagentry	evict,evict_page$evict
	pagentry	fault,page_fault$fault
	pagentry	free_address_for_scavenge,volmap_util$free_address_for_scavenge
	pagentry	grab_volmap_page_unwired,volmap_page$grab_volmap_page_unwired
	pagentry	init,device_control$init
	pagentry	lock_ptl,page_fault$lock_ptl_ext
	pagentry	lock_volmap,lock_volmap$lock_unwired
	pagentry	pcleanup,page_fault$pcleanup
	pagentry	poll_volmap_io,volmap_page$poll_io
	pagentry	post_purge,post_purge$post_purge
	pagentry	pre_page_info,page_fault$pre_page_info
	pagentry	pread,page_fault$pread
	pagentry	pwait,device_control$pwait
	pagentry	pwrite,page_fault$pwrite
	pagentry	reset_pvte,volmap$reset_pvte
	pagentry	reset_working_set,page_fault$reset_working_set
	pagentry	thread_to_lru,page_fault$thread_lru_ext
	pagentry	time_out,device_control$time_out
	pagentry	trace_marker,page_fault$trace_marker
	pagentry	unlock_ptl,page_fault$unlock_ptl_ext
	pagentry	unlock_volmap,lock_volmap$unlock_unwired
	pagentry	wire_abs,evict_page$wire_abs
	pagentry	withdraw_list,free_store$withdraw_list_ext
	pagentry	withdraw_range,stock$withdraw_range_ext
	pagentry	write_volmap_page_unwired,volmap_page$write_volmap_page_unwired


	end




		    page_error.alm                  11/11/89  1105.1r w 11/11/89  0804.3      280863



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(86-05-13,GJohnson), approve(86-05-13,MCR7387),
"     audit(86-05-13,Martinson), install(86-05-14,MR12.0-1056):
"     Correct error message documentation.
"  2) change(86-05-29,Fawcett), approve(86-04-11,MCR7383),
"     audit(86-06-11,Coppola), install(86-07-17,MR12.0-1097):
"     Add subvolume to error messages.
"  3) change(87-02-18,Lippard), approve(87-03-16,MCR7640),
"     audit(87-06-17,Farley), install(87-07-17,MR12.1-1043):
"     Added entry to crash system on finding invalid volmap words (fix by
"     Swenson).
"                                                      END HISTORY COMMENTS

" " " " " " " " " " " " " " " " " " " " " " " "
"
"	page_error	this procedure contains the code for outputing
"			error messages that are generated by the machine
"			language parts of page control.
"
"	First coded by Webber at time immemorial.
"	Modified for NSS by B. Greenberg '75
"	Mexped by VanVleck, with Greenberg, 2/77,3/77
"	Macro ALM and declaration macrology by BSG 5-6/77
"	Interpreter by BSG 7/17/77
"	Modified for stock, -PML by J. Bongiovanni February 1982
"	Modified to move core map by E. N. Kittlitz June 1982
"	Modified for scavenger, J. Bongiovanni, August 1982
"	Modified for page_synch, J. Bongiovanni, October 1982
"	Delete sst include file, Benson Margulies, January 1984
"	Added covert channel audit message, Keith Loepere, January 1985.
"	Converted to access_audit_bin_header, Keith Loepere, January 1985.
"	Modified to use syserr_constants, syserr_mmdam_msg,
"			and segdamage_msg incls, EJ Sharpe, March 1985
"	Modified to print the subvolume with the driveno for syserr,
"		          R. A. Fawcett, July 1985
"
" " " " " " " " " " " " " " " " " " " " " " " "

" GENERAL STRATEGY:

"	First, we "adjust" pxss_page_stack to look like the TSX that
"	     got us here did a PL/I "call" to page_error, but _w_e save all his
"	     registers for him at sp|0 and sp|32 (decimal).
"	While running in pxss_page_stack we copy anything we want into "arg".
"	Then we do a push to new (upper) frame.
"	Here we set up an arg list and call syserr.
"	Then we pop up to the pxss_page_stack frame and return,

"	     reloading his registers from the pxss_page_stack frame first.
"
"	Interpreter strategy:
"
"	Maximum code condensation of arglist preparation is achieved by
"	coding 1 word per arglist element. Tsx7 to "interpreter"
"	builds all of syserr arg list from arg "n" on in a "k" arg list:
"
"	tsx7	interpreter
"	zero	endl,2*n
"	zero	k,4
"	arg_n_description
"	arg_n_plus_1_description
"	...
"	arg_k_description
"endl:

"	description is 2 halfwords, first specifies arg addr,
"	second descriptor addr. Address for data is negative if
"	offset into pxss_page_stack, + if text. Descr. addr is always text.

"
"	How to use the page_error programming language.
"
"	This macrology enables the maintainter of page_error to generate
"	calls to syserr and syserr$binary with a maximum of ease. A typical
"	call to syserr is written like this:
"
"	call_syserr	1,(page_fault: this and that ^o for ^a),devadd,drivename
"
"	being equivalent to
"
"	call syserr (1, "page_fault: this and that ^o for ^a", devadd, drivename)
"
"	in PL/1. The ioa_arguments must be "declared" by the dcl or dclfix
"	macros. Usage is:
"
"	dcl	drivename,arg+18,char,4
"
"	meaning
"
"	dcl drivename char (4) based (addr (arg)+18), so to speak.
"
"	1st arg is variable name, second is location, which must be in pxss_page_stack,
"	3rd is data type (only char, fixed, ptr, bit provided now), 4th is precision, default 17.
"
"	dclfix declares something by its own name as fixed bin (17).

"	1st argument to call_syserr (or call_syserr_binary) is interpreted as being an offset
"	in pxss_page_stack if not a numeric literal.
"
"	call_syserr_binary 1,(arg+4,*),syserr_binary_code,opt_subr,(ctrlstring),args...
"
"	is similar. 2nd arg is DATA address- pointer developed from it. 3rd arg is suffix
"	in syserr_binary_def.incl.alm (i.e., xx for SB_xx, SBL_xx). opt_subr is the name
"	of a subroutine to be called by macro in new frame (currently only gseg_info).
"	Omit (,,) in other cases. gseg_info formats up seg-id type message, incrs.
"	sst$damaged_ct.
"
"
"	Declaration/arglist macrology.
"

	macro	dcl	    "dcl  symbol,address(rel to U),type{,prec}
	maclist	off,save
	macro	iword_&1
	zero	-(&2),=v1/1,6/&3,17/0,12/&=&4,&[17&;&4&]
	&&end
	maclist	restore
	&end

	macro	dclfix
	maclist	off,save
&R&(	dcl	&i,&i,fixed
&)	maclist	restore
	&end

	macro	message
&1.msg:aci   "&2"
&1.dsc:	vfd	1/1,6/char,1/0,4/0,24/&l2
	&end


	macro	call_syserr

	new_frame

	tsx7	interpreter
	zero	*+2+&K,2
	zero	2*&K,4

	ifint	&1
	zero	=&1,fx
	ifend
	inint	&1
	zero	-(&1),fx
	ifend

	zero	&U.msg,&U.dsc
&R3&(	iword_&i
&)
	tra	csys

	message	&U,(&2)
	&end

	macro	call_syserr_binary

	new_frame

	ine	&4,()
&(4	tsx7	&i
&)
	ifend

	ifint	&1
	eppap	=&1
	ifend
	inint	&1
	eppap	&1
	ifend
	spriap	sp|syserr_arg_list+2

	tsx7	interpreter
	zero	*+2+&K-2,6
	zero	2*&K,4

	zero	&U.sbc,fx
	zero	&U.sbl,fx
	zero	&U.msg,&U.dsc
&R6&(	iword_&i
&)
	eppap	&2
	tsx7	binary_setup
			"no return

&U.sbc:	vfd	36/SB_&3
&U.sbl:	vfd	36/SBL_&3

	message	&U,(&5)
	&end

	macro	savexx	savexx	regname
	stcd	sp|stack_frame.return_ptr bound_page_control
	spri	sp|0
	sreg	sp|32
	ine	&1,none
	stx	&1,sp|stack_frame.return_ptr+1
	ifend
	ife	&1,none
	stc1	sp|stack_frame.return_ptr+1	set loop message
	ifend
	&end

	macro	new_frame
	push	syserr_arg_list+frame_size
	epp	U,sp|stack_frame.prev_sp,*
	&end

"

"
"	Sundry	assembler declarations
"

	name	page_error
	segdef	bad_device_id
	segdef	device_error,out_of_core,ptl_mylock
	segdef	zeroing_page
	segdef	error_in_done
	segdef	out_of_hc_part
	segdef	page_fault_error,non_fatal_error
	segdef	page_move_parity,wired_parity_error,reverting_page,deleting_mm_frame
	segdef	volmap_async_error,deposit_invalid_addtype,stock_out_of_synch
	segdef	invalid_deposit_list_args,address_out_of_range
	segdef	volmap_stacq_fails,volmap_mylock,deposit_zero_address
	segdef	volmap_inconsistent,stock_inconsistent,ptl_not_locked
	segdef	wrong_async_state,volmap_page_async_error,volmap_page_invalid_call
	segdef	deposit_inuse_address,bad_volmap_address,volmap_io_error,poll_state_change
	segdef	scav_stacq_fails
	segdef	no_free_dm_entries,dm_journal_seg_problem
	segdef	excessive_seg_state_chg
	segdef	invalid_volmap_word

	equ	dcb,2
	equ	mbx,5
	equ	bsd,3


	equ	U,2		Use bp to point at pxss_page_stack frame

	equ	syserr_arg_list,40	The whole upper frame is arglist.
	equ	frame_size,8*16
	equ	binary_buffer,6*16

"
"	Declarations of variables for above macros
"


	dclfix	devadd,pvtx,core_add

	dcl	argf,arg,fixed
	dcl	a1char,arg+1,char,1
	dcl	a1f,arg+1,fixed
	dcl	t1f,temp+1,fixed
	dcl	ctrlrtag,temp,char,1
	dcl	a2f,arg+2,fixed
	dcl	a3f,arg+3,fixed
	dcl	a4f,arg+4,fixed
	dcl	a5f,arg+5,fixed

	dcl	devname,arg,char,4
	dcl	driveno,arg+1,char,4

	dcl	pvtep,arg+6,ptr
	dcl	stockp,arg+8,ptr

	dcl	person,arg,char,32
	dcl	categories,arg+8,bit,18
	dcl	level,arg+9,fixed

bad_device_id:
	savexx	none		TRA from device_control

	call_syserr 1,(device_control: invalid pvtx ^w),pvtx

csys:	call	syserr$syserr(sp|syserr_arg_list)

" now we are on the upper frame. Get back.

exit:	epbpsb	sp|0		inline pop
	eppbp	sp|stack_frame.prev_sp,*
	inhibit	on
	sprisp	sb|stack_header.stack_end_ptr
	lpri	bp|0
	inhibit	off
	lreg	sp|32
	rtcd	sp|stack_frame.return_ptr	return to alm code

" 

out_of_hc_part:
	savexx	none		TRA from free_store

	call_syserr 1,(free_store: out of of room in hardcore partition.)
" 

zeroing_page:
	savexx	.ret
	lda	1,dl		set entry sw
	tra	zpag_rpag_merge

reverting_page:
	savexx	.ret
	lda	2,dl
zpag_rpag_merge:
	sta	temp+1

	tsx7	get_ast_params
	tsx7	get_pageno
	lda	arg+18

	tsx0	setup_pvtname

	call_syserr_binary 0,sp|binary_buffer,zerpag,gseg_info,
	     (page_fault: ^[Zeroing^;Reverting^] page on ^a_^a),t1f,devname,driveno


"
deleting_mm_frame:
	savexx	.ret
	tsx0	setup_controller
	call_syserr_binary 3,sp|binary_buffer,mmdam,movemm,
		(page_fault: Deleting main memory at ^o, SCU ^a, due to parity errors.),core_add,ctrlrtag

"
page_move_parity:
	savexx	.ret
	lda	0,dl		info code
	tra	evpp_merge

wired_parity_error:
	savexx	none		fatal
	lda	1,dl
evpp_merge:
	sta	temp+1
	tsx0	setup_controller
	tsx7	get_ast_params
	tsx7	get_pageno
	lda	arg+18
	tsx0	setup_pvtname

	call_syserr_binary temp+1,sp|binary_buffer,random_segdamage,gseg_info,
	     (evict_page: ^[fatal ^]parity error moving page, frame at ^o, SCU ^a),
	     t1f,core_add,ctrlrtag

" 


page_fault_error:
	savexx	none		TSX6 from page_fault, don't go
	lda	=1,dl		function
	ldq	=1,dl		crash code
	tra	pferr.join
non_fatal_error:
	savexx	.2ret		TSX6 from page_fault
	lda	=2,dl		function
	ldq	=0,dl
pferr.join:
	sta	arg
	stq	arg+1
	stz	arg+2		x5 has loc in page_fault
	sxl5	arg+2

	call_syserr arg+1,(page_fault: ^[^;non^]fatal error at loc ^o),argf,a2f

"

error_in_done:
	savexx	none		TZE from page_fault
	stz	arg
	sxl	.ptw,arg		ptr to ptw

	call_syserr 1,(page_fault: fatal error in done, ptp ^o),argf
" 

out_of_core:
	savexx	none		TPL from page_fault

	call_syserr 1,(page_fault: out of main memory)
" 


ptl_mylock:
	savexx	none		TZE from page_fault

	call_syserr 1,(page_fault: mylock on global lock)
" 

device_error:
	savexx	.2ret		TSX6 from page_fault
	lda	=1	"ECCH"	
	sta	arg+2
	lda	ast|aste.pvtx_word,.aste
	arl	aste.pvtx_shift
	ana	aste.pvtx_mask,dl
deverr.got_pvtx:
	tsx0	setup_pvtname

	call_syserr_binary 1,U|arg+18,read_nc,gseg_info,
	     (page_fault: device read not complete ^a_^a ^w),
	     devname,driveno,devadd
" 
volmap_async_error:
	savexx	none
	lda	pvtx
	tsx0	setup_pvtname
	call_syserr 1,(free_store: volmap_seg async error for ^a_^a),devname,driveno

deposit_invalid_addtype:
	savexx	none
	sta	devadd
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(free_store: Deposit non-disk address ^w on ^a_^a),devadd,devname,driveno

address_out_of_range:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(free_store: Deposit/withdraw address ^w out of paging region on ^a_^a.),devadd,devname,driveno

stock_out_of_synch:
	savexx	none
	spribp	arg+6
	spribb	arg+8
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(free_store: PVTE/Stock out of synch on ^a_^a. stockp=^p.),devname,driveno,stockp

invalid_deposit_list_args:
	savexx	none
	call_syserr 1,(free_store: Invalid call to free_store$deposit_list.)
scav_stacq_fails:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(free_store: Scavenger STACQ fails on ^a_^a.),devname,driveno

no_free_dm_entries:
	savexx	none
	call_syserr 1,(page_synch: Out of free entries in dm_journal_seg_.)

dm_journal_seg_problem:
	savexx	none
	call_syserr 1,(page_synch: dm_journal_seg inconsistent.)
" 
volmap_stacq_fails:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(lock_volmap: STACQ fails on ^a_^a.),devname,driveno

volmap_mylock:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(lock_volmap: MYLOCK on volmap lock for ^a_^a.),devname,driveno

" 
deposit_zero_address:
	savexx	none
	call_syserr 1,(stock: deposit zero address.)

" 
volmap_inconsistent:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(volmap: Volume Map inconsistent on ^a_^a.),devname,driveno

invalid_volmap_word:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(volmap: Invalid volume map word on ^a_^a.),devname,driveno

stock_inconsistent:
	savexx	none
	spribp	arg+6
	spribb	arg+8
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(volmap: record stock inconsistent on ^a_^a. stockp=^p.),devname,driveno,stockp

deposit_inuse_address:
	savexx	.ret
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep


	call_syserr 0,(volmap: Attempt to deposit in-use address ^o on ^a_^a.),devadd,devname,driveno

bad_volmap_address:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(volmap: Invalid Volume Map address computation for ^o on ^a_^a.),devadd,devname,driveno

"
ptl_not_locked:
	savexx	none
	call_syserr 1,(volmap_page: PTL not locked to process.)

wrong_async_state:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(volmap_page: Invalid async state on ^a_^a.),devname,driveno

volmap_page_async_error:
	savexx	none
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 1,(volmap_page: Async error for ^a_^a.),devname,driveno

volmap_page_invalid_call:
	savexx	none
	call_syserr 1,(volmap_page: Invalid call.)

volmap_io_error:
	savexx	.ret
	sta	arg+2		Page number
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 3,(volmap_page: Unrecoverable I/O error on Volmap page ^d of ^a_^a. Addresses lost.),a2f,devname,driveno


poll_state_change:
	savexx	.ret
	stz	arg+2
	ldx1	bp|pvte.volmap_async_state
	sxl1	arg+2		New async state
	spribp	arg+6
	tsx0	setup_pvtname_from_pvtep
	call_syserr 4,(volmap_page: Async state on ^a_^a changed to ^d on poll.),devname,driveno,a2f

" 

excessive_seg_state_chg:
	savexx	.2ret		" tsx	.2ret from page_fault

	epp	U,pds$process_group_id
	mlr	(pr),(pr)		" copy process_group_id
	desc9a	U|0,32
	desc9a	arg,32		" (person)

	ldaq	pds$access_authorization
	qrl	18		" level to lower half
	staq	arg+8
	
	call_syserr_binary 24,sp|binary_buffer,covert_seg_state,covert_audit_info,
	     (AUDIT (page_fault): GRANTED excessive segment state changes (Moderate_cc) for ^a (^o:^.3b).),person,level,categories
" 

" " " " " " " " " " " " " " " " " " " " " " "
"				    "
"	Subroutines		    "
"				    "
" " " " " " " " " " " " " " " " " " " " " " "

get_pageno:			"Given astep, ptp, get pageno into
				"arg+20 upper
	eax0	-aste_size,.ptw
	stx	.aste,arg+20
	sblx0	arg+20
	stx0	arg+20
	tra	0,7		no ssx0 cause top bit oflw

get_ast_params:			"Get uid, vtocx, pvtx.
	lda	ast|aste.uid,.aste	get uid
	sta	arg+21
	tze	get_ast_params.zuid wie noord

	lda	ast|aste.vtocx,.aste
	ana	-1,dl
	tra	get_ast_params.gotvx

get_ast_params.zuid:
	lca	1,dl
get_ast_params.gotvx:
	sta	arg+20

	lda	ast|aste.pvtx_word,.aste
	arl	aste.pvtx_shift
	ana	aste.pvtx_mask,dl
	sta	arg+18		"Leave this in A reg.
	tra	0,7

"

setup_controller:
	lda	page_fault$cme_flags,*.cme get controller
	ana	cme.contr,dl	controller used here
	als	36-9
	adla	=aA   "		Ascii A
	sta	temp
	tra	0,0

setup_pvtname_from_pvtep:			"s/r to address printable pv name
	eppap	arg+6,*
	tra	setup_pvtname.pvtep

setup_pvtname:				"s/r to address printable pv name
	eaq	0,al
	mpy	pvte_size,dl
	eppap	pvt$array
	eppap	ap|-pvte_size,qu		address right pvte
setup_pvtname.pvtep:
	ldq	ap|pvte.logical_area_number_word
	qrl	pvte.logical_area_number_shift
	anq	pvte.logical_area_number_mask,dl
	stq	arg+18
	btd	(pr),(pr)
	desc9a	arg+18,4
	desc9ls	arg+19,3,0
	stz	arg+1
	mvne	(pr),(),(pr)
	desc9ls	arg+19,3,0
	desc9a	microp,2
	desc9a	arg+1,2
	mlr	(pr),(pr)
	desc9a	ap|pvte.sv_name,2
	desc9a	arg+1(2),2
	lda	ap|pvte.devname
	sta	arg
	lda	ap|pvte.pvid
	sta	arg+18
	lda	ap|pvte.lvid
	sta	arg+19
	tra	0,0

microp:
	oct	070322000000		" ses ON, mvc 2
"
" " " " " " " " " " " " " " " " " " " " " " "
"				    "
"	Arglist interpreter		    "
"				    "
" " " " " " " " " " " " " " " " " " " " " " "

interpreter:
	lda	1,7		get 2*argct with 4
	eaq	0,au
	staq	sp|syserr_arg_list

	eax6	2,7		point at arg
	lxl1	0,7		offset to first unprocessed
	eax1	syserr_arg_list+0,1
	eax2	0,1
	adlx2	1,7		-> descs

interp.list:
	cmpx6	0,7		end of list?
	tze	0,6		wham

	lda	0,6
	eppap	0,al		-> desc
	spriap	sp|0,2
	eaa	0,au
	tpl	int.txt
	neg	0
	eppap	U|0,au		-> stack arg
	tra	*+2
int.txt:	eppap	0,au		address text
	spriap	sp|0,1

	eax1	2,1
	eax2	2,2
	eax6	1,6		interp pc
	tra	interp.list

binary_setup:
	spriap	sp|binary_buffer+22
	eppap	sp|binary_buffer+22
	spriap	sp|syserr_arg_list+2*2
	ldx1	sp|syserr_arg_list
	eppap	ptrd
	spriap	sp|syserr_arg_list+2+2,1
	tra	bincall

bincall:	call	syserr$binary(sp|syserr_arg_list)
	tra	exit

"
"
"	New-frame subroutines
"

gseg_info:
format_segdamage_binary:
"
"				First copy UIDs from AST, right-justified.
	mlr	(pr),(pr)
	desc9a	U|arg+18,4*4
	desc9a	sp|binary_buffer+segdamage.pvid,4*4	"lvid immediately follows pvid
	aos	sst$damaged_ct	trigger aswering service
	eax4	16		assume no more stuff if lossage
	eax5	0		fill from 0 if lossage
	lxl2	U|arg+20		have vtocx?
	tmi	gup.fillup3	no, put in zeros

	lxl3	U|32+1		x3 from saved regs
	lxl3	ast|aste.par_astep,3 check  par
	tze	gup.fillup3	c/b root!
	eax4	15		set to last uid word
gup.lp1:	lda	ast|aste.uid,3
	sta	sp|binary_buffer+segdamage.uid_path,4	store in array
	lxl3	ast|aste.par_astep,3	loop up
	tze	gup.fillup	thats all on this end
	eax4	-1,4		count level
	tpl	gup.lp1		normal case
	eax4	1,4		only if busted, do this.

"				Now left-justify them, pad with zeros.
gup.fillup:
	eax5	0		destination of  move
gup.fillup1:
	lda	sp|binary_buffer+segdamage.uid_path,4	get put word
gup.fillup2:
	sta	sp|binary_buffer+segdamage.uid_path,5	store in new place
	eax5	1,5		new target
	eax4	1,4		new source
	cmpx4	16,du		ready to do over end?
	tmi	gup.fillup1	no, do next word
gup.fillup3:
	lda	0,dl		pad out zeros
	cmpx5	16,du		gonna store over end?
	tmi	gup.fillup2	no, go store zero
	tra	0,7		good luck.


movemm:				"Get main mem lossage parms
	lda	U|core_add
	ldq	U|temp		abcd etc
	staq	sp|binary_buffer+mmdam_msg.addr	"ctrltag immediately follows addr
	tra	0,7

	even
devadd_to_20:
	lda	devadd
	sta	arg+20

devadd_to_buf20:
	lda	U|devadd
	sta	sp|binary_buffer+20
	tra	0,7
"
covert_audit_info:
	mlr	(),(pr)			" zero all first
	desc9a	0,0
	desc9a	sp|binary_buffer,4*audit_head_size

	bool	period,056000

	scm	(pr),(du)			" take apart process_group_id
	desc9a	U|arg,32
	desc9a	period,1			" period
	arg	sp|binary_buffer

	lda	sp|binary_buffer		" lth of person
	mlr	(pr,rl),(pr),fill(040)
	desc9a	U|arg,al
	desc9a	sp|binary_buffer+audit_head.person,22

	ada	1,dl			" pt at project
	scm	(pr,al),(du)
	desc9a	U|arg,32
	desc9a	period,1			" period
	arg	sp|binary_buffer

	lxl3	sp|binary_buffer
	mlr	(pr,rl,al),(pr),fill(040)
	desc9a	U|arg,x3
	desc9a	sp|binary_buffer+audit_head.person+5(2),9

	ada	sp|binary_buffer
	ada	1,dl
	mlr	(pr,al),(pr)
	desc9a	U|arg,1
	desc9a	sp|binary_buffer+audit_head.person+7(3),1

	lda	ARH_NO_PROXY,dl
	als	audit_head.type_shift-audit_head.version_shift
	ada	ACCESS_AUDIT_HEADER_VERSION_3,dl
	als	audit_head.version_shift
	ora	audit_head.subj_process,dl
	sta	sp|binary_buffer+audit_head.version

	lda	sst$seg_state_chg_operation
	sta	sp|binary_buffer+audit_head.operation_code

	lda	audit_event_flags.grant+audit_event_flags.cc_10_100,du
	sta	sp|binary_buffer+audit_head.event_flags

	lda	pds$process_id
	sta	sp|binary_buffer+audit_head.process_id

	ldaq	pds$access_authorization
	staq	sp|binary_buffer+audit_head.authorization
	staq	sp|binary_buffer+audit_head.max_authorization	" pds$max_auth is not wired
	tra	0,7
"
" " " " " " " " " " " " " " " " " " " "
"
"	constants and descriptors
"
" " " " " " " " " " " " " " " " " " " "

fx:	vfd	1/1,6/fixed,1/0,4/0,12/0,12/35
ptrd:	vfd	1/1,6/ptr,1/0,4/0,24/0

	equ	ptr,13
	equ	fixed,1
	equ	char,21
	equ	bit,19
"
	include	access_audit_eventflags
	include	access_audit_bin_header
	include	aste
	include	cmp
	include	page_info
	include	page_regs
	include	pvte
	include	pxss_page_stack
	include	stack_frame
	include	stack_header
	include	syserr_constants
	equ	SYSERR_COVERT_CHANNEL_LOG,SYSERR_COVERT_CHANNEL+LOG
	include	syserr_mmdam_msg
	include	segdamage_msg
	include	syserr_binary_def
	equ	SB_covert_seg_state,SB_access_audit
	equ	SBL_covert_seg_state,audit_head_size
"
"BEGIN MESSAGE DOCUMENTATION

"	Message:
"	device_control: invalid pvtx XX

"	S:	$crash

"	T:	$run

"	M:	An invalid PVT index XX was found by device control,
"	or an invalid device type appeared in the PVT entry of that index.
"	$err

"	A:	$recover


"	Message:
"	free_store: out of room in hardcore partition.

"	S:	$crash

"	T:	$run

"	M:	During bootload, the PART HC on the RLV became full.
"	$err

"	A:	$recover
"	It may be necessary to boot with another tape.
"	If this error occurs with a new version of the system boot tape,
"	the system programming staff may determine that the size of the
"	hardcore partition must be increased by using the
"	rebuild_disk command on a copy of the RPV.


"	Message:
"	page_fault: Zeroing page on DSKX_NN{S}

"	S:	$info

"	T:	$run

"	M:	A segment residing on DSKX_NN{S}
"	has been damaged due to a device error.
"	The segment damaged switch is set and a page of zeros is introduced
"	into the segment.
"	Subsequent user processes attempting to use this segment will
"	receive an error indication.
"	Binary information identifying the damaged segment is encoded into
"	this message for subsequent automatic processing. The pathname
"	of the damaged segment will appear in a message in the answering
"	service log, bearing the syserr_log sequence number of this
"	message, shortly after this message occurs.

"	A: Attempt to identify the damaged segment, and
"	inform its owner.


"	Message:
"	page_fault: fatal error at loc AAAA

"	S:	$crash

"	T:	$run

"	M:	$err

"	A:	$recover


"	Message:
"	page_fault: nonfatal error at loc AAAA

"	S:	$info

"	T:	$run

"	M:	$err
"	The system attempts to keep running.

"	A:	$ignore


"	Message:
"	page_fault: device read not complete DSKX_NN{S} DDDD

"	S:	$crash

"	T:	$run

"	M:	This message is used for program debugging only.

"	A:	$recover
"	$inform


"	Message:
"	page_fault: fatal error in done, ptp ZZZZ

"	S:	$crash

"	T:	$run

"	M:	While posting an I/O completion,
"	the system found a page table pointer of zero,
"	or found that the page was not out of service.
"	$err

"	A:	$recover


"	Message:
"	page_fault: mylock on global lock

"	S:	$crash

"	T:	$run

"	M:	When page_fault attempted to lock the global
"	page control lock, it found it already locked to the same process.
"	$err

"	A:	$recover


"	Message:
"	page_fault: out of main memory

"	S:	$crash

"	T:	$run

"	M:	The page removal algorithm was unable to
"	find a removable page. Incorrect system programmer action,
"	damage to the AST, or an error in the
"	supervisor or the hardware could cause this symptom.

"	A:	$recover


"	Message:
"	page_fault: Reverting page on DSKX_NN{S}

"	S:	$info

"	T:	$run

"	M:	A segment residing on DSKX_NN{S} has had one of its
"	pages reverted to an earlier copy of the same page.  The damaged switch
"	is set.  This can happen due to device error or main memory errors.
"	Subsequent user processes attempting to use this segment
"	will receive an error indication.  Binary information
"	identifying the damaged segment is encoded into this message for
"	subsequent automatic processing.  The pathname
"	of the damaged segment will appear in a message in the answering
"	service log, bearing the syserr log sequence number
"	of this message, shortly after this message occurs.

"	A: Attempt to identify the damaged segment and inform its owner.


"	Message:
"	page_fault: Deleting main memory at AAAA, SCU TAG,
"	due to parity errors.

"	S: $beep

"	T: $run

"	M: Due to main memory parity errors, the system is automatically
"	removing a page of main memory from the memory in SCU TAG,
"	preventing further use during this bootload.

"	A: Inform Field Engineering personnel about possible
"	problems with this SCU.


"	Message:
"	evict_page: parity error moving page, frame at AAA, SCU TAG.

"	S: $info

"	T: $run

"	M: A parity error was encountered while moving a page within
"	main memory.  This may occur as part of an attempt to delete that
"	main memory, or use it as an I/O buffer.

"	A: Inform Field Engineering personnel about possible problems
"	with this SCU.


"	Message:
"	evict_page: fatal parity error moving page, frame at AAA, SCU TAG.

"	S: $crash

"	T: $run

"	M: A parity error was encountered while moving a wired page
"	around memory.  The page may not be usable.

"	A: Contact Field Engineering personnel about possible
"	problems with SCU TAG.
"	$recover


"	Message:
"	free_store: volmap_seg async error for dskX_NN{S}

"	S:	$crash

"	T:	$run

"	M:	When attempting to write a page of the Volume Map
"	to dskX_NN{S}, the page was found not to be in memory. This
"	probably indicates a software error.

"	A:	$recover


"	Message:
"	free_store: Deposit non-disk address XXXXXXXXXXXX on dskX_NN{S}

"	S:	$crash

"	T:	$run

"	M:	free_store was called to return an address to the free
"	pool for dskX_NN{S}, but the address type was not disk. This probably
"	indicates a software error.

"	A:	$recover


"	Message:
"	free_store: Deposit/withdraw address XXXXXX out of paging region on dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	Address XXXXXX was being deposited to or wtihdrawn from
"	the pool of free addresses for dskX_NN{S}, but the address is not
"	within the Paging Region for the device. This probably indicates
"	a software error.

"	A:	$recover


"	Message:
"	free_store: PVTE/Stock out of synch on dskX_NN{S}. stockp=YYY|YYYYY.

"	S:	$crash

"	T:	$run

"	M:	The PVTE and record stock for dskX_NN{S} do not point to
"	each other. This indicates a hardware or software error.

"	A:	$recover


"	Message:
"	free_store: Invalid call to free_store$deposit_list.

"	S:	$crash

"	T:	$run

"	M:	free_store$deposit_list was called with the wrong
"	number of arguments. This is a software error.

"	A:	$recover


"	Message:
"	free_store: Scavenger STACQ fails on dskX_NN{S}.

"	S:	$crash

"	T:	During a physical volume scavenge of dskX_NN{S}.

"	M:	A STACQ instruction, used to unlock a record address
"	during a volume scavenge, did not operate correctly. This indicates
"	processor or memory malfunction.

"	A:	$recover


"	Message:
"	lock_volmap: STACQ fails on dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	The stacq instruction, used to lock the Volume Map on
"	dskX_NN{S}, did not operate correctly. This indicates processor or
"	memory malfunction.

"	A:	$recover


"	Message:
"	lock_volmap: MYLOCK on volmap lock for dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	A process attempted to lock the Volume Map lock for
"	dskX_NN{S} while already owning the lock. This indicates a software
"	malfunction.

"	A:	$recover


"	Message:
"	stock: deposit zero address.

"	S:	$crash

"	T:	$run

"	M:	An attempt was made to deposit address zero into a record
"	stock. This is an invalid address, and it indicates hardware or
"	software failure.

"	A:	$recover


"	Message:
"	volmap: Volume Map inconsistent on dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	An attempt to withdraw a disk address from the pool of
"	free addresses on dskX_NN{S} failed, although the control structures
"	describing the Volume Map indicated that addresses were available.
"	This indicates hardware or software failure.

"	A:	$recover


"	Message:
"	volmap: Invalid volume map word on dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	An attempt to withdraw a disk address from the pool of
"	free addresses on dskX_NN{S} resulted in finding a volume map word
"	with at least one of bits 0, 33, 34, and 35 on.  These bits are
"	invalid for volume map words.  This indicates hardware or
"	software failure.

"	A:	Perform an ESD.  Reboot the system and perform a
"	volume salvage (not a scavenge) of the disk volume dskX_NN{S}.
"	This may be performed at Initializer ring-1 or ring-4 command
"	level.  Perform the salvage before adding the storage system
"	volume back to the system.  The volume scavenger will not
"	detect volume map words with invalid bits enabled, so the
"	salvager must be used.  Once the salvage is complete, the
"	volume may be added back to the system.


"	Message:
"	volmap: record stock inconsistent on dskX_NN{S}. stockp=YYY|YYYYY.

"	S:	$crash

"	T:	$run

"	M:	An attempt to deposit a record address from the Volume
"	Map to the record stock failed unaccountably. This indicates
"	probably software failure.

"	A:	$recover


"	Message:
"	volmap: Attempt to deposit in-use address YYYYYY on dskX_NN{S}.

"	S:	$info

"	T:	$run

"	M:	An attempt was made to return disk address YYYYYY to the free
"	pool on dskX_NN{S}, but the address was already marked as free. This indicates
"	damage of some sort to the Volume Map. This damage can be repaired
"	by a volume salvage.

"	A:	$inform


"	Message:
"	volmap: Invalid Volume Map address computation for YYYYYY on dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	In attempting to place the disk address YYYYYY into the
"	free pool for dskX_NN{S}, an error occurred in translating the address
"	into a location within the Volume Map.  This indicates a software
"	error.


"	Message:
"	volmap_page: PTL not locked to process.

"	S:	$crash

"	T:	$run

"	M:	An entry in volmap_page was called which required that
"	the Global Page Table lock be held by the calling process. It
"	was not held by that process, indicating software failure.

"	A:	$recover


"	Message:
"	volmap_page: Invalid async state on dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	An inconsistency was discovered in the asynchronous
"	update state of the Volume Map on dskX_NN{S}. This is likely a
"	software error.

"	A:	$recover


"	Message:
"	volmap_page: Async error for dskX_NN{S}.

"	S:	$crash

"	T:	$run

"	M:	When attempting to write an updated page of the Volume Map
"	on dskX_NN{S}, it was found not to be in memory. This indicates a
"	software failure.

"	A:	$recover

"	Message:
"	volmap_page: Invalid call.

"	S:	$crash

"	T:	$run

"	M:	One of the conditions required for a call to a volmap_page
"	entry point was not present. This indicates a software failure in
"	the caller of volmap_page.

"	A:	$recover


"	Message:
"	volmap_page: Unrecoverable I/O error on Volmap page M of dskX_NN{S}. Addresses lost.

"	S:	$beep

"	T:	$run

"	M:	There was an unrecoverable I/O on a page of the Volume Map,
"	which describes free records on the volume. As a result, all free
"	records described by that page of the Volume Map have been lost.

"	A:	It may be possible to recover the lost addresses by a 
"	volume salvage. However, a hard device error will prevent the volume
"	salvage from succeeding. In this case, it will be necessary
"	to recover the volume to a good pack.


"	Message:
"	volmap_page: Async state on dskX_NN{S} changed to S on poll.

"	S:	$log

"	T:	$run

"	M:	An interrupt for a volume map I/O was lost and was
"	recovered by a periodic polling routine.

"	A:	$ignore


"	Message:
"	page_synch: Out of free entries in dm_journal_seg_.

"	T:	$run

"	S:	$crash

"	M:	$err

"	A:	$recover


"	Message:
"	page_synch: dm_journal_seg_ inconsistent.

"	T:	$run

"	S:	$crash

"	M:	$err

"	A:	$recover


"	Message:
"	AUDIT (page_fault): GRANTED excessive segment state changes 
"	(Moderate_cc) for PROCESS_GROUP_ID (AUTHORIZATION)

"	T:	$run

"	S:	$security_log

"	M:	An attempt to use the modification of various segment
"         attributes as a covert channel was detected.

"	END MESSAGE DOCUMENTATION

	end




		    page_fault.alm                  11/11/89  1105.1r w 11/11/89  0804.3      739098



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(87-06-22,Fawcett), approve(87-06-23,MCR7734),
"     audit(87-07-14,Farley), install(87-07-17,MR12.1-1043):
"     Change the checking for the "mylock" on the ptl for after the first stac
"     instructions indicates that the lock was in fact locked.
"                                                      END HISTORY COMMENTS


" " " " " " " "" " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	page_fault
"
"	This is the major procedure of Multics page control. For details, see
"	the Storage System PLM, Order Number AN61.
"
"	Coded 1/70 by S.Webber
" Last Modified (Date and Reason):
"	Modified by S.Webber 07/01/71 to add page multilevel
"	Modified by S.Webber 07/01/72 for followon
"	Modified by S.Webber 10/01/73 to merge with privileged code
"	Modified by B. Greenberg 06/10/74 for IOBM and put all cam/lock_ptl in page.
"	Modified by B. Greenberg 11/12/74 for overlap-lookahead core control.
"	Modified by B. Greenberg 02/05/75 for new storage system.
"	Modified by S. Webber 02/05/76 for new reconfiguration
"	Modified by B. Greenberg 03/08/76 for waiting on PTL
"	Modified by B. Greenberg 05/13/76 for pdme's with uid/pageno
"	Modified by B. Greenberg 12/76 for core_queue_man delay queue.
"	Modified by B. Greenberg 3/31/77 for disk_emergency and new page_error.
"	Modified by B. Greenberg 5/03/77 for page$pcleanup, aste.damaged.
"	Modified by RE Mullen 5/13/77 for concurrent scheduler
"	Modified by B. Greenberg 8/77 for pc_recover_sst, misc. cleanups.
"	Modified by B. Greenberg 9/20/77 for disk offline waiting.
"	Modified by B. Greenberg 3/15/78 for large sst, ptw.phm1
"	Modified by B. Greenberg 5/1/78 for parity errors.
"	Modified by D. Spector 2/20/79 for 18-bit unsigned quota
"	Modified by B. Greenberg 2/79 for variable write_limit
"	Modified by B. Greenberg 2/79 for 8-cpu port expander
"	Modified by J. A. Bush 3/80 to store fault time in machine conditions
"	Modified by B. Greenberg 6/23/80 for loop & unlock meters
"	Modified by J. A. Bush 8/80 for the DPS8/70M CPU
"	Modified by E.N. Kittlitz (per WOS) to not update PF count on gtus segments.
"	Modified by E.N. Kittlitz 11/17/80 for new dtu/dtm calculation.
"	Modified by J. Bongiovanni 1/81 for fault_counters
"         Modified by M. Pierret 11/80 to use page pinning algorithm
"	Modified by J. Bongiovanni 2/81 to remove cam/cache code
"	Modified by W. Olin Sibert, 2/26/81, for ADP conversion, phase one
"	Modified by C. Hornig, January 1982, to only CAM if segment accessible.
"	Modified by J. Bongiovanni, January 1982, to remove PML code, add
"	    extended page fault trace type
"	Modified by J. Bongiovanni, February 1982, for stocks
"	Modified by E. N. Kittlitz, 6/21/82, summer solstice sacrifice of core map.
"	Modified by J. Bongiovanni, July 1982, scs$trouble_processid, scavenger
"	Modified by J. Bongiovanni, October 1982, synchronized segment support,
"	     don't decrement quota through zero
"	Modified by E. N. Kittlitz (Massachusetts agent for W.O. Sibert) to pin those pages again.
"	Modified by Keith Loepere, October 1983, for paged unpaged dseg and
"	     for bug fix to find_core loop.
"	Modified by R. Coppola 10/13/83 to meter DF1 on per-cpu basis and
"	added code to meter cache errors when mc_trace'ing
"         Modified by BIM 83-12-03 for pgt_ IPS signal.
"	Modified by TO 84-10-17 to remove write_limit and disk_run'ing.
"	Modified by Keith Loepere, December 1984, for covert channel 
"	     detection and a little cleanup.
"	Modified by Keith Loepere, January 1985, for updated covert
"	     channel detection.
"	Modified by Keith Loepere, January 1985, for fix to aste.records race.
"	Modified by Tom Oke, February 1985, to remove a missed write_limit
"	     and disk run.
"
"	The following entries exist within this procedure (given by entry name to "page"):
"
"	done	used by the paging DIMs to signal the completion
"		of an I/O request.
"
"	enter_data places an entry into the per-process trace table
"
"	fault     transferred to upon page faults from the fault vector
"
"	lock_ptl  used to lock the page table lock
"
"	pccleanup	used to get a page out of core
"
"	pread	used to read a page into core
"
"	pwrite	used to write a page out of core
"	
"	reset_working_set is obsolete and does nothing
"
"	trace_marker places a user marker entry into the per-process
"		trace table
"
"	unlock_ptl used to unlock the page table lock
"				
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

"
" 
"
" The very beginning
"
	name	page_fault


	entry	wait_return,pmut_unlock_ptl
	entry	ptl_wait_return

	segdef	check_accessible		" See whether anyone can access segment
	segdef	cleanup_page		" Evict one page from memory
	segdef	cme_offsets		" Core map ITS pointers, 1 per cme word
	segdef	cme_0,cme_bp,cme_fp		" ITS to word 0 of cme
	segdef	cme_1,cme_devadd,cme_flags	" ITS to word 1 of cme
	segdef	cme_2,cme_astep,cme_ptwp	" ITS to word 2 of cme
	segdef	cme_3,cme_pin_counter,cme_synch_page_entryp	" ITS to word 3 of cme

	segdef	delete_mm_frame		" Clear out and deconfigure main memory frame
	segdef	disk_offline_event		" Wait event for disk offline
	segdef	disk_offlinep		" Check whether disk is offline
	segdef	done			" Post completion of I/O
	segdef	done_			" Post completion with PTL locked
	segdef	enter_data		" Enter per-process trace data
	segdef	fault			" Page Fault entry
	segdef	find_core_		" Find a frame of core
	segdef	init_savex		" Init x7 save stack
	segdef	init_savex_bb		" Init x7 save stack, set bb -> sst
	segdef	lock_ptl			" Lock PTL
	segdef	lock_ptl_ext		" Lock PTL from outside ALm PC
	segdef	lock_ptl_no_lp		" Lock PTL, don't save lp
	segdef	my_lp			" lp for bound_page_control
	segdef	notify_return		" Side-door return from pxss$notify_page
	segdef	page_fault_error		" Call to page_error - fatal
	segdef	pcleanup			" Entry to get a page out of core
	segdef	pf_prs			" Pointer to saved prs on page fault
	segdef	pf_scuinfo		" Pointer to SCU data on page fault
	segdef	pre_page_info		" Obsolete
	segdef	pread			" Entry to read a page
	segdef	pwrite			" Entry to write a page
	segdef	read_page_abs		" Same as read_page, but OOPV not allowed
	segdef	reset_working_set		" Obsolete
	segdef	savex			" Save x7 in save stack for recursive use
	segdef	set_up_abs_seg		" Setup abs_seg_1
	segdef	thread_in			" Thread CME as MRU
	segdef	thread_lru_ext		" Thread CME as LRU, ouside of ALM PC
	segdef	thread_out		" Thread CME out of used list
	segdef	thread_to_lru		" Thread CME as LRU
	segdef	trace_marker		" Add user marker to per-process trace
	segdef	trace_restart_fault		" Add restart_fault to per-process trace
	segdef	trace_scheduling		" Add reschedule to per-process trace
	segdef	trace_signaller		" Add signaller to per-process trace
	segdef	unlock_ptl		" Unlock PTL
	segdef	unlock_ptl_ext		" Unlock PTL, outside of ALM PC
	segdef	unsavex			" Pop save stack, tra 0,x7
	segdef	unsavex_1			" Pop save stack, tra 1,x7
	segdef	unsavex_2			" Pop save stack, tra 2,x7
	segdef	write_page		" Write page out if necessary
"

	include	page_regs
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Temporary storage, INCLUDE files, and constants
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


	link	prds_link,prds$
	link	abs_seg1_link,abs_seg1$

	include	stack_frame
	include	stack_header
	include	trace_types
	include	sys_trouble_codes
	include	mode_reg
	include	pxss_page_stack
	include	page_error_types
	include	page_info
	include	apte
	include	sst
	include	tc_meters
	include	wcte
	include	sdw
	include	ptw
	include	add_type
	include	aste
	include	cmp
	include	mc
	include	null_addresses
	include	static_handlers
	include	device_error
	include	mctseg
	include	fault_vector
	include	unpaged_page_tables
"
"	check for wild transfers to bound_page_control|0

	tsx5	page_fault_error	"ERROR - TRA TO PAGE|0"
	tsx5	page_fault_error	"ERROR - TRA TO PAGE|1"
"
"
"	The following code (located at bound_page_control|2) is used for
"	hardware debugging to make it easy to restart the last page
"	fault via restoring the machine conditions and doing an RCU.
"
	epplp	my_lp,*		restore page's linkage
	eppap	pds$page_fault_data
	tra	restart_fault

	dec	0	" (bpc|5) -- address_mask used to be here

"	This location (bound_page_control|6) is left unused so that
"	obsolete patches of run limit (write_limit) will not crash system.
obsolete_wlim:
	dec	0

	even
pf_prs:	its	-1,1
pf_scuinfo:
	its	-1,1
my_lp:
	its	-1,1

cme_offsets:			" set up by initialize_faults.
cme_0:
cme_bp:
cme_fp:	its	-1,0

cme_1:
cme_devadd:
cme_flags:
	its	-1,1

cme_2:
cme_ptwp:
cme_astep:
	its	-1,2

cme_3:
cme_pin_counter:
cme_synch_page_entryp:
	its	-1,3

sdw_bits: 		" Bits for abs-seg SDW -- it is
			" Address 0, read/write, one unpaged page

	iftarget	L68	" SDW is different format for each
	  vfd	18/0,18/sdw.valid
	  vfd	1/0,14/(1024/16)-1,3/sdw.read+sdw.write,18/sdw.unpaged
	ifend

	iftarget	ADP
	  vfd	18/0,18/sdw.valid
	  vfd	14/(1024/16)-1,4/0,18/sdw.read+sdw.write+sdw.unpaged
	ifend

channel_mask_set:
	oct	17,17

unnull_mask:
	zero	-1-ptw.nulled,-1	mask to resurrect an address

	even
null:	its	-1,1
pc_signal_arglist:
	vfd	18/6,18/4,18/0,18/0

"*********************************************************************
"*********************************************************************
"*********************************************************************
"*********					**********
"*********	HERE ARE THE CONSTANTS ... AND	**********
"*********	HERE BEGINS THE CODE OF PAGE_FAULT.	**********
"*********					**********
"*********************************************************************
"*********************************************************************
"*********************************************************************
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Subroutines:
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

lock_ptl:
	sprilp	sp|stack_frame.lp_ptr we don't do a normal 'entry' so ...
lock_ptl_no_lp:
	epbpbb	sst$		bb -> SST through out page
	lda	pds$processid	lock the page table lock
	stac	sst|sst.ptl
	tze	ptl_ok		branch if we think locked it
	read_clock		meter time waiting for lock
	cmpa	sst|sst.ptl	check for mylock on page table lock
	tze	page_error$ptl_mylock  complain if lock already set
	staq	pds$arg_1
	lda	pds$processid	get set to lock again
ptl_repeat:
	stac	sst|sst.ptl	hurry up and wait
	nop
	nop
	tnz	ptlfail		locked, see if wait needed
	read_clock	
	sbaq	pds$arg_1
	adaq	sst|sst.loop_lock_time
	staq	sst|sst.loop_lock_time
	increment	sst|sst.loop_locks	meter times we had to loop lock
ptl_ok:
	lda	pds$processid	did we lock ok?
	cmpa	sst|sst.ptl
	tze	*+2
	tsx5	page_fault_error	"ERROR - PTL STAC FAILED"
	tra	0,.ret

ptlfail:
	cmpx	.ret,pft_lret,du	locking for page fault?
	tnz	ptl_repeat	no, loop some more
	read_clock		account for partial pf time 
	sbaq	pds$time_1	account for partial pf time 
	adaq	tc_data$cpu_pf_time	account for partial pf time 
	staq	tc_data$cpu_pf_time	account for partial pf time 
	tra	pxss$ptl_wait	yes, wait for lock

ptl_wait_return:			"return location from pxss$ptl_wait
	eppap	pds$page_fault_data
	read_clock		account for rest of pf time
	staq	pds$time_1	account for rest of pf time
	tra	masked_switched_legal

pmut_unlock_ptl:
	push
	tsx	.2ret,init_savex_bb
	tsx	.ret,unlock_ptl
	eppap	sp|stack_frame.arg_ptr,*
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sp|stack_frame.prev_sp,*
	tra	pmut$unwire_unmask
unlock_ptl_ext:
	push
	tsx	.2ret,init_savex_bb
	tsx	.ret,unlock_ptl	unlock the ptl
	tra	return


unlock_ptl:
	tra	core_queue_man$unlock_ptl  Hoo, boy!

lock_ptl_ext:
	eax	.ret,.rt
	tra	lock_ptl_no_lp
.rt:	short_return

non_fatal_error:
	eax5	-1,.ret
	tsx	.2ret,page_error$non_fatal_error
	tra	0,.ret

page_fault_error:
	eax5	-1,5		set x5 to point to actual call to subroutine
	tra	page_error$page_fault_error  die

init_savex_bb:
	epp	sst,sst$
init_savex:
	eaa	save_stack	get address of save stack base
	ora	stack_size*64,dl	set up a tally word for storing into save_stack
	sta	stackp		stash this away
	tra	0,.2ret		return to the caller


savex:
	stx	.ret,stackp,id	store x7 in save stack using tally word
	ttf	0,.2ret		return to the caller if tally not runout
	tsx5	page_fault_error	"ERROR - SAVE STACK OVERFLOW"

unsavex:
	ldx	.ret,stackp,di	pop value of x7 (also updating tally word properly)
	tra	0,.ret
unsavex_1:
	ldx	.ret,stackp,di	pop value of x7 (also updating tally word properly)
	tra	1,.ret

"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"						"
"	Subroutines to manage used list threading	"
"						"
"						"
"						"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

"
"	Move an entry to least-recently-used place
"
thread_to_lru:


"	assumes .cme -> cme

	cmpx	.cme,sst|sst.usedp	see if already at lru point
	tze	0,.ret		leave it if so

	szn	cme_fp,*.cme make sure threaded in (could be postpurge os)
	tmoz	0,.ret


"
"	Load pointers to current brothers, thread out.
"
	ldx	.nxt,cme_fp,*.cme next
	lxl	.lst,cme_bp,*.cme previous

	cmpx	.cme,sst|sst.wusedp	see if write point is on .cme
	tnz	*+2
	stx	.nxt,sst|sst.wusedp	make writes start at next

"	Thread out

	stx	.nxt,cme_fp,*.lst successor(last) = successor
	sxl	.lst,cme_bp,*.nxt last(successor) = last

"	Move to usedp

mv_to_usedp:
	ldx	.nxt,sst|sst.usedp  point to successor to be

"	See if usedp at wusedp. If so, back up wusedp.

	cmpx	.nxt,sst|sst.wusedp	see if wusedp = usedp
	tnz	*+2		no, not equal.
	stx	.cme,sst|sst.wusedp	our cme is new wused

	stx	.cme,sst|sst.usedp	in any case, our cme is new used.

thread_behind:
	lxl	.lst,cme_bp,*.nxt point to last to be

"	Thread to .cme

	stx	.cme,cme_fp,*.lst successor (last) = cme
	sxl	.cme,cme_bp,*.nxt last (successor) = cme

"	Thread cme to environment

	stx	.nxt,cme_fp,*.cme successor (cme) = successor
	sxl	.lst,cme_bp,*.cme last (cme) = last

	tra	0,.ret

"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "
"						"
"	Thread a cme out of the used list.		"
"						"
"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "

thread_out:

"	Point to environment

	ldx	.nxt,cme_fp,*.cme successor = successor (cme)
	tpnz	*+2
	tsx5	page_fault_error	"ERROR - THREADING OUT UNTHREADED CME"

	lxl	.lst,cme_bp,*.cme last = last (cme)

"	Make sure replacement and writing pointers are not
"	looking at .cme.

	cmpx	.cme,sst|sst.usedp
	tnz	*+2
	stx	.nxt,sst|sst.usedp move usedp to successor if so

	cmpx	.cme,sst|sst.wusedp
	tnz	*+2
	stx	.nxt,sst|sst.wusedp

"	Thread out

	sxl	.lst,cme_bp,*.nxt last (successor) = last
	stx	.nxt,cme_fp,*.lst successor (last) = successor

	stz	cme_fp,*.cme
	tra	0,.ret

"
"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "
"						"
"	Thread an unthreaded entry to lru		"
"						"
"						"
"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "

thread_in:
	szn	cme_fp,*.cme make sure not threaded in already
	tmoz	mv_to_usedp
	tsx5	page_fault_error	"ERROR - THREADING IN THREADED CME"

"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "
"
"	Thread an unthreaded entry to MRU.              "
"				                    "
"" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "

thread_in_mru:
	ldx	.nxt,sst|sst.wusedp thread in behind wusedp.
	szn	cme_fp,*.cme     make sure not threaded in
	tmoz	thread_behind	move behind wusedp
	tsx5	page_fault_error	"ERROR - MRU THREADING THREADED CME"

"
"	External entry to thread to lru.
"
thread_lru_ext:
	eppbp	ap|2,*		ap -> cmep
	eax	.cme,bp|0,*
	epp	sst,sst$		set up sst ptr
	tsx	.ret,thread_to_lru
	short_return
"

	inhibit	on
	even
meter_virtual_time:
	lca	1,dl		check for recursive metering
	asa	pds$vtime_count	..
	tpl	0,.ret		yes, do no more
	read_clock		get current value of CPU time
	adl	96,dl			add in correction delta
	sbaq	pds$cpu_time	..
	sbaq	pds$time_v_temp	get time used for this fault/interrupt
	staq	pds$time_v_temp
	adaq	pds$virtual_delta	save as virtual time increment
	staq	pds$virtual_delta	..
	ldaq	pds$time_v_temp	also calculate total vcpu
	adaq	tc_data$+delta_vcpu
	staq	tc_data$+delta_vcpu
	tra	0,.ret
	inhibit	off

set_up_abs_seg:
	lda	core_add
	als	coreadd_to_sdw.ls	shift core addr into sdw pos
	eaq	0		clear q-reg
	oraq	sdw_bits		turn on other interesting bits
	eppap	abs_seg1$		get pointer to core area
	ldx	.tem,lp|abs_seg1_link get segno of abs_seg1
	adlx	.tem,lp|abs_seg1_link multiply by 2
	staq	dseg$,.tem	store in descriptor segment
	cams
	tra	0,.2ret

store_pattern:
	tsx	.2ret,set_up_abs_seg get abs_seg1 ready
	ldaq	=vo36/777666333222,o36/444000111555
	staq	ap|0		and store it into the page
	staq	ap|1022		..
	tra	0,.ret

check_pattern:
	tsx	.2ret,set_up_abs_seg
	ldaq	=vo36/777666333222,o36/444000111555
	cmpaq	ap|0		if the same we have trouble
	tze 	1,.ret		take error return
	cmpaq	ap|1022		try the last 2 words
	tnz	0,.ret		ok if not the same
	tra	1,.ret		bad news if the same

clear_core:
	tsx	.2ret,set_up_abs_seg make abs_seg1 point to core_add
	eax	.tem,4096		zero out 4096 characters
	mlr	(),(pr,rl),fill(0)
	desc9a	0,0
	desc9a	ap|0,x0		.tem
	tra	0,.ret

check_for_zero:			" assumes abs_seg1 setup
	eppap	abs_seg1$
	eax	.tem,4096		number of characters in a page
	cmpc	(),(pr,rl),fill(0)
	desc9a	0,0
	desc9a	ap|0,x0		.tem
	tze	1,.ret
	tra	0,.ret


" 
"
"	The following subroutine (reset_mode_reg) is called before masking down.
"	It therefore must be inhibited.
"
	inhibit	on
reset_mode_reg:
	rsw	2			get cpu type in a
	als	mc.cpu_type_shift		get the CPU type
	ana	mc.cpu_type_mask,du
	stca	ap|mc.cpu_type_word,70	store in machine conditions
	arl	18-mc.cpu_type_shift	position in au lower
	eax4	0,au			copy to x4
	szn	pds$mc_trace_sw		is this process tracing machine conditions?
	tpl	no_trace_mc		xfer if no
	szn	pds$mc_trace_seg		Does user want to trace all M. Cs?
	tze	cp_hregs			xfer if seg number zero
	lda	ap|mc.scu.ppr.psr_word	look at the psr
	ana	scu.ppr.psr_mask,du		and out  everything except psr
	cmpa	pds$mc_trace_seg		compare psr to object we are tracing
	tze	cp_hregs			xfer if psr = object we are tracing
	lda	ap|mc.scu.tpr.tsr_word	look at tsr
	ana	scu.tpr.tsr_mask,du		and out everthing except tsr
	cmpa 	pds$mc_trace_seg		compare tsr to object we are tracing
	tnz	no_trace_mc		do not trace if psr and tsr don't have seg
cp_hregs:	scpr	ap|mc.fim_temp,01		save fault register
	ldaq	ap|mc.fim_temp		note that scpr does D.P. store and
	sta	ap|mc.fault_reg		stores zeroes in mc.fault_reg
	qrl	mc.cpu_type_shift		make room for cpu type
	orq	ap|mc.cpu_type_word		or in cpu type
	stcq	ap|mc.cpu_type_word,70	store cpu type and ext fault reg
	lda	prds$processor_tag		get cpu num
	xec	cache_ctr_tab,al		lb=> per-cpu cache err ctrs	
	lda	ap|mc.fault_reg		reload PFR
	ana	=o10,dl			cache dir parity (bit 32)?
	tze	check_efr			no, go check EFR
	aos	lb|1			yes, increment the per-cpu ctr
check_efr:
	anq	mc.ext_fault_reg_mask,du	mask unwanted bits OFF
	tze	no_efr			no bits on, bypass
	qls	2			get EFR bits in Q 1-17
	eaa	0			set up A as incrementer
efr_loop:
	ada	1,dl			increment EFR slot number
	qls	1			is this bit on?
	tpnz	efr_loop			no, but some other bit on
	tze	no_efr			no more EFR bits
	aos	lb|1,al			increment EFR counter
	tra	efr_loop			look for nxt EFR bit

no_efr:	lprplb	pds$mc_trace_buf		get packed ptr to wired trace buffer
	lxl5	lb|mctseg.hr_nxtad		x5 = rel ptr to next H. R. storage location
	cmpx5	lb|mctseg.hr_lim		do we have to roll over the trace?
	tmi	hr_roll			xfer if no
	ldx5	lb|mctseg.hr_strt		yes, pick up initial storage location
	sxl5	lb|mctseg.hr_nxtad		store new location
hr_roll:	eax5	mctseg.hr_size,5		increment storage location
	sxl5	lb|mctseg.hr_nxtad		set rel ptr to next H. R. storage location
	epplb	lb|-mctseg.hr_size,5	lp -> current HR storage location
	ldq	2,du			get a 2 for stepping address
	eax6	4			4 blocks of
scpr1:	eax5	16			16 history registers
	eax3	0			set up for L68 CPU type initally
	cmpx4	1,du			is this a DPS8/70M CPU?
	tnz	scpr2			xfer if no, it is L68
	eax3	48			yes, set up to skip first 48 hregs
	cmpx6	3,du			DU hreg? Don't have one on DPS8/70M
	tnz	scpr2			no, go execute it
	mlr	(),(pr),fill(0)		zero out this 32 word block
	desc9a	0,0
	desc9a	lb|64,32*4
	eax6	-1,6			yes, skip it
scpr2:	lda	scpr-1,6			get correct instruction
	sta	ap|mc.fim_temp		save in stack
scpr3:	xec	ap|mc.fim_temp		execute the instruction
	cmpx3	0,du			are we through skipping hregs?
	tze	scpr4			yes, go increment address
	eax3	-1,3			no, skip another
	tra	scpr3			and go execute scpr again

scpr4:	asq	ap|mc.fim_temp		increment address of instruction
	eax5	-1,5			count down
	tnz	scpr3			more of this 16 double word block
	eax6	-1,6			count down
	tnz	scpr1			another kind of hreg

	eax5	64			initially set clear count to 64
	cmpx4	1,du			is this a DPS8/70M CPU?
	tze	*+2			yes, clear all 64 hregs
	eax5	16			no, clear only 16 hregs
	lcpr	0,03			set all history regs to zero
	eax5	-1,5			count down
	tpnz	*-2			xfer if more to do
	eawplb	0
trace_mc:
	lxl5	lb|mctseg.mc_nxtad		x5 = rel ptr to next M. C. storage loc
	cmpx5	lb|mctseg.mc_lim		do we have to roll over the trace?
	tmi	mc_roll			xfer if no
	ldx5	lb|mctseg.mc_strt		yes, pick up initial storage location
	sxl5	lb|mctseg.mc_nxtad		store new location
mc_roll:
	eax5	mctseg.mc_size,5		increment storage location
	sxl5	lb|mctseg.mc_nxtad		set rel ptr to next M. C. storage location
	epplb	lb|-mctseg.mc_size,5	lp -> current MC storage location
	mlr	(pr),(pr)			move the data to wired buffer
	desc9a	ap|0,mctseg.mc_size*4
	desc9a	lb|0,mctseg.mc_size*4
no_trace_mc:
	epplb	prds$cache_luf_reg		reset cache control reg
	lcpr	lb|0,02			lcpr to reload luf and cache control
	lda	prds$mode_reg		retrieve template mode reg
	ora	mr.enable_mr+mr.enable_hist,dl enable mode reg and hist regs
	sta	prds$mode_reg_enabled	save this mode reg value
	epplb	prds$mode_reg_enabled	get pointer to temp mode reg value
	lcpr	lb|0,04			reload the mode register
	tra	0,.ret			return to caller

scpr:	scpr	lb|0,40			OU History Regs for L68, OU/DU for DPS8
	scpr	lb|32,20			CU History Regs
	scpr	lb|64,10			DU History Regs for L68, not used for DPS8
	scpr	lb|96,00			APU History Regs

cache_ctr_tab:
	epplb	wired_hardcore_data$cpu_a_cache_err_ctr_array
	epplb	wired_hardcore_data$cpu_b_cache_err_ctr_array
	epplb	wired_hardcore_data$cpu_c_cache_err_ctr_array
	epplb	wired_hardcore_data$cpu_d_cache_err_ctr_array
	epplb	wired_hardcore_data$cpu_e_cache_err_ctr_array
	epplb	wired_hardcore_data$cpu_f_cache_err_ctr_array
	epplb	wired_hardcore_data$cpu_g_cache_err_ctr_array
	epplb	wired_hardcore_data$cpu_h_cache_err_ctr_array

fault_ctr_table: 
	eppab	wired_hardcore_data$cpu_a_flt_ctr_array
	eppab	wired_hardcore_data$cpu_b_flt_ctr_array
	eppab	wired_hardcore_data$cpu_c_flt_ctr_array
	eppab	wired_hardcore_data$cpu_d_flt_ctr_array
	eppab	wired_hardcore_data$cpu_e_flt_ctr_array
	eppab	wired_hardcore_data$cpu_f_flt_ctr_array
	eppab	wired_hardcore_data$cpu_g_flt_ctr_array
	eppab	wired_hardcore_data$cpu_h_flt_ctr_array

	inhibit	off

get_pvtx:
	lda	ast|aste.pvtx_word,.aste
	arl	aste.pvtx_shift
	ana	aste.pvtx_mask,dl
	sta	pvtx
	tra	0,.ret


" 
" " " " " " " " " " " " " " "
"
"	enter_data -- entry to add data to the 'system trace list'
"	Call is:
"
"	call page$enter_data(data_word, type)
"
"	where data_word is a word value to be
"	entered into the next available slot in the trace
"	list. If type = 0 (page fault type) then a return is
"	done and the entry is not placed in the list.
"
" " " " " " " " " " " " " " " " " " " " "

	include	sys_trace

trace_signaller:
	epplp	my_lp,*		set linkage pointer
	lda	pds$condition_name	get first four characters of name
	ldq	pds$condition_name+1
	lls	9		shift out ACC count field
	ldq	signaller_type,du	get coded type
	tsx	.ret,enter
	tra	lb|0		return via special code

trace_restart_fault:
	epplp	my_lp,*
	eaa	0		code for restart is zero
	ldq	restart_fault_type,du
	tsx	.ret,enter
	tra	lb|0		return via special code

trace_marker:
	lda	ap|2,*		get char string to use as marker
	ldq	marker_type,du	set type appropriately
	tsx	.ret,enter
	short_return

trace_scheduling:
	eaa	0		code word is all zeros
	ldq	reschedule_type,du	get type code
	tra	enter

enter_data:
	lda	ap|2,*		pick up the data_word
	ldq	ap|4,*		make sure non-zero type given
	qls	30		left justify
	tze	short_return	return if illegal type given
	tsx	.ret,enter
short_return:
	short_return

return:	return

"
"	Subroutine to enter a page fault into the system-trace list
"
page_util_enter:
	stx	.aste,temp	astep
	eax	.tem,-aste_size,.ptw PTW addr - ASTE size
	sblx	.tem,temp		page number
	anx	.tem,=o377,du	only significant bits
	
	szn	tc_data$post_purge_switch	are we post-purging?
	tze	extended_page_util_enter	no -- we can stuff more data into trace

"	We are post-purging, so we need old format trace entry

	ldq	pds$page_fault_data+mc.scu.tpr.tsr_word  get segno in q
	eaa	0,.aste		get astep in a-reg
	arl	18
	lls	18		fabricate entire code word
	eaq	0,.tem		page number (low order bits) in upper
	tra	enter

extended_page_util_enter:
	lda	pds$page_fault_data+mc.scu.ppr.psr_word	PPR in AU
	ana	=o7777,du		Low-order bits only
	arl	18		PPR in AL
	ldq	pds$page_fault_data+mc.scu.ilc_word	IC in QU
	anq	-1,du		strip out garbage (indicators)
	lls	18+6		1st 30 bits or first word
	sta	temp
	lda	pds$page_fault_data+mc.scu.ppr.psr_word	PPR in AU
	ldq	pds$page_fault_data+mc.scu.cu_stat_word	CU status bits
	canq	scu.cu.if,dl	fault on instruction fetch
	tnz	*+2		yes - use PPR
	lda	pds$page_fault_data+mc.scu.tpr.tsr_word	no - use TSR
	ana	=o7777,du		Low-order bits only
	arl	18		segno in AL
	eaq	0,.tem		pageno in QU
	qls	18-8
	lrl	6
	qrl	6
	ora	temp
	orq	extended_page_fault_type,du

enter:	eppap	pds$trace		get pointer to trace structure
	ldx	.tem,ap|trace.next_free_word get current index to next free slot
	staq	ap|trace.data,.tem	save coded information
	read_clock	
	sbaq	ap|trace.ttime	get incremental time
	stq	ap|trace.temp	save in temporary
	adaq	ap|trace.ttime	recalculate last fault time
	staq	ap|trace.ttime
	ldq	ap|trace.temp	retrieve delta-time
	qrl	6		in terms of 64 micro-seconds
	cmpq	=o177777,dl	see if time is too large
	tmi	*+2		no, use it
	ldq	=o177777,dl	yes, time is too large, use standard large value
	orsq	ap|trace.data+1,.tem OR time value into trace entry
	eax	.tem,2,.tem	bump entry index
	cmpx	.tem,ap|trace.last_available_word  check for wrap-around
	tnz	trace.no_wrap	not now, though
	eax	.tem,0		we wrapped. reset to beginning
trace.no_wrap:
	cmpx	.tem,ap|trace.threshold_word signal?
	tnz	trace.no_signal     nope
	lda	ap|trace.send_ips_word  Signals enabled?
	cana	trace.send_ips,dl
	tze	trace.no_signal
	eppbp	pds$apt_ptr,*	no need to lock, we use stacq
trace.retry_ips:
	lda	sys_info$pgt_mask   This cannot recurse,
	ora	bp|apte.ips_message since we only test EQUAL to
	ldq	bp|apte.ips_message threshold. The pgt_ trace
	stacq	bp|apte.ips_message will be GREATER.
	tnz	trace.retry_ips
	lda	1,dl		set ring alarm
	sta	pds$alarm_ring	store in simulated spot
	lra	pds$alarm_ring	set for real
trace.no_signal:
	stx	.tem,ap|trace.next_free_word
	
	tra	0,.ret


reset_working_set:
	short_return

pre_page_info:
	stz	ap|4,*		pre-page calls
	stz	ap|6,*		paging device page faults
	stz	ap|8,*		no pre-paging
	short_return
"

" quota primitives - check for RQO, decrement quota, increment quota

check_quota:
	lda	ptw|0			inspect ptw
	cana	add_type.non_null,dl 	see if not_null address
	tze	check_quota.real_null
	als	0
	tpl	0,.ret			real address, return

check_quota.real_null:
	tsx	.2ret,type_terminal_quota
	tra	*+2			seg quota
	tra	0,.ret			dir quota, skip it for now

	eax	.tem,0,.aste		loop up parents
quota_c:	lxl	.tem,ast|aste.par_astep,.tem	get father
	cana	ast|aste.tqsw_word,.tem	see if terminal
	tze	quota_c			no, loop up

	szn	pds$quota_inhib		special consideration?
	tnz	0,.ret			yes, return

	lda	entry_sw			don't check on read entry
	cmpa	read_entry,dl
	tze	0,.ret			read entry, don't check

	lda	ap|mc.scu.tpr.trr_word	get ring of faulting reference
	cana	scu.tpr.trr_mask,du		see if in ring 0
	tze	0,.ret			yes, don't check quota

	ldx	.2ret,ast|aste.used,.tem 	check seg quota for over
	cmpx	.2ret,ast|aste.quota,.tem
	tnc	0,.ret			not over quota, return
	lda	PAGE_ERROR_RQO,dl		type of error to signal
	eppab	ast|0,.tem		ASTE of quota account
	tra	errquit

" subtract 1 from quota cell

reset_quota:
	eax	.tem,0,.aste		start at current aste
	tsx	.2ret,type_terminal_quota	find quota parent
	lxl	.tem,ast|aste.par_astep,.tem	seg quota applies to parent

quota_r:	xec	quota.lx,ql		fetch correct cell
	tze	*+3			don't decrement thru 0
	sblx	.2ret,1,du
	xec	quota.sx,ql		save back
	cana	ast|aste.tqsw_word,.tem	stop at terminal account
	tnz	0,.ret
	lxl	.tem,ast|aste.par_astep,.tem	parent cell
	tra	quota_r

" add 1 to quota cell

bump_quota:
	lda	aste.fmchanged,du		turn on fmchanged
	orsa	ast|aste.fmchanged_word,.aste
	
	eax	.tem,0,.aste		start at current aste
	tsx	.2ret,type_terminal_quota	find quota parent
	lxl	.tem,ast|aste.par_astep,.tem	seg quota applies to parent

quota_b:	xec	quota.lx,ql		fetch correct cell
	adlx	.2ret,1,du
	xec	quota.sx,ql		save back
	cana	ast|aste.tqsw_word,.tem	stop at terminal account
	tnz	0,.ret
	lxl	.tem,ast|aste.par_astep,.tem	parent cell
	tra	quota_b

bump_quota_covert_check:

" Add 1 to quota cell, also check that there exists a terminal quota node
" before the first upgraded node.  This should be used only for dirs,
" so that we don't require terminal dir quota for upgraded dirs.

	lda	aste.fmchanged,du		turn on fmchanged
	orsa	ast|aste.fmchanged_word,.aste
	
	eax	.tem,0,.aste		start at current aste
	tsx	.2ret,type_terminal_quota	find quota parent
	lxl	.tem,ast|aste.par_astep,.tem	seg quota applies to parent
	ora	aste.multi_class,du		we will "stop" on terminal
"					node or upgraded node
	stz	temp			assume terminal-ness

quota_bc:	xec	quota.lx,ql		fetch correct cell
	adlx	.2ret,1,du
	xec	quota.sx,ql		save back
	cana	ast|aste.tqsw_word,.tem	look at tqsw and multi_class
	tze	quota_bc_next		neither upgraded nor terminal

	lxl	.2ret,ast|aste.tqsw_word,.tem	terminal half-word
	canx	.2ret,quota.tq_mask,ql
	tnz	quota_bc_term		terminal found
	sta	temp			upgraded found first
quota_bc_next:
	lxl	.tem,ast|aste.par_astep,.tem	parent cell
	tra	quota_bc

quota_bc_term:
	lda	temp
	tnz	0,.ret			upgraded found first
	tra	1,.ret			terminal-ness okay

" determines type of quota (seg/dir), returns to call+(1/2) so depending
" also sets a to have corresponding mask bit for tqsw,
" q to have a 0/1 corresponding to (seg/dir)

type_terminal_quota:
	lda	ast|aste.nqsw_word,.aste special seg?
	cana	aste.nqsw,dl	..
	tnz	0,.ret		leave whole biz if so

	cana	aste.dirsw,dl	dirsw_word same as nqsw_word
	tnz	type.dir_quota

	lda	aste.tqsw,dl	seg quota type
	ldq	0,dl
	tra	0,.2ret
type.dir_quota:
	lda	aste.tqsw/2,dl
	ldq	1,dl
	tra	1,.2ret

quota.lx:	ldx	.2ret,ast|aste.used,.tem	instructions to load desired
	lxl	.2ret,ast|aste.used,.tem	quota cell

quota.sx:	stx	.2ret,ast|aste.used,.tem	instructions to store desired
	sxl	.2ret,ast|aste.used,.tem	quota cell

quota.tq_mask:
	arg	aste.tqsw			values for checking for tqsw
	arg	aste.tqsw/2		in bump_quota_covert_check
"
" " " " " " " " " " " " " " " " " " " " " " " "
"
"	check_accessible	subroutine to check if any processor can access
"			the page in question. This tells us whether to
"			clear all the AM's.
"
" " " " " " " " " " " " " " " " " " " " " " " "

check_accessible:
	ldx	.tem,ast|aste.strp,.aste	" get aste.strp
	tnz	0,.2ret		" must CAM
	lda	ast|aste.hc_sdw_word,.aste	" check for HC segment
	cana	aste.hc_sdw,du	" aste.hc_sdw?
	tnz	0,.2ret		" yes, CAM
				" volmap_seg_word same as hc_sdw_word
	cana	aste.volmap_seg,dl	" aste.volmap_seg?
	tnz	0,.2ret		" yes, CAM
	tra	1,.2ret		" we save some connects!
"
" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Routines to check for pages of synchronized segments
"
"
"	On evict, do housekeeping
"
"	    tsx7	check_synch_cleanup
"
"	On write, check if page must be held
"
"	   tsx7    check_for_synch_hold
"	   <return if page cannot be written>
"	   <normal return>
"
" " " " " " " " " " " " " " " " " " " " " " " " "


check_synch_cleanup:
	lda	cme_flags,*.cme		
	cana	cme.synch_held,dl		synchronized page
	tze	0,.ret			no
	tra	page_synch$cleanup		return to 0,x7

check_for_synch_hold:
	lda	ast|aste.synchronized_word,.aste
	cana	aste.synchronized,dl	synchronized page
	tze	1,.ret			no
	tsx	.2ret,savex		recursive use of x7
	tsx	.ret,page_synch$write	check whether we should write
	tra	unsavex			do not write
	tra	unsavex_1			write OK

"
" " " " " " " " " " " " " " " " " " " " " " " "
"
"	update_csl	subroutine to make sure the csl
"			for a segment is correct. It is called
"			when a page is found to be zero,
"			either by being modified to zeroes or
"			by being a non-modified null address.
"
" " " " " " " " " " " " " " " " " " " " " " " " "

update_csl:
	stz	temp		zero out entire word
	stz	temp+1		and next as well
	eax	.tem,aste_size,.aste get a pointer to the page table
	stx	.tem,temp		save for now
	stx	.tem,temp+1
	eax	.tem,1,.ptw	get page number by subtracting base of PT from ptp
	sblx	.tem,temp		(add 1 to get csl )
	stx	.tem,temp
	lda	ast|aste.csl_word,.aste pick up csl of segment
	ana	aste.csl_mask_inner,du
	arl	aste.csl_shift-18	shift to upper a, right justified
	cmpa	temp		compare with page number
	tnz	0,.ret		not the same, don't change csl
	eax	.tem,-1,.ptw	start search at previous page
	cmpx	.tem,temp+1	end search at first page of segment
	tnc	up_csl.set_csl	done (at page zero)
	ldq	ptw.valid,dl		get in core flag for compares
csl_loop:
	canq	sst|0,.tem	is current page in core ?
	tnz	up_csl.set_csl	yes, stop and set csl here
	lda	sst|0,.tem	get ptw
	cana	add_type.non_null,dl is there a real address?
	tze	up_csl.dont_count
	als	0		test sign
	tpl	up_csl.set_csl	real disk address
up_csl.dont_count:
	eax	.tem,-1,.tem	go to previous PTW
	cmpx	.tem,temp+1	are we passed the start ?
	trc	csl_loop		no, loop back and check this page
up_csl.set_csl:
"update csl into AST entry
	eaa	1,.tem		get curerrent ptp (+1 to convert to csl format)
	sbla	temp+1		subtract out base of page table
	als	aste.csl_shift-18	shift to position in AST entry
	era	ast|aste.csl_word,.aste and store in AST entry
	ana	aste.csl_mask_inner,du
	ersa	ast|aste.csl_word,.aste
	tra	0,.ret		return

" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	fault
"
"	This entry is transferred to from the fault vector when a page fault
"	occurs. The pointers, registers, etc. must be saved...
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	even
fault:
	inhibit	on
	spri	pf_prs,*
	eppap	pf_prs,*		get pointer to MC
	sreg	ap|mc.regs	save registers
	spl	ap|mc.eis_info
	epplp	my_lp,*		set up linkage pointer
	read_clock		start metering
	staq	ap|mc.fault_time	save fault time in machine conditions
	staq	pds$time_1	and in pds
	aos	pds$vtime_count	check for recursive virtual metering
	tpnz	already_metering	..
	sbaq	pds$cpu_time	calculate virtual time
	staq	pds$time_v_temp	save until RCU time
already_metering:
	tsx	.ret,reset_mode_reg	reset mode register (turn on history regs)

	rsw	0		get set for possible tracing
	sta	sst$+sst.trace_sw

	lxl1	prds$processor_tag	get set for masking
	lprpab	scs$mask_ptr,1
	xec	scs$read_mask,1
	staq	ap|mc.mask
	ldaq	scs$sys_level
	xec	scs$set_mask,1
	xec	fault_ctr_table,1	AB => per-cpu fault ctr array
	aos	ab|0+FAULT_NO_DF1
	inhibit	off

	eppab	sp|0		save sp in ab
	eppsp	prds$+stack_header.stack_begin_ptr,*  get set for push macro
	epbpsb	sp|0		set stack base pointer
	push

	spriab	sp|stack_frame.prev_sp  now save previous sp
	lca	scu.ir.parm+1,dl	make sure parity mask is OFF
	ansa	ap|mc.scu.indicators_word

"
"	The following code checks to make sure we don't get a fault while
"	we're on the PRDS.
"
	lxl7	ap|mc.prs+6*2	however, if were not in ring 0, OK
	canx7	=o700000,du
	tnz	masked_switched_legal		not in ring 0, OK
	ldx7	ap|mc.prs+6*2	get SP at time of fault
	cmpx7	lp|prds_link	compare segment number to that of PRDS
	tze	fault_while_on_prds	bad news, return to bos
masked_switched_legal:

	tsx	.2ret,init_savex	initialize save_stack for x7
	tsx	.ret,lock_ptl	lock the page table lock
pft_lret:

	stz	entry_sw		fault entry, set switch 
	stz	ap|mc.errcode	zero error code for later use

	eppap	pds$page_fault_data	restore pointer to fault data
	epplb	dseg$		get pointer to descriptor segment

"	If a page fault is taken during an instruction fetch then the CU status
"	bit IF (instruction  fetch) will be ON.

	lxl1	ap|mc.scu.cu_stat_word Get CU status bits
	canx1	scu.cu.if,du	Is IF bit ON? 
	tze	regular_page_fault	not on, must be normal one (so use TSR)

	lda	ap|mc.scu.ppr.psr_word For an IF page fault the PSR is valid
	lxl1	ap|mc.scu.apu_stat_word Reset x1 to APU status bits.
	tra	all_page_faults	Go join normal path
regular_page_fault:
	lxl1	ap|mc.scu.apu_stat_word see what type of fault
	canx1	scu.apu.ptw+scu.apu.dsptw+scu.apu.ptw2,du is it a normal page fault?
	tnz	*+2		if one of these bits is on we're OK
	tsx5	page_fault_error	"ERROR - BAD SCU DATA NO APU BITS"
	lda	ap|mc.scu.tpr.tsr_word This is the normal path. The segno is in TSR

all_page_faults:
	ldq	ap|mc.scu.ca_word	page number is derived from CA field
	canx1	scu.apu.ptw2,du	is it a pre-page (decimal instruction)
	tze	*+2		no, don't increment page number
	adlq	1024,du		yes, up the page number by 1
	ana	scu.tpr.tsr_mask,du	leave just the segno in AU
	sta	temp		save for bound comparison.
	als	1		multiply by sdw size
	eax	.tem,0,au		put in x0
	lda	lb|1		get DSEG sdw bounds word (bound 377770)
	ora	=o7,du		convert bounds to max segno
	cmpa	temp		this is segno 377770000000
	tmi	bad_segno		Segno out of reason.
	stq	temp		save tsr word offset
	ldaq	lb|0		get addr of descriptor segment from its sdw (DBR)
	arl	sdw.add_shift	move to fixed bin
"				see if dseg paged
	sbla	unpaged_page_tables$0+upt.sst_absloc	convert to page table pointer
	tmi	not_dseg		unpaged page tables are below sst
	eppbp	sst|0,al		make bp point to first page table word
	eaa	0,.tem		get two times segno
	arl	10		get page number of dseg

	canx1	scu.apu.dsptw,du	Is this a page fault on the dseg?
	tnz	dseg_page_fault	Yes, skip the following code

	lda	ptw|0,au		get correct PTW for dseg
	cana	ptw.valid,dl		..
	tze	quit		there is fault, go take it
not_dseg:
	ldaq	lb|0,.tem		look for seg-fault, get sdw of segment
	cana	sdw.valid,dl	see if directed fault set
	tze	quit		go handle seg-fault
	staq	pf_sdw		save access fields
	arl	36-24		move to fixed bin
	sbla	sst|sst.ptwbase	no seg-fault, get page table index
	eppbp	sst|0,al		get the astep (+aste_size)
	ldq	temp		get back word offset
	qrl	page_power	convert to page number
	tra	found_faulted_page	skip code for dseg faults

dseg_page_fault:
	stq	pf_sdw+1		address word doesn't matter for dseg
	eaq	0,au		copy page number into q
found_faulted_page:
	eax	.aste,ptw|-aste_size get real astep into x3
	eppbp	ptw|0,qu		adjust ptwp to point to the actual PTW
	eax	.ptw,ptw|0	and save it in x2

	ldq	ptw|0		get PTW in q-reg
	canq	ptw.valid,dl		see if fault still exists
	tnz	quit		no, return
	canq	ptw.os,dl		is the page out of service?
	tnz	short_page_fault	process short pf
	canq	ptw.er,dl		is page in error from earlier read?
	tnz	page_read_error	yes, signal an error.

	lda	ast|aste.npfs_word,.aste see if no-page-fault-switch is on
	cana	aste.npfs,du	..
	tnz	create_segment_fault


"
"	Here the commitment has been made to actually
"	read in one page of virtual memory.
"

	tsx	.ret,pc_trace$page_fault


	tsx	.ret,read_page
	    tra	readin.goon	must wait for page
	    tra	readin.goon	
	    tra	wait_any_event_apte	wait for volmap event (in APTE by now)

readin.goon:
	tsx	.ret,pc_trace$page_fault_end
	tsx	.ret,page_util_enter enter the page in the trace list
"
"	The following are various per-process meters about paging activity
"	as well as some system meters about where page faults are
"	happening.
"
	lda	ast|aste.per_process_word,.aste count pdir faults
	cana	aste.per_process,du
	tze	*+2
	increment	sst|sst.pdir_page_faults

	lxl	.tem,ast|aste.par_astep,.aste	count faults in segs off dirs off root
	lxl	.tem,ast|aste.par_astep,.tem
	cmpx	.tem,sst|sst.root_astep+1
	tnz	*+2
	increment	sst|sst.level_1_page_faults

	lda	ast|aste.dirsw_word,.aste	count dir pfts
	cana	aste.dirsw,dl
	tze	readin.meter_ndir_pft	meter in AST
	increment	sst|sst.dir_page_faults
	tra	readin.meter_sgdir_join

readin.meter_ndir_pft:			"count in ASTE
	cana	aste.gtus,du		" gtus in same word as dirsw
	tnz	readin.meter_sgdir_join	" if transparent, can't count faults
	lda	ast|seg_aste.usage,.aste
	adla	1,dl			LOGICAL arith, please
	sta	ast|seg_aste.usage,.aste

readin.meter_sgdir_join:
	lda	pds$page_fault_data+mc.scu.tpr.trr_word  count ring 0 page faults
	cana	scu.tpr.trr_mask,du
	tnz	*+2
	increment	sst|sst.ring_0_page_faults

	aos	pds$page_waits	meter page waits
	aos	pds$number_of_pages_in_use
	ldq	sst|sst.nused	number of available pages
	eppbb	pds$apt_ptr,*	can also be used to reference tc_data
	epbpbp	bb|0		get pointer to base of apt
	lda	tc_data$n_eligible	make sure it isn't zero (can it ever be?)
	tze	no_eligible
	sta	temp
	div	temp		divide by the eligibility
	eaa	0		clear a-reg
	staq	temp		save measurement
	cmpq	pds$number_of_pages_in_use  are we in equilibrium
	tmi	in_equilibrium	yes
	ldq	pds$number_of_pages_in_use  until then use this value
	staq	temp		save it as the measure
	asq	temp+1		which is doubled when not in equilibrium
in_equilibrium:
	adaq	bp|cumulative_memory_usage
	staq	bp|cumulative_memory_usage
	ldaq	temp		reload measure for updating apte.paging_measure
	adaq	bb|apte.paging_measure add the paging measure
	staq	bb|apte.paging_measure and save it again

no_eligible:
	ldx2      bb|apte.wct_index
	tze	skip_pinning	no WCTEs yet (initialization)
"				bp -> to base of apt (set above)
	lxl	.tem,bp|wcte.pin_weight,2 get pin weight
	stx	.tem,cme_pin_counter,*.cme

skip_pinning:
	epp	sst,sst$		restore sst ptr

          sxl       .cme,cmep           save cmep
          tsx       .ret,claim_mod_core write out mod pages
          lxl       .cme,cmep
	ldx	.ptw,ptp_astep	reload .ptw
	lxl	.aste,ptp_astep	and .aste

	eppbp	tc_data$		restore tcd ptr
	read_clock		meter page fault time
	sbaq	pds$time_1	get cpu time for this fault
	adaq	bp|cpu_pf_time	keep sum of times
	staq	bp|cpu_pf_time
	aos	bp|cpu_pf_count	and count of faults

"
"
"	Wait for the page fault as appropriate.
"
	epp	ptw,sst|0,.ptw


wait_ret:			"here to wait for non/pd i/o
	lda	ptw|0		make this check just in case..
	cana	ptw.os,dl
	tze	quit

				"tra to pxss to wait for PTW I/O.
	ldq	cme.notify_requested,dl set flag for notify
	orsq	cme_flags,*.cme ..
	eaa	0,.ptw		create PTW event
wait_page_fault_event:
	arl	18		right justified
wait_any_event:
	eppap	pds$apt_ptr,*	get apte ptr
	sta	ap|apte.wait_event	make it where can get notified.

wait_any_event_apte:
	store_clock pds$time_1
	tsx	.ret,unlock_ptl	dump posting queue, possibly notifying
				"this event, and unlock ptl.
	meter_time pds$time_1,sst|sst.pf_unlock_ptl_time,sst|sst.pf_unlock_ptl_meterings

	tra	pxss$page_wait


"
"
"	End of page fault processing here.
"	These labels restart the page fault.
"
quit:	tsx	.ret,unlock_ptl	unlock page table lock

wait_return:			"return location from pxss$page_wait
	eppap	pds$page_fault_data	get pointer to fault data

	read_clock
	cmpaq	pds$first_covert_event_time
	tpl	wait_return_no_delay

" must wait until first_covert_event_time is met- that is, until covert channel
" time is up

	ldaq	pds$first_covert_event_time
	staq	pds$arg_1
	tra	pxss$page_pause	" will return at wait_return

wait_return_no_delay:
	inhibit	on
	ldaq	ap|mc.mask	retrieve previous mask
	oraq	channel_mask_set	turn on all channel mask
	anaq	scs$open_level	turn off unconfigured channel mask bits
	lxl1	prds$processor_tag
	lprpab	scs$mask_ptr,1
	xec	scs$set_mask,1

	ldaq	prds$+stack_header.stack_begin_ptr  restore stack end pointer for PRDS
	staq	prds$+stack_header.stack_end_ptr

	odd
	tsx	.ret,meter_virtual_time measure time to be taken out as virtual

restart_fault:
	lpl	ap|mc.eis_info	restore EIS pointers and lengths
	lreg	ap|mc.regs
	lpri	pf_prs,*
	rcu	pf_scuinfo,*
	inhibit	off

"

"
"	Error and unconventional cases in page fault processing.
"
fault_while_on_prds:
	lca	trbl_prds_pf,dl	flag for page fault on prds
	sta	scs$sys_trouble_pending
	lda	pds$processid	save our process ID
	stac	scs$trouble_processid  if we're the first
	lxl1	prds$processor_tag
	cioc	scs$cow_ptrs,1*	send connect to self
	nop
	nop
	nop
	tra	fault_while_on_prds
"
"	Come here when fault taken on page already being read.
"

short_page_fault:
"	Compute cme addr so that wait_ret can turn on notify_requested.
"

	increment	sst|sst.short_pf_count	meter

	iftarget	l68	" Shift different on L68/ADP
	   qrl	ptw_to_cmep.rl
	ifend
	iftarget	adp
	   anq	ptw_add_mask,du	" Must mask off all but page number
	   qls	ptw_to_cmep.ls
	ifend

	eax	.cme,sst|sst.cmp,*qu point to cme.
	tra	wait_ret		and wait for the page

"
"	Error bit set by done_ (done_read). Signal in
"	faulting process.
"
page_read_error:

	tsx	.ret,disk_offlinep	is disk down as per pvt?
	 tra	wait_any_event	yes, wait for it, event in A

	lca	ptw.er+1,dl	turn off error flag
	ansa	ptw|0		in PTW

	lda	PAGE_ERROR_IOERR,dl
	eppab	ast|0,.aste	ASTE
	tra	errquit

bad_segno:
	lda	PAGE_ERROR_BADFAULT,dl
	eppab	null,*
	tra	errquit

errquit:	sta	pc_err_type
	sprpab	pc_err_astep
	sprp	ptw,pc_err_ptwp

	tsx	.ret,unlock_ptl

"
"	Call pc_signal to copy machine conditions, and otherwise set
"	up for the signaller

	ldaq	pc_signal_arglist
	staq	arg
	eppap	pc_err_type
	spriap	arg+2
	eppap	pc_err_astep
	spriap	arg+4
	eppap	pc_err_ptwp
	spriap	arg+6
	call	pc_signal$pc_signal(arg)

"
"	Now change the stack pointer so that if a process takes a page
"	fault while signalling which also gets an error (RQO possibly)
"	that we don't crash the system because our sp will still point
"	to the PRDS.
"
	ldaq	prds$+stack_header.stack_begin_ptr
	staq	prds$+stack_header.stack_end_ptr  reset stack end pointer
	eppap	pds$signal_data
	eppsp	ap|mc.prs+6*2,*	change sp to that at time of the fault

"
"	Now complete the virtual time calculation that were by-passed because we did
"	not do an RCU.
"
	tsx	.ret,meter_virtual_time
	tra	signaller$signaller	now let the signaller do the work

"	data for signal call.


" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	pread
"
"	Entry to read a page into core.
"
"	Call is:
"		call page$pread(astep,pageno,waitev)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

pread:
	push
	stz	ap|6,*
	lda	read_entry,dl	set entry switch
	sta	entry_sw
	tsx	.2ret,init_savex	set up stack

pread.loop:			"may have paged in 2 or more stages, tho.
	eppap	sp|stack_frame.arg_ptr,*
	eppbp	ap|2,*
	epp	sst,sst$
	eppbp	bp|0,*
	eax	.aste,bp|0
	lda	ap|4,*
	eax	.ptw,bp|aste_size,al	 point to ptw
	epp	ptw,sst|0,.ptw

	lda	ptw|0		is page in?
	cana	ptw.valid,dl
	tnz	return		yes, no problem.

	cana	ptw.er,dl		error from previous read?
	tze	pread.read_page	no, just read

	tsx	.ret,disk_offlinep
	 tra	pread.wait_any	go wait global event if needed

pread.read_page:
	tsx	.ret,read_page	do some work.
	 tra	pread.wait	must wait, indicate or loop
	 tra	pread.loop	must check again.

	eppap	pds$apt_ptr,*	retrieve wait event
	lda	ap|apte.wait_event
	 tra	pread.wait_any	volmap event
pread.wait:


pread.wait_ret:
	arl	18		convert to wait event
pread.wait_any:
	eppap	sp|stack_frame.arg_ptr,* retrieve arg pointer
	sta	ap|6,*		return wait event
	tra	return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	pwrite
"
"	Entry to write a page out.
"
"	Call is:
"		call page$pwrite(astep,pageno)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " "  "

pwrite:
	push
	lda	write_entry,dl	set up entry switch
	sta	entry_sw
	eppbp	ap|2,*		get pointer to APT
	eppbp	bp|0,*
	epbpbb	bp|0		let bb point to base of sst
	eax	.aste,bp|0
	lda	ap|4,*		get page number
	eax2	bp|aste_size,al
	eppbp	sst|0,.ptw	make sure bp points to PTW
	lda	ptw|0		pick up page table word

	iftarget	l68	" Shift different on L68/ADP
	   arl	ptw_to_cmep.rl
	ifend
	iftarget	adp
	   ana	ptw_add_mask,du	" Must mask off all but page number
	   als	ptw_to_cmep.ls
	ifend

	eax	.cme,sst|sst.cmp,*au
	tsx	.2ret,init_savex	initialize save stack for x7
	tsx	.ret,write_page


	tra	return
" 
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	pcleanup
"
"	Entry to get a page out of core.
"
"	Call is:
"		call page$pcleanup (astep, pageno)
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

pcleanup:
	push
	lda	cleanup_entry,dl
	sta	entry_sw

	tsx	.2ret,init_savex_bb

	epp	ptw,ap|2,*
	epp	ptw,ptw|0,*	get astep
	eax	.aste,ptw|0
	lda	ap|4,*		get pageno
	eax	.ptw,ptw|aste_size,al
	epp	ptw,sst|0,.ptw

	lda	ptw|0		get ptw
	cana	add_type.disk+ptw.os,dl
	tze	*+2
	tsx5	page_fault_error	"ERROR - PCLEANUP: CALLED ON BAD-STATE PAGE

	iftarget	l68	" Shift different on L68/ADP
	   arl	ptw_to_cmep.rl
	ifend
	iftarget	adp
	   ana	ptw_add_mask,du	" Must mask off all but page number
	   als	ptw_to_cmep.ls
	ifend

	eax	.cme,sst|sst.cmp,*au
	arl	cmep_to_coreadd.rl
	sta	core_add

	lca	ptw.valid+1,dl
	ansa	ptw|0		turn off ptw access

	tsx	.2ret,check_accessible	" only CAM if needed
	tsx	.ret,cam_cache$cam_cache	make sure it takes

	tsx	.ret,cleanup_page	do the work.
	return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	read_page, read_page_abs
"
"	Subroutine called by tsx7 to read a page into core (or if
"	the page has never beeen referenced it will zero the core).
"	A free block of core is found and possibly several 'writes' are
"	queued in searching for the free core for the read_page entry.
"	For the read_page_abs entry the free block of core
"	specified by the caller is used.
"
"	tsx7	read_page
"	<return with wait event in Areg>
"	<return if page in memory>
"	<return with volmap wait event set in APTE>
"
"	The subroutine expects
"
"		x2 = pointer to PTW
"		x3 = pointer to AST entry
"		bp = pointer somewhere into SST
"		bb = pointer to base of SST
"
"	In addition, the read_page_abs entry expects
"
"		x4 = pointer to core map entry of free block
" " " " " " " " "" " " " " " " " " " " " " " " " " " " " " " " " "

read_page_abs:
	tsx	.2ret,savex	recursive use of index 7

	tsx	.ret,check_allocation	make sure we have disk.
	 tsx5	page_fault_error	"ERROR - OOPV ON EHS SEG"
	 tra	read_page_abs.apte_event	volmap event

	tra	read_page_join

read_page_abs.apte_event:
	eppap	pds$apt_ptr,*	event is in APTE
	lda	ap|apte.wait_event
	tra	unsavex_2		return to caller

read_page:
	tsx	.2ret,savex	recursive use of index 7

	tsx	.ret,check_quota	check for quota overflow
	tsx	.ret,check_allocation is there disk available?
	 tra	read_page.oodev	no disk on this PV
	 tra	unsavex_2		must wait for volmap event

	stx	.ptw,ptp_astep	save x2 and x3 for now
	sxl	.aste,ptp_astep		..
	tsx	.ret,find_core	find a free block of core
	ldx	.ptw,ptp_astep	restore x2 and x3
	eppbp	sst|0,.ptw	make sure bp points to PTW as well
	lxl	.aste,ptp_astep		..
"
read_page_join:

"	At this point, a cme to ptw binding is established.  To validate the
"	assumptions of pc_recover_sst, it must be done in following order:
"		Auxiliary info into CME
"		cme.ptwp <= ptwp
"		ptw.add <= CORE

	lca	   ptw.phm+ptw.phm1+ptw.er+1,dl  " turn off bad bits.
	ansa	ptw|0
	lda	ptw|0		copy device address to core map entry
	staddra	cme_devadd,*.cme store address from ptw into cme
	lca	   cme.io+cme.phm_hedge+cme.removing+cme.notify_requested+1,dl
	ansa	cme_flags,*.cme clear random flags

	sxl	.aste,cme_astep,*.cme Associate astep with cme, not ptp yet.
"	Do not store ptwp in cme until cme is ready, core clear, or ptw os.


	eaa	0,.cme		copy rel(cmep) to a-reg
	sbla	sst|sst.cmp+1	to get core address
	arl	cmep_to_coreadd.rl
	sta	core_add		save core address

	ldq	aste.init,du	turn off init bit in aste
	orsq	ast|aste.init_word,.aste	..
	ersq	ast|aste.init_word,.aste	..
	ldq	ast|aste.np_word,.aste increment number of pages in core
	anq	aste.np_mask,dl
	tnz	read.incr_np
"
" Reading in the first page causes dtu to advance.  Also, the dtm may be
" advanced.  Lets see.
"
	ldq	1,dl		this will advance to 1 page
	szn	pds$throttle_segment_state_changes
	tze	read.set_np	don't count events
	szn	entry_sw
	tnz	read.set_np	only count on fault side

" Count this event.  Our assumptions:
" dtm -	w access implies that we can (and must assume we will) advance dtm.
"	Advancing dtm is always lower class visible since it propogates up
"	the hierarchy.  However, we know that dirs advance dtm only when 
"	they want to (in sum$dirmod), so we don't count dirs as setting 
"	dtm here.
"
" dtu -	w access implies that our authorization equals the access class 
"	of the object, hence our setting dtu is not lower class visible.
"	However, multi-class and directories violate this rule.
"
" Hence: a non-directory, multi-class writable object advances dtu and dtm
" in a lower class visible way.  All other cases advance either dtu or dtm
" but not both.

	lda	pf_sdw+1
	cana	sdw.write,du	check for write
	tze	read.covert_1	no write
	lda	ast|aste.dirsw_word,.aste " (also multi_class word)
	cana	aste.multi_class,du
	tze	read.covert_1	non-multi-class
	cana	aste.dirsw,dl
	tnz	read.covert_1	is a dir

	tsx	.ret,limit_covert_channel	both dtu and dtm set
read.covert_1:
	tsx	.ret,limit_covert_channel	only dtu or dtm set
	ldq	1,dl		advance np to 1 page
	tra	read.set_np

read.incr_np:
	adlq	1,dl
	erq	ast|aste.np_word,.aste
	anq	aste.np_mask,dl
read.set_np:
	ersq	ast|aste.np_word,.aste

	lda	cme_devadd,*.cme  pick up cme devadd
	cana	add_type.non_null,dl is there an address?
	tnz	*+2		must have real allocation here
	tsx5	page_fault_error	"ERROR - NO ALLOCATION IN PTW: READ_PAGE"
	als	0		is it a real address?
	tpl	must_read		yes, actually read it

	"
	"Make zeroes for a predeposited address.
	"
	"tra	read.create_zeros	is right on the next page
"
"
"	Page had either a null or nulled address in PTW.
"	Create a fresh page of zeroes.
"

read.create_zeros:
	lda	ast|aste.records_word,.aste
	adla	=o001000,dl		increment records used
	era	ast|aste.records_word,.aste
	ana	aste.records_mask_inner,dl
	ersa	ast|aste.records_word,.aste

" Adding a page can be a covert event, if this is a multi-class object
" (records used, etc. lower class visible) or if this is a dir without
" terminal quota between it and the nearest upgraded node.
" We don't have to worry about questions of setting csl/ru since the only
" cases where page creations are covert events are cases where the page
" creations are performed by trusted code themselves, and in which we know
" that pages are created serially.  The user cannot create any random page
" in these segments, only the next.  Thus, csl and ru contain the same
" information, even though ru may later become less than csl if some of
" these new pages end up zero.

	szn	pds$throttle_segment_state_changes
	tze	read.bump_quota	don't count events
	szn	entry_sw
	tnz	read.bump_quota	only on fault side

	lda	ast|aste.multi_class_word,.aste
	cana	aste.multi_class,du
	tze	read.create_check_dir
	tsx	.ret,limit_covert_channel	multi-class
	tra	read.bump_quota

read.create_check_dir:
	cana	aste.dirsw,dl
	tze	read.bump_quota	non-dir

" We have a dir.  We shall do a special bump quota which checks for
" terminal-ness.

	tsx	.ret,bump_quota_covert_check increment used
	tsx	.ret,limit_covert_channel	upgraded found first
	tra	read.quota_bumped

read.bump_quota:
	tsx	.ret,bump_quota	increment used
read.quota_bumped:
	increment	sst|sst.new_pages	meter new pages created
	tsx	.ret,clear_core	zero out the core
"
"	Now it is safe to store .ptw in cme
"
	stx	.ptw,cme_ptwp,*.cme
	lda	core_add		pick up core address again
	als	coreadd_to_ptw.ls
	ora	add_type.core,dl
	staddra	ptw|0		store in ptw

	lda	ptw.phu+ptw.valid+df1,dl make used, accessible, refresh bit
	orsa	ptw|0

	stx	.aste,temp	calculate page number
	eax	.tem,1-aste_size,.ptw by subtracting astep from (ptwp-aste_size+1)
	sblx	.tem,temp
	stz	temp
	sxl	.tem,temp		save in temp
	lda	ast|aste.csl_word,.aste pick up current csl
	ana	aste.csl_mask_inner,du
	arl	aste.csl_shift
	cmpa	temp		compare ...
	tpl	unsavex_1		csl already larger than this
	ldq	temp		retrieve new csl value
	qls	aste.csl_shift	position for store into ASTE
	erq	ast|aste.csl_word,.aste
	anq	aste.csl_mask_inner,du
	ersq	ast|aste.csl_word,.aste
	tra	unsavex_1
"
" covert channel test - update covert channel event count, test bandwidth
"
limit_covert_channel:
	aos	pds$covert_event_count
	tmi	0,.ret		not enough events to monitor, yet

" arriving here, we need to determine the bandwidth of these covert channel
" events and possible audit or delay

	read_clock
	sbaq	pds$first_covert_event_time
	cmpaq	covert.big_time
	tpl	covert.reset_clock		time too great to count
	div	sst|sst.seg_state_change_limit usecs/bit in q
	stq	temp			and temp
	mpy	sst|sst.audit_seg_state_change_bw
	cmpaq	covert.million
	tpl	covert.test_delay		usecs/bit*max_bps<1000000

" audit here

	increment	sst|sst.audit_seg_state_chg
	tsx	.2ret,page_error$excessive_seg_state_chg

covert.test_delay:
	ldq	temp
	mpy	sst|sst.max_seg_state_change_bw
	cmpaq	covert.million
	tpl	covert.reset_clock		usecs/bit*max_bps<1000000

" delay process

	increment	sst|sst.delayed_seg_state_chg

	ldaq	covert.million
	div	sst|sst.max_seg_state_change_bw  desired usecs/bit
	sbq	temp			   delay as usecs/bit
	mpy	sst|sst.seg_state_change_limit   delay in aq
	staq	pds$first_covert_event_time	   temp storage
	adlaq	sst|sst.seg_state_chg_delay	" this isn't really correct,
				" this is how long we want to delay,
				" not how long we will - but it's not
				" worth metering the real delay
	staq	sst|sst.seg_state_chg_delay

	read_clock			set time to delay until
	adaq	pds$first_covert_event_time	see wait_return for use of time
	tra	covert.reset

covert.reset_clock:
	read_clock
covert.reset:
	staq	pds$first_covert_event_time
	lca	sst|sst.seg_state_change_limit
	sta	pds$covert_event_count
	tra	0,.ret

	even
covert.big_time:
	oct	0,377777777777
covert.million:
	dec	0,1000000
"
"
"	Page had non-null add type. Must actually read page in.
"	PTW is in A register.
"

must_read:
	sta	devadd		save device address in stack


	tsx	.ret,get_pvtx	get segment pvtx for fault

read.must_rd.merge:
	tsx	.ret,device_control$check_ckdv  see if checking device incomplete
	tsx	.ret,store_pattern	if so, store pattern

"
"	Set up os bit before storing ptwp in cme, so page goes back in pc_r_sst.
"
	lca	cme.io+1,dl	set io flag to "read"
	ansa	cme_flags,*.cme

	lda	ptw.os,dl		turn it on
	orsa	ptw|0

	stx	.ptw,cme_ptwp,*.cme


	lda	core_add		set up ptw afresh
	als	coreadd_to_ptw.ls
	ora	add_type.core,dl
	staddra	ptw|0		put in coreadd

	tsx	.ret,thread_out	OS out of list

	lda	int+pri,dl	(almost) always interrupt on reads
	sta	inter
	tsx	.ret,device_control$dev_read  read the page into core
	eaa	0,.ptw		ptw is he wait event
	tra	unsavex		wait this event
"
"
"	Peculiar exits of read_page
"

read_page.oodev:			"out of physical volume.
				"Signal a segfault.
	increment	sst|sst.oopv	meter

	lda	aste.pack_ovfl,dl	turn on aste bit
	orsa	ast|aste.pack_ovfl_word,.aste	in AST

	szn	entry_sw		better be a page_fault
	tze	*+2
	tsx5	page_fault_error	"ERROR - OOPV ON READ_PAGE CALL"
create_segment_fault:
	eppap	pds$page_fault_data	address mc
	lda	ap|mc.scu.apu_stat_word
	cana	scu.apu.dsptw,dl	is this ds fault?
	tze	*+2
	tsx5	page_fault_error	"ERROR - SETFAULT DESCRIPTOR SEGMENT"

	lxl	.tem,ap|mc.scu.cu_stat_word was it IF?
	canx	.tem,scu.cu.if,du
	tnz	*+2
	lda	ap|mc.scu.tpr.tsr_word get TSR if not IF
	als	1		double segno
	ana	=o177776,du

	iftarget	l68	" On Level 68 only, must also set df_no to zero
	  lcq	sdw.valid+sdw.df_no_mask+1,dl
	ifend
	iftarget	adp
	  lcq	sdw.valid+1,dl
	ifend

	ansq	dseg$,au
	tsx	.ret,cam_cache$cam
	tra	quit		seg mover will handle

"
" " " " " " " " " " " " " " " " " " " " " " " " " " "
"					  "
"	disk_offlinep			  "
"					  "
"	Is the seg's disk offline?		  "
"					  "
"	tsx	.ret,disk_offlinep		  "
"	 tra	yes, event in A		  "
"	null	no			  "
"					  "
" " " " " " " " " " " " " " " " " " " " " " " " " " "

disk_offlinep:
	tsx	.2ret,savex
	tsx	.ret,get_pvtx
	tsx	.ret,device_control$disk_offlinep
	 tra	*+2		offline
	tra	unsavex_1		not offline

	lca	ptw.er+1,dl	turn OFF the error bit. This is
	ansa	ptw|0		so that when the guy tries again
				"when the disk finally comes back,
				"the next call to disk_offlinep
				"doesnt cause a signal.
	lda	disk_offline_event
	tra	unsavex

disk_offline_event:
	aci	"dskw"
"
"
"	Check to see if page has allocation. Give one
"	if needed.
"
"	tsx7	check_allocation
"	<return in out of room on physical volume>
"	<return if must wait volmap event, event set in APTE>
"	<return if page has allocation>

check_allocation:
	lda	ptw|0		grab ptw
	cana	add_type.core,dl
	tze	*+2		make sure we're doing this right
	tsx5	page_fault_error	"ERROR - CORE ADDR IN PTW: READ_PAGE"
	cana	   add_type.disk,dl    " real devadd?
	tnz	2,.ret		yes, that's fine.

	stx	.aste,pageno	ASTE offset
	eax	.tem,-aste_size,.ptw
	sblx	.tem,pageno	Page number
	eaq	0,.tem
	qrl	18
	stq	pageno
	ldq	ast|aste.vtocx,.aste
	anq	-1,dl		VTOCE Index
	stq	vtocx

	tsx	.2ret,savex	enter free_store
	tsx	.ret,get_pvtx	get pvtx
	tsx	.ret,free_store$withdraw  get an address
	 tra	unsavex		OOPV
	 tra	unsavex_1		volmap wait event

"
"	Put nulled address where null one was. With respect to pc_recover_sst,
"	this is all the same.
"
	lda	devadd
	ora	ptw.nulled,du	this is semikilled address
	sta	devadd

	staddra	ptw|0		put in new address
unsavex_2:
	ldx	.ret,stackp,di
	tra	2,.ret		return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	find_core_
"
"	Subroutine to find a block of free core.
"
"	Call is:
"		tsx7 page_fault$find_core_
"
"		tsx7 find_core
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	equ	pre_seek_limit,15	" Mod failure detection

find_core_:			" Externally available to ALM PC

find_core:
	tsx	.2ret,savex	save index 7
	increment	sst|sst.needc	meter times core was needed
	lca	1,du		init ctr for out-of-core to -2**18
	sta	total_steps
fploop:
	stz	count		zero count of steps
	lca	pre_seek_limit,dl	initialize mod failure ctr
	sta	temp1
	ldx	.cme,sst|sst.usedp	set cmep 

"     re-entry from find_core.ptw_ng and find_core.skip_meter_mod

fc1:
	lda	cme_flags,*.cme	check for total acceptability
	cana	cme.removing+cme.abs_w,dl
	tnz	find_core.cme_ng	something unusable- meter & skip

	ldx	.ptw,cme_ptwp,*.cme	Is core free? Set ptp.
	tze	found_core	yes, take it.
	epp	ptw,sst|0,.ptw	point at ptw
	lda	ptw|0		let's examine the ptw...

	cana	ptw.phu+ptw.wired+ptw.os+ptw.phm+ptw.phm1,dl	" make quick check
	tnz	find_core.ptw_ng	something in ptw is unacceptable.

	ldx	.tem,cme_pin_counter,*.cme
	tpnz      find_core.skip_pinned  do not evict if still pinned

"
"	Now attempt to evict the page.
"
"
"
"	Here is where access is taken off for a potential eviction.
"	If we lose timing window, access comes back.  Note that core address
"	in PTW stays valid until cleanup_page has run, and contents of
"	core page can be ignored (we are sure page is pure).

	lca	ptw.valid+1,dl	set directed fault 1 in ptw
	ansa	ptw|0		..
	lda	ptw|0		make sure coreadd gets set
	ana	ptw_add_mask,du	" Mask off all but the page address bits
	arl	ptw_to_coreadd.rl	" Clear the right place in the cache
	sta	core_add		..

	lxl	.aste,cme_astep,*.cme " get astep
	tsx	.2ret,check_accessible	" CAM if needed
	tsx	.ret,cam_cache$cam_cache " make sure the access gets turned off

	lda	ptw|0		retrieve ptw for modified bit test
	cana	ptw.phm+ptw.phm1+ptw.wired,dl has the page been modified now? or wired?
	tnz	restore_ptw_access	appear to have lost race

	stx	.cme,sst|sst.usedp	this frame now LRU
	tsx	.ret,cleanup_page	evict the page

found_core:
	increment	sst|sst.steps	meter
	ldx	.tem,cme_fp,*.cme move to MRU
	stx	.tem,sst|sst.usedp
	tra	unsavex		find_core returns
"
"
"	PTW has some kind of unacceptable state: possibilities:
"
"   1.	out of service-		illegal- crash system
"   2.	wired-			skip and meter
"   3.	modified-			leave alone for claim_m_c to evict/unuse.
"   4.	nypd-			leave alone for c_m_c to write to pd if unused.
"   5.	used-			"unuse" for replacement algorithm.

find_core.ptw_ng:
	cana	ptw.os,dl		this ought not be..
	tze	*+2
	tsx5	page_fault_error	"ERROR - FINDCORE FINDS OS ON LIST

	cana	ptw.phm+ptw.phm1,dl	has it been modified?
	tnz	find_core.skip_meter_mod must be written, can't take.
				"don't care whether used or not -must leave
				"both bits for c_m_c, who will off them.

	cana	ptw.wired,dl	is it wired?
	tnz	find_core.skip_wired
"
"	Must be used, skip and meter, impl. replacement algorithm
"	by turning bit off.
"
	increment	sst|sst.skipu	count used.
	lca	ptw.phu+1,dl	turn off phu bit in PTW
	ansa	ptw|0
	lda	ptw.phu1,dl	turn PHU1 ON in PTW
	orsa	ptw|0

skip:
	ldx	.cme,cme_fp,*.cme	go to next core map entry in list
	increment	sst|sst.steps	count step
	aos	total_steps	up count of steps taken looking for core
	tmi	fc1		if still neg, loop on.
	tra	page_error$out_of_core Multics not in operation.


restore_ptw_access:			"come here when 2nd cpu mod in window
	lda	ptw.valid,dl		remove directed fault from ptw
	orsa	ptw|0		..
find_core.skip_meter_mod:
	increment	sst|sst.skipm	count skip mod
cmod1:	increment	sst|sst.steps
	ldx	.tem,cme_fp,*.cme	pt at next cme
	cmpx	.tem,sst|sst.usedp	have we walked whole queue?
	tze	mods_excessive	will run claim_mod_core on whole mem
	eax	.cme,0,.tem	go to next cme
	aos	temp1		see if too many skipmods
	tpl	mods_excessive	too many
	tra	fc1

find_core.skip_pinned:
	increment sst|sst.fc_skips_pinned  no. of pin skips in find_core
	ldx	.tem,cme_pin_counter,*.cme
	sblx	.tem,1,du
	tmi	skip		never happen
	stx	.tem,cme_pin_counter,*.cme
	tra       skip


"
"
"	cme is unacceptable- following may be the case:
"
"   1.	removing		can't page in, must not be used. skip.
"   2.	abs_w		IN PROCESS of being abs-wired.. may not
"			page in evict_page will do it by special means,
"			must avoid getting vol map in here by accident.

find_core.cme_ng:

	cana	cme.abs_w,dl	abs wiring?
	tze	skip		no, just skip.

find_core.skip_wired:
	increment	sst|sst.skipw
	tra	skip		..

"
"	We arrive here when an excess of skips-mod have been made.
"	Potentially, every page in core can be mod and used. Hence,
"	tentatively, the fast find_core has failed. Do it the old way.
"
mods_excessive:
	stx	.cme,sst|sst.usedp save ptr to NEXT cme
	increment	sst|sst.pre_seeks_failed	meter
	tsx	.ret,claim_mod_core	do writes, may even post.
	tra	fploop		restart find_core_

"
""""""""""""""""""""""""""""""""""""""""""""""""""
"					"
"	Subroutine to evict one		"
"	page from core.			"
"					"
""""""""""""""""""""""""""""""""""""""""""""""""""

cleanup_page:
	tsx	.2ret,savex
	lxl	.aste,cme_astep,*.cme get astep

"
"	Unbind core from ptw here. For validity of pc_recover_sst, this
"	must be done in the following order:
"		Put non-core address back in ptw
"		cme.ptwp <= 000000
"		Clean up cme
"
	lda	cme_devadd,*.cme clear out ptw
	staddra	ptw|0

	lda	ast|aste.np_word,.aste subtract from count of pages in core
	sbla	1,dl
	era	ast|aste.np_word,.aste
	ana	aste.np_mask,dl
	ersa	ast|aste.np_word,.aste
	lda	ast|aste.np_word,.aste
	cana	aste.np_mask,dl	see if any pages left in core
	tnz	cleanup.np_nonzero	yes, continue

	lda	aste.init,du	no, turn init bit ON in ASTE
	ora	ast|aste.init_word,.aste	..
	sta	ast|aste.init_word,.aste  gtus is in same word, so...
	cana	aste.gtus,du	check gtus. If on, leave dtu alone
	tnz	cleanup.np_nonzero  nothing to do

	read_clock		get time
	lls	20		convert to fstime in A
	sta	ast|aste.dtu,.aste	and drop it in

cleanup.np_nonzero:
	tsx	.ret,check_synch_cleanup do housekeeping for synchronized page
	lda	ptw|0		if not live address, must adjust quota...
	cana	add_type.non_null,dl and records_used.
	tze	cleanup.rsq	null, reset recs.
	cana	ptw.nulled,du	is it nulled?
	tze	cleanup.nrsq1	not nulled, don't reset.
cleanup.rsq:
	tsx	.ret,update_csl	make sure csl is correct
	lda	ast|aste.records_word,.aste
	ana	aste.records_mask_inner,dl
	sbla	=o001000,dl	decrement records used
	tpl       cleanup.recused_okay
	szn	pvt$esd_state
	tnz	cleanup.recused_okay
	tsx5	page_fault_error	"ERROR - RECUSED WENT NEG: CLEANUP"
cleanup.recused_okay:
	era	ast|aste.records_word,.aste
	ana	aste.records_mask_inner,dl
	ersa	ast|aste.records_word,.aste
	tsx	.ret,reset_quota	deduct a quotum used
cleanup.nrsq1:
	eax	.tem,0		zero ptw correspondence
	stx	.tem,cme_ptwp,*.cme ..
	sxl	.tem,cme_astep,*.cme zero astep correspondence too
	tsx	.ret,thread_to_lru	move to head of list
	lca	ptw.phm+ptw.phm1+1,dl	" turn off mod
	ansa	ptw|0
	tra	unsavex
"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"						"
"						"
"	claim_mod_core				"
"						"
"	Tsx	.ret,claim_mod_core to sweep		"
"			up all the writes that	"
"			find_core chose not to do.	"
"						"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

claim_mod_core:
	tsx	.2ret,savex	save return
	increment	sst|sst.write_hunts	meter

mc_continue:
	ldx	.cme,sst|sst.wusedp	start at last point

mclp:	cmpx	.cme,sst|sst.usedp	are we up to find_core?
	tze	cl_done
	increment	sst|sst.claim_steps	meter steps

	lda	cme_flags,*.cme look at cme
	cana	cme.removing+cme.abs_w,dl	   " check unacceptable states
	tnz	cl_bad

	ldx	.ptw,cme_ptwp,*.cme point to ptw
	tze	cl_free		this is really bad, for
				"this cme should be
				"in front of usedp.
	epp	ptw,sst|0,.ptw	point to ptw

	lda	ptw|0		consider ptw
	cana	ptw.os+ptw.wired,dl
	tnz	cl_ptwbad
	cana	ptw.phm+ptw.phm1,dl 	" we only care about those f_c_ skipped
	tze	cl_notmod

	cana	ptw.phu,dl	see if used
	tnz	cl_used		turn off used if on

	ldx	.tem,cme_pin_counter,*.cme see if page is pinned
	tpnz      cl_pinned

	increment	sst|sst.claim_writes meters
	ldx	.tem,cme_fp,*.cme peek ahead to next cme
	stx	.tem,sst|sst.wusedp	save pointer

	lxl	.aste,cme_astep,*.cme pick up astep
	tsx	.ret,write_page	write_page will do all necessary
	tra	mc_continue

mc_end:	ldx	.cme,cme_fp,*.cme scan on into map
	tra	mclp

cl_bad:
	increment	sst|sst.claim_skip_cme	A CME had permanent unacceptable state, or RWS
	tra	mc_end

cl_ptwbad:
	increment	sst|sst.claim_skip_ptw	PTW wired
	tra	mc_end

cl_free:
	increment	sst|sst.claim_skip_free	A CME was free to claim_mod_core
	tra	mc_end

cl_notmod:
	increment	sst|sst.claim_notmod	not modified, not interesting
	tra	mc_end

cl_used:
	lcq	ptw.phu+1,dl		mod, but used.
	ansq	ptw|0			turn off used and pray for cam.
	ldq	ptw.phu1,dl		dont screw up working sets
	orsq	ptw|0
	increment	sst|sst.claim_passed_used
	tra	mc_end

cl_pinned:
	increment sst|sst.cl_skips_pinned  no. of pin skips in claim_mod
"				cme_pin_counter in x0
	sblx	.tem,1,du
	tmi	mc_end		never happen
	stx	.tem,cme_pin_counter,*.cme
	tra       mc_end

cl_done:
	stx	.cme,sst|sst.wusedp
	tra	unsavex
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	write_page
"
"	Subroutine to check to see a page should be written out.
"	If so, initiate the I/O.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

write_page:
"
"	Page has been modified
"
	tsx	.2ret,savex	recursive use of .ret
	tsx	.ret,get_pvtx	get pvtx from AST
	tsx	.ret,pc_trace$write_page
	eaa	0,.cme		compute core_add from cmep
	sbla	sst|sst.cmp+1
	arl	cmep_to_coreadd.rl	..
	sta	core_add
	lda	cme_devadd,*.cme save devadd in stack
	sta	devadd		..

	lda	ptw|0		inspect ptw
	cana	ptw.os,dl		check for o/s
	tze	*+2
	tsx5	page_fault_error	"ERROR - WRITE CALL ON OS PAGE"
	cana	ptw.phm+ptw.phm1,dl 	" if neither on, obsolete call
	tze	unsavex


	lxl	.tem,ast|aste.par_astep,.aste	dont update if no parent
	tze	write.dont_set_fms

	ldq	ast|aste.gtms_word,.aste	check global-transparent-modified-switch
	canq	aste.gtms,du
	tnz	write.dont_set_fms	if on, don't set fms

	cana	ptw.phm,dl	was fms set by pc$update_incore_fms?
	tze	write.dont_set_fms	yes, don't set it

	eax	.tem,0,.aste	copy AST parent to x0 (first time is AST)
	read_clock		get current time
	lrs	16		convert to fstime in Q
	lda	aste.fms,du	get set to turn on all superior fms's

write.set_parent_fms:
	orsa	ast|aste.fms_word,.tem
	stq	ast|aste.dtm,.tem	set dtm as well
	lxl	.tem,ast|aste.par_astep,.tem
	tnz	write.set_parent_fms

write.dont_set_fms:
	tsx	.2ret,set_up_abs_seg abs_seg1 -> page in memory, ap -> abs_seg1
	tsx	.ret,check_for_synch_hold synchronized page, not to be written
	tra	unsavex		yes - don't write

	szn	tc_data$system_shutdown  don't null pages during shutdown
	tnz	page_non_zero	yes, pretend page non-zero(don't deposit anything)
	ldq	ast|aste.dnzp_word,.aste don't null if special flag set
	canq	aste.dnzp,du	..
	tnz	page_non_zero

	lda	ptw|0		Don't null wired pages.
	cana	ptw.wired,dl
	tnz	page_non_zero

	tsx	.ret,check_for_zero	test for a zero page
	tra	page_non_zero	return here if really not zero
	lca	ptw.valid+1,dl	set directed fault 1 in ptw
	ansa	ptw|0		..

	tsx	.2ret,check_accessible	" only CAM if needed
	tsx	.ret,cam_cache$cam_cache make sure people see it

	tsx	.ret,check_for_zero	try again after turning off access
	tra	page_non_zero_a	he just modified it before we zapped access, phooey
"
"	page was all zeroes
"
	increment	sst|sst.zero_pages
	tsx	.ret,pc_trace$zero_page


	lda	ptw.nulled,du	null the disk addr in cme.
	orsa	cme_devadd,*.cme

	lda	aste.fmchanged,du	turn on map changed bit
	orsa	ast|aste.fmchanged_word,.aste
	tsx	.ret,cleanup_page	evict page from core, turns off phm.
	tra	unsavex
" 
"	come here because the page is non-zero and must be written out
"

page_non_zero_a:
	lda	ptw.valid,dl		remove directed fault from ptw
	orsa	ptw|0		..
page_non_zero:
	lda	cme_devadd,*.cme
	cana	add_type.non_null,dl is it real null?
	tnz	write.pnz.to_disk

"
"	Was a real null address- this must not be so at this point!!!
"
write.nz.was_real_null:
"
	tsx5	page_fault_error	"ERROR - NO ALLOCATION AT WRITE TIME"



write.pnz.to_disk:
	lda	unnull_mask	unnull, but not in core map
	ansa	devadd

"
"
"	Actually set up like we're gonna write.
"	Recovery strategy requires cme.io set before os set.
"

do_write:
	tsx	.ret,thread_out	OS out of list

	lda	cme.io,dl		turn on write bit in CME
	orsa	cme_flags,*.cme ..

	lda	ptw.os,dl		set ptw out of service
	orsa	ptw|0

	lca	ptw.phm+ptw.phm1+1,dl turn it off once ptw.os is on.
	ansa	ptw|0

	tsx	.2ret,check_accessible	" if needed:
	tsx	.ret,cam_cache$cam_ptws	turn it off on all cpus.

do_write.not_mod:
	stz	inter		generally don't interrupt on writes
	lda	entry_sw		see if write entry
	cmpa	write_entry,dl
	tnz	do_write.not_pri	not, continue

	lda	int+pri,dl	interrupt on write entry
	sta	inter
do_write.not_pri:
	tsx	.ret,device_control$dev_write  initiate the write
	tra	unsavex

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	done,done_
"
"	Entry (subroutine) to post the completion of I/O.
"	Call is
"		call done(core_add,errcode)
"	or
"		tsx7 done_
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

done:
	tra	core_queue_man$disk_post


done_:
	eppbb	sst$		bb must point into SST for PAGE
	tsx	.2ret,savex	save return loc in stack
	lda	core_add		get core map entry pointer
	als	coreadd_to_cmep.ls
	eax	.cme,sst|sst.cmp,*au  set up .cme

	tsx	.ret,pc_trace$done
"
"	Flags to A-reg until we know where we're headed.
"
	lxl	.tem,cme_astep,*.cme save astep for later
	stx	.tem,done_astep

	lda	cme_flags,*.cme see if a read/write sequence is active

	ldq	cme_devadd,*.cme pick up device address out of CM entry
	stq	devadd		and save in stack

	ldx	.ptw,cme_ptwp,*.cme	get ptp
	tze	page_error$error_in_done  core must be used
	eppbp	sst|0,.ptw
	lxl	.tem,ptw|0	check for out of service
	canx	.tem,ptw.os,du
	tze	page_error$error_in_done
	lxl	.aste,cme_astep,*.cme get astep

	cana	cme.io,dl		Was this a write?
	tnz	done_write	yes, go handle it
	"tra	done_read		*** is on the next page ***
"
"	done_read -- thread core in mru, 
"		   and turn on PTW access.
"

done_read:
	tsx	.ret,thread_in_mru	make most recently used

	szn	errcode		check error code
	tnz	error_on_read	error ...
"
"	Check for device incomplete
"
	tsx	.ret,device_control$check_ckdv
	 tsx	.ret,check_pattern	dvctl returns here if checking on
	  tra	done.read.no_ckdv_error c_p comes here if no error.
				   "also, dvctl comes here if not checking!
	tsx	.2ret,page_error$device_error
	tra	error_on_read	treat as fatal error

done.read.no_ckdv_error:
	lda	ptw.valid+df1,dl	turn on access
	orsa	ptw|0
	lca	ptw.os+1,dl	turn off os bit
	ansa	ptw|0

"	tra	notify_code	" (Actually, just fall through to this)
"
"

"
"
"	Post a read or write complete, with or without error.
"	Call handler for I/O to volmap_seg.
"	Cause a page faulter to restart his fault, and cause
"	call side to retry.
"
notify_code:
"
"	Check for notify_requested. If none, neither notify
"	nor idle pre_empt.
"
	lda	cme.notify_requested,dl	get flag
	cana	cme_flags,*.cme	see if on in cme
	tze	notify_end	no, just return
	ersa	cme_flags,*.cme	was on. Turn off and
				"notify/preempt.
done.notify.uncond:
	szn	tc_data$pre_empt_flag  see if we're pre-empting (and notifying)
	tnz	check_idle	we're not pre-empting. are we an idle process ?
	eaq	0,.ptw		get event from ptw addr
	qrl	18
	stq	pds$arg_1		save argument
	tra	pxss$page_notify

	entry	notify_return
notify_return:
	epp	sst,sst$		restore sst pr, possibly for done_ entry.
notify_end:
	ldx	.tem,done_astep	astep
	lda	sst|aste.volmap_seg_word,.tem see if this is a volmap_seg
	cana	aste.volmap_seg,dl
	tze	unsavex		no - return to the caller of done
	lda	sst|aste.pvtx_word,.tem
	arl	aste.pvtx_shift
	ana	aste.pvtx_mask,dl	pvtx in Areg
	tsx	.ret,volmap_page$post_io	do asynchronous stuff
	epp	sst,sst$		restore
	tra	unsavex		return to caller of done

check_idle:
	ldaq	pds$apt_ptr	see if we're an idle process
	cmpaq	prds$idle_ptr
	tnz	notify_end	no, just return
	lda	apte.pre_empt_pending,du
	eppbp	pds$apt_ptr,*
	orsa	bp|apte.flags
	lxl1	prds$processor_tag
	stc2	pds$connect_pending
	cioc	scs$cow_ptrs,1*
	tra	notify_end
"
"
"	error_on_read - put Pdisk address back in PTW
"

error_on_read:
	increment	sst|sst.page_read_errors	meter
	tsx	.ret,cleanup_page	out of core

	lca	ptw.os+1,dl	Now oocore, off os.
	ansa	ptw|0

	lda	ptw.er,dl		mark ptw as signalable
	orsa	ptw|0
	tsx	.ret,get_pvtx
	tsx	.ret,call_disk_emergency
	tra	done.notify.uncond
"
"
"	done_write - remove O/S status, 
"		   and thread core in LRU.
"

done_write:

	lca	1,dl		decrement global count of writes.
	asa	sst|sst.wtct
	tpl	*+2
	stz	sst|sst.wtct	make sure stays +.

	lda	ptw.phm+ptw.phu,dl	count uses of pages being written
	cana	ptw|0		..
	tze	*+2		not used, don't count
	increment	sst|sst.mod_during_write
	lca	ptw.os+ptw.er+1,dl	turn off OS and ERR flags.
	ansa	ptw|0
	lda	ptw.valid,dl	turn access on - it's off for synch pages
	orsa	ptw|0

	ldq	errcode		if error, go process it, passing
	tnz	error_on_write	error code in Q.

	lca	cme.phm_hedge+1,dl turn off write
	ansa	cme_flags,*.cme scheduler and pd_upflag

"
resurgo:
	lda	cme_devadd,*.cme
	cana	ptw.nulled,du	is this null?
	tze	rethread		no, ordinary write.
	era	ptw.nulled,du
	sta	cme_devadd,*.cme
	increment	sst|sst.resurrections	meter
resurgo.fmchanged:
	lda	aste.fmchanged,du	turn on fmc bit
	orsa	ast|aste.fmchanged_word,.aste
no_dblw:
rethread:
	tsx	.ret,thread_in	insert in core map at lru
	tra	notify_code	and notify waiting processes
"
"
"	error_on_write - Zero data if data error,
"		       but leave in core as modified if device inop.
"

error_on_write:	"errcode passed in Q.
	increment	sst|sst.page_write_errors meter

	canq	errflags.memory_unusable,dl	page damage or mem problem
	tnz	done.werr.deverr		


"			not pd case- analyze errcode
	canq	errflags.device_inoperative,dl	disk down?
	tnz	write_device_inop	yes, handle it

"
"	Must be data error on write
done.werr.deverr:
"
	lda	aste.damaged,dl
	orsa	ast|aste.damaged_word,.aste
	lda	aste.fmchanged,du	cause vtoce update
	orsa	ast|aste.fmchanged_word,.aste

	tsx	.ret,thread_in	get core in list
	lca	ptw.valid+1,dl	turn off access
	ansa	ptw|0
	tsx	.ret,cam_cache$cam_cache
	tsx	.ret,cleanup_page	drive guy out of core

	lda	ptw.er,dl
	orsa	ptw|0
"
"	Try for an older copy of the page in any case.
"
	eax	.ret,page_error$reverting_page assume some stuff out there
	lda	cme_devadd,*.cme get diskaddr or pdaddr
	cana	add_type.non_null,dl any good stuff atall?
	tnz	done.werr.deverr.printerr ptw ok

	eax	.ret,page_error$zeroing_page
	ldq	errcode		see what case
	lda	page_bad_null,du	assume device lossage
	canq	errflags.memory_unusable,dl
	tze	*+2
	lda	page_devparity_null,du parity case
	staddra	ptw|0		in the ptw
done.werr.deverr.printerr:
	tsx	.ret,0,.ret	print barfage
	lda	errcode		do we have to make main mem vanish?
	cana	errflags.memory_unusable,dl
	tze	done.notify.uncond	exit

	tsx	.ret,delete_mm_frame delete this frame of main mem
	tra	done.notify.uncond
		"cme has been freed, don't know whether
		"to notify or not, so do it.

write_device_inop:
	tsx	.ret,get_pvtx
	tsx	.ret,call_disk_emergency

	lda	ptw.phm1,dl	turn mod bit back on
	orsa	ptw|0

finish_write_error:
	tsx	.ret,thread_in_mru avoid repl algorithm
	tra	notify_code



"
"
"	Clear out and deconfigure main memory frame.
"
delete_mm_frame:
	tsx	.2ret,savex
	tsx	.ret,thread_out	good move
	lca	1,dl		just zap first word
	sta	cme_0,*.cme
	asa	sst|sst.nused	it's not used.
	tsx	.ret,page_error$deleting_mm_frame annuntio
	tra	unsavex

"
"	Subroutine to call disk_emergency on disk-errors,
"	So that he might make assessments of system-wide
"	implications of disk device status.

call_disk_emergency:
	sta	pvtx		pvtx in a-reg
	eppap	pvtx
	spriap	arg+2
	eppap	errcode
	spriap	arg+4
	ldaq	=v18/4,18/4,36/0
	staq	arg
	call	disk_emergency$disk_emergency(sp|arg)
	tra	0,.ret


	end




		    page_synch.alm                  11/11/89  1105.1r w 11/11/89  0804.3      102582



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	page_synch
"
"	Module to manage Data Management synchronized pages for ALM
"	Page Control.
"
"	Entries:
"
"	cleanup  	when a synch page is evicted, for housekeeping
"	move	when a synch page is moved from one frame to another
"	write     when Page Control wants to write a synch page, to see
"		whether it can
"	unlink_journal when a journal time stamp is changed, to unlink
"		all held CMEs
"
"	Written October 1982 by J. Bongiovanni
"	Modified June 1983 by M. Pandolf to better meter invalid formats
"	Modified May 1984 by Chris Jones to add move entry
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	page_synch

	segdef	cleanup
	segdef	move
	segdef	write
	segdef	unlink_journal

minus_one:
	dec	-1

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	cleanup
"
"	Called when a synch page is evicted from memory, to do housekeeping
"	and reset CME bits.
"
"	tsx7	page_synch$cleanup
"
"	On entry,
"		x4 -> CME
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

cleanup:
	spriap	page_synch_temp		" Save register
	eppap	dm_journal_seg_$

	ldq	page_fault$cme_flags,*x4	" CME flags
	canq	cme.synch_held,dl		" Held page?
	tze	cleanup_not_held		" No
	tsx6	thread_out		" Yes - thread out of per-journal list

cleanup_not_held:
	lca	cme.synch_held+1,dl		" Reset held bit
	ansa	page_fault$cme_flags,*x4

	tra	ret_0
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"	move
"
"	Called when a synch-held page is moved from one frame to another.
"	Its entry in dm_journal_seg_ must be updated.
"
"	tsx7	page_synch$move
"
"	On entry,
"		x4 -> new CME
"		x5 -> old CME
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
move:
	lda	page_fault$cme_flags,*x5
	ana	cme.synch_held,dl
	tze	0,x7			" not held, nothing to do
	spriap	page_synch_temp
	orsa	page_fault$cme_flags,*x4	" turn on synch_help in new
	eaq	0,x5			" save this for a minute
	lxl5	page_fault$cme_synch_page_entryp,*qu
	sxl5	page_fault$cme_synch_page_entryp,*x4
	eppap	dm_journal_seg_$		" point to dm_page_entry
	stx4	ap|dm_page_entry.cme_relp,x5
	eax5	0,qu			" copy it back
	tra	ret_0
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"	write
"
"	Called when Page Control wants to write a synch page. If the page
"	must be held, it is threaded to a per-journal list.
"
"	tsx7	page_synch$write
"	<return if page must be held>
"	<return if OK to write>
"
"	On entry,
"		x4 -> CME
"		bp -> PTW
"		abs_seg1 -> memory frame for page
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

write:
	spriap	page_synch_temp		" Save register
	eppap	dm_journal_seg_$
	aos	ap|dm_journal.synch_write_calls " Meter

	tsx6	page_fault$savex		" Recursive use of x7

	lda	page_fault$cme_flags,*x4
	cana	cme.synch_held,dl		" Page already held?
	tze	write_not_held		" No
	tsx6	thread_out		" Yes - thread out of list

write_not_held:
	tsx6	check_page_hold		" Should we hold?
	tra	invalid_format		" Bogus synch page format
	tra	write_hold		" Hold for sure

"	Maybe not hold, but race exists since page is accessible to other
"	CPUs. Remove access and check again

	lca	ptw.valid+1,dl
	ansa	bp|0			" Remove access in PTW
	tsx6	page_fault$check_accessible	" Is segment accessible?
	tsx7	cam_cache$cam_cache		" Yes, zap AMs

	tsx6	check_page_hold		" Check again for hold
	tra	invalid_format		" Bogus format
	tra	write_hold		" Hold
	tra	ret_unsavex_1		" Can write - done restores access

write_hold:
	lda	ptw.valid,dl		" Restore access
	orsa 	bp|0
	lda	ap|dm_journal.n_held_pages_mem " Check held against threshold
	cmpa	ap|dm_journal.max_held_pages_mem
	tpl	write_over_threshold	" Exceeded
	aos	ap|dm_journal.synch_write_holds " Meter
	tsx6	thread_in			" Thread into list per-journal
	tra	ret_unsavex_0		" And return

invalid_format:
	lda	ptw.valid,dl		" Restore access
	orsa	bp|0
	tra	ret_unsavex_1		" For now

write_over_threshold:
	aos	ap|dm_journal.synch_write_tosses " Meter
	tra	ret_unsavex_1		" And toss by allowing write
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	unlink_journal
"
"	Called when a journal time stamp is changed to unlink all CMEs,
"	causing pages not to be held. Pages which should still be held
"	will be detected when next we try to write them.
"
"	call page_synch$unlink_journal (Journal_Index)
"
"	Must be called with PTL held
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

unlink_journal:
	push

	ldq	ap|2,*			" Journal index
	tmoz	unlink_returns		" Bogus
	eppap	dm_journal_seg_$
	cmpq	ap|dm_journal.n_journals	" Valid index
	tpnz	unlink_returns		" No
	mpy	dm_per_journal_size,dl
	eaq	ap|dm_journal.per_journal-dm_per_journal_size,ql " QU -> per journal entry
	stq	page_synch_temp
	aos	ap|dm_journal.unlink_calls	" Meter

unlink_loop:
	ldq	page_synch_temp		" QU -> per journal entry
	ldx0	ap|dm_per_journal.entry_relp,qu " x0 -> page entry
	tze	unlink_returns		" None left
	aos	ap|dm_journal.unlink_steps	" Meter
	ldx4	ap|dm_page_entry.cme_relp,x0	" x4 -> CME
	tze	page_error$dm_journal_seg_problem " Bad news, indeed
	tsx6	thread_out		" Unthread this entry
	tra	unlink_loop

unlink_returns:
	return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Return points - restore registers and return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

ret_0:
	lprpap	page_synch_temp
	tra	0,x7

ret_1:
	lprpap	page_synch_temp
	tra	1,x7

ret_2:
	lprpap	page_synch_temp
	tra	2,x7

ret_unsavex_0:
	lprpap	page_synch_temp
	tra	page_fault$unsavex

ret_unsavex_1:
	lprpap	page_synch_temp
	tra	page_fault$unsavex_1
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Internal procedure to check whether a page should be held, and
"	not written.
"	
"	tsx6	check_page_hold
"	<return if invalid synch page format>
"	<return if should hold>
"	<return if write OK>
"
"	On entry,
"		x4 -> CME
"		abs_seg1 -> main memory for page
"
"	On exit,
"		ap -> dm_journal_seg_
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

check_page_hold:

	eppap	abs_seg1$			" ap -> page
	ldaq	ap|synch_page.version_word
	tze	null_version_word
	lda	ap|synch_page.version_word
	ana	synch_page.version,du
	cmpa	SYNCH_PAGE_VERSION_1,du	" Good format for header
	tnz	invalid_version_number	" No
	lda	ap|synch_page.journal_index_word
	arl	synch_page.journal_index_shift
	ana	synch_page.journal_index_mask,dl " Pick up journal index
	tze	invalid_journal_index	" No good
	sta	page_synch_index		" save
	ldaq	ap|synch_page.time_stamp_word
	anaq	synch_page.time_stamp_mask	" Get time stamp
	staq	page_synch_time		" And save
	rccl	sys_info$clock_,*		" Check for reasonable value
	cmpaq	page_synch_time		" Can't be later than clock
	tmi	invalid_time_stamp

	eppap	dm_journal_seg_$

	ldq	page_synch_index
	cmpq	ap|dm_journal.n_journals	" Index valid
	tpnz	0,x6			" No
	mpy	dm_per_journal_size,dl	" Convert to offset
	eax0	ap|dm_journal.per_journal-dm_per_journal_size,ql " x0 -> per_journal entry
	szn	ap|dm_per_journal.uid,x0	" In use?
	tze	0,x6			" No - bogousity

	ldaq	page_synch_time
	cmpaq	ap|dm_per_journal.time_stamp,x0 " Hold page?
	tmoz	2,x6			" No
	tra	1,x6			" Yes

null_version_word:
	eppap	dm_journal_seg_$
	aos	ap|dm_journal.synch_write_no_stamp " Meter
	tra	0,x6

invalid_version_number:	
	eppap	dm_journal_seg_$
	aos	ap|dm_journal.synch_write_inv_vers " Meter
	tra	0,x6

invalid_journal_index:
	eppap	dm_journal_seg_$
	aos	ap|dm_journal.synch_write_inv_ix " Meter
	tra	0,x6

invalid_time_stamp:
	eppap	dm_journal_seg_$
	aos	ap|dm_journal.synch_write_inv_time " Meter
	tra	0,x6

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Internal procedure to thread an entry into a per-journal list
"
"	tsx6	thread_in
"
"	On entry,
"		ap -> dm_journal_seg_$
"		x4 -> CME
"		x0 -> per_journal entry
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

thread_in:
	ldx1	ap|dm_journal.free_list_relp	" Next free entry
	tze	page_error$no_free_dm_entries	" None

	ldq	ap|0,x1			" QU -> next free
	stq	ap|dm_journal.free_list_relp

	stx4	ap|dm_page_entry.cme_relp,x1

	ldx5	ap|dm_per_journal.entry_relp,x0 " Entry in list
	tnz	thread_in_non_empty		" List non-empty

	stx1	ap|dm_per_journal.entry_relp,x0 " Save in list ptr
	stx1	ap|dm_page_entry.fp,x1	" Entry threads to self
	sxl1	ap|dm_page_entry.bp,x1
	tra	thread_in_done

thread_in_non_empty:
	lda	ap|dm_page_entry.fp,x5	" x5 -> an entry in the list
	sxl1	ap|dm_page_entry.bp,x5	" entry -> back to new entry
	stx5	ap|dm_page_entry.fp,x1	" new entry -> forward to entry
	stx1	ap|dm_page_entry.fp,al	" prev entry -> forward to new entry
	eax5	0,al
	sxl5	ap|dm_page_entry.bp,x1	" new entry -> back to prev entry

thread_in_done:
	sxl0	ap|dm_page_entry.journal_relp,x1 " pointer to per_journal
	sxl1	page_fault$cme_synch_page_entryp,*x4 " CME -> entry
	lda	cme.synch_held,dl
	orsa	page_fault$cme_flags,*x4	" Mark CME as held
	aos	ap|dm_per_journal.n_held,x0	" Bump count of held this journal
	aos	ap|dm_journal.n_held_pages_mem " And total held

	tra	0,x6
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Internal procedure to thread an entry out of a per-journal list
"
"	tsx6	thread_out
"
"	On entry,
"		ap -> dm_journal_seg_$
"		x4 -> CME
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

thread_out:

	lda	cme.synch_held,dl
	era	minus_one
	ansa	page_fault$cme_flags,*x4	" Mark CME as not-held

	lxl1	page_fault$cme_synch_page_entryp,*x4 " x1 -> entry
	tze	page_error$dm_journal_seg_problem
	lda	-1,du
	ansa	page_fault$cme_synch_page_entryp,*x4 " Reset CME pointer

	lxl0	ap|dm_page_entry.journal_relp,x1 " x0 -> per-journal entry

	lxl5	ap|dm_page_entry.bp,x1	" x5 -> prev entry
	cmpx1	ap|dm_page_entry.fp,x1	" Thread to self?
	tnz	thread_out_non_empty	" No - list won't be empty
	
	stz	ap|dm_per_journal.entry_relp,x0 " Mark list as empty
	tra	thread_out_done

thread_out_non_empty:
	lda	ap|dm_page_entry.fp,x1	" AU -> next entry
	sxl5	ap|dm_page_entry.bp,au	" next -> back to prev
	eax5	0,au			" x5 -> next entry
	stx5	ap|dm_page_entry.fp,al	" prev -> forward to next
	stx5	ap|dm_per_journal.entry_relp,x0 " In case it pointed to this one

thread_out_done:
	lda	ap|dm_journal.free_list_relp	" Thread entry into free list
	sta	ap|dm_page_entry.fp,x1
	eaa	0,x1
	sta	ap|dm_journal.free_list_relp

	lda	ap|dm_per_journal.n_held,x0	" Decrement per-journal count
	sbla	1,dl
	sta	ap|dm_per_journal.n_held,x0
	lda	ap|dm_journal.n_held_pages_mem " Decrement total count
	sbla	1,dl
	sta	ap|dm_journal.n_held_pages_mem

	tra	0,x6
"
	include	cmp
"
	include	dm_journal_seg_
"
	include	ptw
"
	include	pxss_page_stack
"
	include	synch_page


	end




		    pc.pl1.pmac                     11/11/89  1105.1rew 11/11/89  0804.3      420723



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/* format: style2,indcomtxt */
/* use: pl1_macro pc.pl1.pmac  -target l68 */
pc:
     procedure;

/* *	PC -- the utility procedure of pl1 page control.
   *
   *	Last modified (date and reason):
   *
   *      1985-03-28, BIM: assume that all modified pages of synch segments
   *		  are synch held until proven otherwise by page$pwrite.
   *	841220 by Keith Loepere to count dirs pages against its own quota.
   *	840623 by Keith Loepere for nullify entry for bce.
   *	840417 E. A. Ranzenbach to correct page_read zero event problem that caused crashes in the segment mover.
   *      84-01-19 BIM to remove unworkable synch segmove support.
   *      84-01-03 BIM to finish segmove.
   *	831219 by E. N. Kittlitz, for segmove
   *      09/19/83 by E. N. Kittlitz, per UofC SGH, periodically unlock PTL during long flushes.
   *      08/22/83 by E. N. Kittlitz, per UofC GM&SGH, don't hedge-write per-process pages.
   *      10/27/82 by J. Bongiovanni to reset damaged, fm_damaged on truncate
   *               and for synchronized pages
   *      08/17/82 by J. Bongiovanni for scavenger
   *      06/09/82 by J. Bongiovanni to fix shutdown quota problem
   *      03/07/82 by J. Bongiovanni for record stocks
   *      01/23/82 by BIM for truncate_count
   *	12/29/81 by C. Hornig to remove Page Multilevel and fix fencepost error in flush.
   *	08/11/81 by W. Olin Sibert, to fix get_file_map to not report nulled addresses as modified.
   *	   This fix actually provided by Steve Harris, University of Calgary
   *	02/20/81 by W. Olin Sibert, to conditionalize page-multilevel (phase one of ADP conversion)
   *	11/17/80 by ENK for new dtu/dtm calculation
   *	11/06/80 by ENK for loop_up_fms honouring of aste.gtms.
   *	03/16/78 by BSG for phm1, incore null non-reportage.
   *	08/01/77 by Greenberg for badd_types, pc_recover_sst.
   *	05/03/77 by BSG for page$pcleanup
   *	01/27/77 by TVV for non-fatal unprotected addresses
   *	11/01/76 by D. Vinograd to add entry for volume dumper which returns special null addresses
   *	   and does not deposit.
   *	10/31/76 by BSG for truncate_deposit_all entry
   *	05/13/76 by BSG for seg-by-seg PD flush.
   *	04/13/76 by REM for Cleanup Metering
   *	10/11/75 by BSG for fault_time_withdraws
   *	03/04/75 by BSG for new storage system (incl. no pdht).
   *	12/11/74 by BSG for new CME/PTW protocols and new core control.
   *	06/19/74 by BSG for page$pwait and page$cam.
   *	08/21/73 by RBS to put in checks for reused addresses.
   *	08/03/73 by RBS to cause pc$flush to index thru cmes rather than follow threads.
   *	08/10/73 by SHW to use 18 bit device addresses
   *	07/15/73 by RBS to cause pages that are in core to be written to disk by pd_flush_all
   *	10/04/72 by RBS to make page waits go to device control to accomodate bulk store logic
   *	06/06/72 by RBS to modify for follow-on
   *	10/26/71 by RHG to fix move_page_table for pages which are in core when moved
   *	10/07/71 by SHW to add ptwp to pdme (increase entry size to 3 words)
   *	10/05/71 by RHG to initialize pdmap and to skip the first sst.nrecs_pdmap entries in pd_flush_all
   *	09/22/71 by RHG to make null devadds include a ptr for page
   *	09/20/71 by RHG to fix bug in pc$get_file_map which lost all pages of file except first at deactivation
   *	09/03/71 by Steve Webber to make calls to page$withdraw be fixed bin(4), not bit(4)
   *	08/10/71 by Richard H. Gumpertz to add code for page multi-level
*/

	dcl     Astep		 ptr parameter;
	dcl     Copy_Astep		 ptr parameter;
	dcl     File_Mapp		 ptr parameter;
	dcl     Listp		 ptr parameter;
	dcl     Pageno_Listp	 ptr parameter;
	dcl     Deposit_Count	 fixed bin parameter;
	dcl     First_Page		 fixed bin parameter;
	dcl     Last_Page		 fixed bin parameter;
	dcl     N_Pages		 fixed bin parameter;
	dcl     N_In_Core		 fixed bin parameter;
	dcl     Records		 fixed bin parameter;
	dcl     Pvtx		 fixed bin parameter;
	dcl     Vtocx		 fixed bin parameter;
	dcl     Move_Astep		 pointer parameter;
	dcl     Old_Astep		 ptr parameter;
	dcl     New_Astep		 ptr parameter;
	dcl     Code		 fixed bin (35) parameter;
	dcl     New_Vtocx		 fixed bin (17) parameter;
	dcl     New_Pvtx		 fixed bin (17);

	dcl     (records, first_page, last_page, i)
				 fixed bin;
	dcl     ind		 fixed bin (35);
	dcl     temp_ind		 fixed bin (35);
	dcl     pvtx		 fixed bin;
	dcl     dumper		 bit (1);
	dcl     return_pageno	 bit (1) aligned;
	dcl     add_to_dmpr_map	 bit (1);
	dcl     (getfmap_csl, getfmap_np, getfmap_nrec)
				 fixed bin (9);
	dcl     offed_sw		 bit (1);
	dcl     j			 fixed bin;
	dcl     segmove_records_used	 fixed bin;
	dcl     (cmp, ptwp)		 ptr;
	dcl     curtime		 fixed bin (71);
	dcl     n_in_core		 fixed bin (18);
	dcl     n_io_started	 fixed bin;
	dcl     pageno		 fixed bin;
	dcl     (from_core, count)	 bit (1);
	dcl     (old_astep, new_astep, old_ptp, new_ptp, move_ptp)
				 ptr;
	dcl     oldmask		 fixed bin (71);
	dcl     no_deposit_no_return	 bit (1) aligned;
	dcl     tr_count_sw		 bit (1) aligned;
	dcl     segmove_records_needed fixed bin;
	dcl     segmove_records_in_hand
				 fixed bin;
	dcl     segmove_total_records	 fixed bin;
	dcl     code		 fixed bin (35);
	dcl     new_pvtx		 fixed bin;
	dcl     new_vtocx		 fixed bin;
	dcl     move_tries		 fixed bin;

	dcl     1 copy_aste		 like aste aligned;

	dcl     fword		 (0:99) fixed bin based;

	dcl     Address_Array	 (0:255) bit (22) aligned based (Listp);
	dcl     (deposit_list, segmove_deposit_list)
				 (0:255) bit (22) aligned;
	dcl     rfm		 (0:255) bit (22) aligned;
	dcl     1 Devadd_Array	 (0:255) aligned based (Listp),
		2 record_no	 bit (18) unaligned,
		2 add_type	 bit (4) unaligned;
	dcl     Pageno_List		 (0:255) fixed bin aligned based (Pageno_Listp);
	dcl     pageno_list		 (0:255) fixed bin aligned;

	dcl     devadd		 bit (22) unaligned;
	dcl     devadd_record_no	 bit (18) unaligned defined (devadd);
	dcl     devadd_record_no_proper
				 bit (17) defined (devadd) pos (2);
	dcl     devadd_add_type	 bit (4) unaligned defined (devadd) position (19);
	dcl     devadd_null_flag	 bit (1) defined (devadd) position (1);


	dcl     1 devadd_bits	 unal based (addr (devadd_add_type)) like badd_type;


	dcl     cleanup_start_time	 fixed bin (71);	/* Cleanup Metering */

	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$action_not_performed
				 fixed bin (35) ext static;
	dcl     error_table_$synch_seg_segmove
				 fixed bin (35) external static;
	dcl     dbm_man$set_incr	 entry (fixed bin, fixed bin, fixed bin (35));
	dcl     (
	        lock$lock_fast,
	        lock$unlock_fast
	        )			 entry (pointer);
	dcl     page$cam		 ext entry;
	dcl     page$deposit_list	 entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, ptr);
	dcl     page$pcleanup	 entry (ptr, fixed bin);
	dcl     page$pread		 entry (ptr, fixed bin, fixed bin (35));
	dcl     page$pwait		 ext entry (fixed bin (35));
	dcl     page$pwrite		 ext entry (ptr, fixed bin);
	dcl     page$withdraw_list	 entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin (35), fixed bin (35));
	dcl     pmut$lock_ptl	 ext entry (fixed bin (71), ptr);
	dcl     pmut$unlock_ptl	 ext entry (fixed bin (71), ptr);
	dcl     pxss$notify		 ext entry (fixed bin);
	dcl     pxss$relinquish_priority
				 ext entry;
	dcl     quotaw$cu_for_pc	 entry (ptr, fixed bin, bit (1) aligned);
	dcl     syserr		 ext entry options (variable);
	dcl     trace		 ext entry options (variable);

	dcl     null_devadd_not_in_core
				 bit (36) aligned internal static options (constant) init ("000000000001"b3);
	dcl     line_of_words	 char (23) internal static options (constant) init ("^w ^w ^w ^w ^w ^w ^w ^w");
	dcl     half_line_of_words	 char (11) defined (line_of_words);

	dcl     (addr, addrel, addwordno, bit, clock, divide, fixed, max, min, null, ptr, rel, size, unspec, wordno)
				 builtin;
%page;
cleanup:
     entry (Astep);					/* Entry to get segment out of core. */
						/* Caller guarantees no access to segment */

/* Note that synchronized pages which are modified and cannot be written yet
   are left in memory. If this happens during shutdown, it is fine. Otherwise,
   the caller must detect this situation and handle it appropriately. It
   can be detected by checking that aste.np is non-zero. */

	sstp = addr (sst_seg$);
	astep = Astep;
	cmp = sst.cmp;				/* get a pointer to the core map */
	cleanup_start_time = clock ();		/* Cleanup Metering */

	sst.cleanup_count = sst.cleanup_count + 1;	/* Cleanup Metering */
	call pmut$lock_ptl (oldmask, ptwp);		/* mask */
	records = 0;
	if pc_trace
	then call trace ("cleanup^-^-astep = ^p", astep);
loopc:
	ptp = addrel (astep, sst.astsize);		/* get a pointer to the page table */
	ind = -1;					/* index of page to wait on */
	do i = 0 to sst.pts (fixed (aste.ptsi, 2)) - 1;	/* loop over all pages in the segment */
	     if atptw.core
	     then do;				/* In core, includes all O/S */

		     if ^ptw.os
		     then do;			/* Not out of service */
			     if ^(ptw.phm | ptw.phm1)
			     then /* Attempt to clean up the page */
				call page$pcleanup (astep, i);
						/* Do it, cam the cache */
						/* He turns off PTW access, SDW'S gone, so no race. */
			     else call page$pwrite (astep, i);
						/* Start a write */
			end;

		     if ptw.os
		     then ind = fixed (rel (ptp), 18);	/* Set wait event */

		end;

	     ptp = addrel (ptp, size (ptw));		/* Next ptw, please */
	end;

	if ind > 0
	then call wait_then_go_to (loopc);

	sst.cleanup_real_time = sst.cleanup_real_time /* Cleanup Metering */ + clock () - cleanup_start_time;
						/* Cleanup Metering */

quit:
	call pmut$unlock_ptl (oldmask, ptwp);		/* unlock and unmask */
	return;
%page;
nullify:
     entry (Astep);					/* Entry to nullify a bce/hardcore segment.
						   Part of disk optimization for bce. */

/* The idea is to mark the pages of the segment unmodified, clean them up
   (to disk) and then mark the disk addresses as null.  This is done just to
   optimize the later filling in of this segment.  We don't guarantee perfection
   in this, but it doesn't matter.  Anyone who calls this ensures that the
   segment is not in use so we don't expect a problem with pages being
   referenced between ptl lockings. */

/* First unmodify the pages.  Note that os pages are not affected, but these
   either aren't yet modified (being read) or will become unmodified (after
   write). */

	sstp = addr (sst_seg$);
	astep = Astep;

	call pmut$lock_ptl (oldmask, ptwp);		/* mask */
	ptp = addrel (astep, sst.astsize);		/* get a pointer to the page table */
	do i = 0 to sst.pts (fixed (aste.ptsi, 2)) - 1;	/* loop over all pages in the segment */
	     if atptw.core
	     then /* In core, includes all O/S */
		if ^ptw.os			/* Not out of service */
		then ptw.phm, ptw.phm1 = "0"b;

	     ptp = addrel (ptp, size (ptw));		/* Next ptw, please */
	end;
	call pmut$unlock_ptl (oldmask, ptwp);		/* unlock and unmask */

	call cleanup (astep);			/* free all memory frame; make into disk addresses */

	call pmut$lock_ptl (oldmask, ptwp);		/* mask */
	ptp = addrel (astep, sst.astsize);		/* get a pointer to the page table */
	do i = 0 to sst.pts (fixed (aste.ptsi, 2)) - 1;	/* loop over all pages in the segment */
	     if atptw.disk
	     then substr (ptw.add, 1, 1) = "1"b;	/* make null */

	     ptp = addrel (ptp, size (ptw));		/* Next ptw, please */
	end;
	call pmut$unlock_ptl (oldmask, ptwp);		/* unlock and unmask */
	return;
%page;
fill_page_table:
     entry (Astep, File_Mapp, N_Pages);


	astep = Astep;				/* Copy args */
	fmp = File_Mapp;
	pvtx = astep -> aste.pvtx;
	last_page = N_Pages - 1;			/* arg is csl */
	sstp = addr (sst_seg$);
	records = 0;

	ptp = addrel (astep, sstp -> sst.astsize);
	do i = 0 to last_page;
	     devadd = file_map.fm (i);		/* No need to lock here */
	     if devadd_null_flag
	     then do;				/* Outside world null address, */
		     devadd_null_flag = "0"b;		/* This is not NULLED, but null. */
		     devadd_add_type = "0000"b;	/* Internal null address representation */
		end;
	     else do;				/* real disk address */
		     devadd_add_type = add_type.disk;	/* Assume protected. */
		     records = records + 1;
		end;
	     ptp -> ptwa_bits (i) = devadd | null_devadd_not_in_core;
						/* save final result in ptw */
	end;


	do i = last_page + 1 to sstp -> sst.pts (fixed (astep -> aste.ptsi, 2)) - 1;
						/* Fill up rest of page table with nulls */
	     ptp -> ptwa_bits (i) = null_devadd_not_in_core;
	     ptp -> mptwa (i).devadd = fill_page_table_null_addr;
	end;
	aste.records = bit (fixed (records, 9), 9);
	if pc_trace
	then do;
		call trace ("fill_page_table^-astep = ^p", astep);
		if last_page <= 4
		then call trace (half_line_of_words, ptp -> fword (0), ptp -> fword (1), ptp -> fword (2),
			ptp -> fword (3));
		else do;
			do i = 0 to last_page by 8;
			     call trace (line_of_words, ptp -> fword (i), ptp -> fword (i + 1),
				ptp -> fword (i + 2), ptp -> fword (i + 3), ptp -> fword (i + 4),
				ptp -> fword (i + 5), ptp -> fword (i + 6), ptp -> fword (i + 7));
			end;
		     end;
	     end;
	return;
%page;
truncate:
     entry (Astep, First_Page);			/* entry to truncate a page table */


	tr_count_sw = "0"b;
	go to truncate_join;

truncate_count:
     entry (Astep, First_Page, N_In_Core);


	tr_count_sw = "1"b;

truncate_join:
	sstp = addr (sst_seg$);			/* get a pointer to the sst */

	astep = Astep;				/* copy args into wired down stack */
	ptp = addrel (astep, sstp -> sst.astsize);
	cmp = sstp -> sst.cmp;			/* and core map pointer */
	first_page = First_Page;
	last_page = sstp -> sst.pts (fixed (astep -> aste.ptsi, 3)) - 1;
						/* get pt end for last page */

	records = 0;
	if pc_trace
	then call trace ("truncate^-^-astep = ^p", astep);

/* the segment has an AST entry -- must clean up page tables and core map */

	call pmut$lock_ptl (oldmask, ptwp);		/* lock and mask */

	if pc_trace
	then do;
		if last_page <= 4
		then call trace (half_line_of_words, ptp -> fword (0), ptp -> fword (1), ptp -> fword (2),
			ptp -> fword (3));
		else do;
			do i = 0 to last_page by 8;
			     call trace (line_of_words, ptp -> fword (i), ptp -> fword (i + 1),
				ptp -> fword (i + 2), ptp -> fword (i + 3), ptp -> fword (i + 4),
				ptp -> fword (i + 5), ptp -> fword (i + 6), ptp -> fword (i + 7));
			end;
		     end;
	     end;
	n_in_core = 0;
retry:
	ind = 0;

	do i = first_page to last_page;		/* loop through all pages going */
	     if ptp -> ptwa (i).os
	     then do;				/* if out of service, must wait for io */
		     ind = fixed (rel (addr (ptp -> ptwa (i))), 18);
						/* get event to wait on */
		     call wait_then_go_to (retry);	/* must go back to top after waiting */
		end;
	     count = "0"b;				/* Assume no truncation */

/* At this point, page is not o/s. If in core, devadd has core address. */

	     from_core = atptwa (i).core;		/* Remember in_coreness */
	     devadd = ptp -> mptwa (i).devadd;		/* pick up the device address */

/* At this point, devadd has disk or null address, unless in core */

	     if from_core
	     then do;				/* Page is in core */
		     n_in_core = n_in_core + 1;
		     cmep = addr (cmp -> cma (ptp -> core_ptwa (i).frame));
						/* Get pointer to cme */
		     devadd = cmep -> cme.devadd;	/* and get the devadd for cleanup */
		     if ptp -> ptwa (i).wired
		     then sstp -> sst.wired = sstp -> sst.wired - 1;
		     call page$pcleanup (astep, i);	/* Fix up data bases, count quota, csl */
		     count = "0"b;			/* page$cleanup did all work */
		end;


/* At this point, page is not in core. devadd has disk, null, or nulled */

	     if devadd_bits.disk
	     then if ^devadd_null_flag		/* if nulling ... */
		then do;
			devadd_null_flag = "1"b;	/* Null the address */
			count = "1"b;
		     end;

	     ptp -> mptwa (i).devadd = devadd;		/* Insert right devadd in ptw */
	     if count
	     then records = records + 1;

	end;
	call loop_up_fms;
	if records ^= 0
	then do;
		astep -> aste.fmchanged = "1"b;	/* Make sure we get an update_vtoce */
		if ^astep -> aste.nqsw
		then if astep -> aste.dirsw
		     then call quotaw$cu_for_pc (astep, -records, "1"b);
		     else if astep -> aste.par_astep
		     then call quotaw$cu_for_pc (ptr (astep, astep -> aste.par_astep), -records, "0"b);
		astep -> aste.records = bit (fixed (fixed (astep -> aste.records, 9) - records, 9), 9);
	     end;

/* Now update the current segment length */

	do i = min (first_page - 1, last_page) to 0 by -1;/* min traps truncate to addr > aste size */
	     devadd = ptp -> mptwa (i).devadd;
	     if ptp -> atptwa (i).core
	     then goto update_csl;
	     if devadd_add_type & add_type.non_null
	     then if ^devadd_null_flag
		then go to update_csl;
	end;
update_csl:
	astep -> aste.csl = bit (fixed (i + 1, 9), 9);

	if first_page = 0
	then do;
		astep -> aste.damaged = "0"b;		/* empty is undamaged */
		astep -> aste.fm_damaged = "0"b;
	     end;

	call page$cam;				/* make sure our work takes */
	call pmut$unlock_ptl (oldmask, ptwp);		/* unlock and unmask */
	if tr_count_sw
	then N_In_Core = n_in_core;			/* return for meter for callers that want. */
	return;
%page;
dumper_get_file_map:
     entry (Astep, Copy_Astep, File_Mapp, Deposit_Count, Listp, Pageno_Listp);
						/* dumper entry for VTOCE update */

	dumper = "1"b;
	goto get_file_map_common;

get_file_map:
     entry (Astep, Copy_Astep, File_Mapp, Deposit_Count, Listp, Pageno_Listp);
						/* entry for VTOC update */


	dumper = "0"b;
get_file_map_common:
	astep = Astep;				/* Copy astep */
	add_to_dmpr_map = "0"b;
	sstp = addr (sst_seg$);			/* get SST base ptr */
	fmp = File_Mapp;
	cmp = sstp -> sst.cmp;			/* get core map ptr */
	last_page = sstp -> sst.pts (fixed (astep -> aste.ptsi, 2)) - 1;
	no_deposit_no_return = (Listp = null) | aste.ddnp;
	getfmap_csl, getfmap_np, getfmap_nrec = 0;	/* Init counters */
	offed_sw = "0"b;				/* Don't need cam */
	return_pageno = (Pageno_Listp ^= null ());

	call pmut$lock_ptl (oldmask, ptwp);		/* Lock the pagetable lock */

	sstp = addr (sst_seg$);
	j = 0;					/* Init deposit index */
	do i = 0 to last_page;			/* Walk the table */
	     ptp = addrel (astep, sstp -> sst.astsize + i);
						/* Get one page tbl ptr */
	     devadd = ptp -> mptw.devadd;		/* Get address from ptw */
	     if devadd_bits.disk
	     then do;				/* Disk addr, could be nulled */
		     if devadd_null_flag & ^no_deposit_no_return
		     then do;			/* put in deposit list */
			     devadd_null_flag = "0"b; /* zero the special internal flag */
			     deposit_list (j) = devadd;
						/* set to give to outside world */
			     if return_pageno
			     then pageno_list (j) = i;

			     j = j + 1;		/* one more depositable address processed */
			     devadd = get_file_map_vt_null_addr;
			     ptp -> mptw.devadd = devadd;
						/* coded null to file map and page table */
			end;
		     else if devadd_null_flag & dumper
		     then devadd = get_file_map_vt_null_addr;
		end;
	     if devadd_bits.core
	     then do;				/* A core address- move on up storage levels */
		     if ptw.phm
		     then do;			/* Must off phm */
			     ptw.phm1 = "1"b;	/* Mark mod status */
			     ptw.phm = "0"b;	/* OFF PHM */
			     offed_sw = "1"b;
			end;
		     cmep = addr (cmp -> cma (core_ptw.frame));
		     devadd = cmep -> cme.devadd;	/* Reconsider this devadd */
		     if devadd_null_flag & ^ptw.phm1 & ^(ptw.os & cme.io)
		     then devadd = get_file_map_vt_null_addr;
						/* This avoids damage to pure nulls incore */
		end;
	     if devadd_null_flag
	     then if dumper
		then devadd = get_file_map_dumper_non_null_addr;
		else do;
			devadd = get_file_map_vt_null_addr;
			devadd_null_flag = "1"b;
		     end;				/* if page is not on disk yet, or trunced,
						   we cannot fault in this page should we crash */
	     else devadd_null_flag = (devadd_add_type = "0000"b);
						/* Set outside-world null representation */

	     if ^devadd_null_flag
	     then do;				/* Real page */
		     getfmap_nrec = getfmap_nrec + 1;
		     getfmap_csl = i + 1;
		     if atptw.core
		     then getfmap_np = getfmap_np + 1;
		end;

	     rfm (i) = devadd;			/* Send out agreed-upon devadd */
	end;
	curtime = clock ();				/* loop_up_fms MAY do this, but we must be sure */
	if offed_sw
	then do;
		call loop_up_fms;			/* Pages were noted as modified. */
		call page$cam;			/* We turned off phm bits. */
	     end;

	if aste.fms
	then add_to_dmpr_map = "1"b;
	if ^aste.gtus
	then if aste.np | aste.infp
	     then /* have pages in, or subordinate astes */
		aste.dtu = bit (fixed (curtime, 52), 52);
						/* call it -in use- */
	copy_aste = astep -> aste;			/* Copy ASTE structure */

/* Update perishable items consistently to caller */

	astep -> aste.fms = "0"b;			/* copy_aste has old value - this
						   assignment constitutes segment control's
						   recognition of modification */
	if ^dumper
	then do;
		astep -> aste.fmchanged1 = astep -> aste.fmchanged;
						/* Dont' lose fmchanged until updatev
						   turns this off, but ... */
		astep -> aste.fmchanged = "0"b;	/* turn off p_c maintained bit. */
	     end;
	call pmut$unlock_ptl (oldmask, ptwp);		/* And unlock the pagetables */
						/* Use following items to avoid damaging */
						/* segments with incore nonmod nulls. */
						/* Copy out data to caller */

	copy_aste.np = bit (fixed (getfmap_np, 9), 9);
	copy_aste.records = bit (fixed (getfmap_nrec, 9), 9);
	copy_aste.csl = bit (fixed (getfmap_csl, 9), 9);

	unspec (Copy_Astep -> aste) = unspec (copy_aste); /* Copy the s  into our callers copy */

	do i = 0 to last_page;
	     fmp -> file_map.fm (i) = rfm (i);		/* Upper bits into file map */
	end;

	do i = 0 to j - 1;				/* copy out depositable addresses */
	     Address_Array (i) = deposit_list (i);
	     if return_pageno
	     then Pageno_List (i) = pageno_list (i);
	end;
	Deposit_Count = j;				/* deposit count */
	if add_to_dmpr_map & ^aste.nid & ^aste.per_process & ^aste.hc_sdw
	then call dbm_man$set_incr (fixed (aste.pvtx, 17), fixed (aste.vtocx, 17), (0));

	if pc_trace
	then do;
		call trace ("get_file_map^-astep = ^p, fmp = ^p", astep, fmp);
		if last_page <= 4
		then call trace (half_line_of_words, ptp -> fword (0), ptp -> fword (1), ptp -> fword (2),
			ptp -> fword (3));
		else do;
			do i = 0 to last_page by 8;
			     call trace (line_of_words, ptp -> fword (i), ptp -> fword (i + 1),
				ptp -> fword (i + 2), ptp -> fword (i + 3), ptp -> fword (i + 4),
				ptp -> fword (i + 5), ptp -> fword (i + 6), ptp -> fword (i + 7));
			end;
		     end;
	     end;
	return;
%page;
updates:
     entry (Astep);					/* Entry to set file modified switches. */

	astep = Astep;				/* Copy arg to avoid page fault. */
	sstp = addr (sst_seg$);
	call pmut$lock_ptl (oldmask, ptwp);		/* lock and mask */
	call loop_up_fms;
	go to quit;

update_incore_fms:
     entry (Astep);					/* used to get fms as accurate as possible */


	astep = Astep;
	sstp = addr (sst_seg$);
	ptp = addrel (astep, sst.astsize);

	if aste.np = "000"b3
	then return;
	offed_sw = "0"b;


	do i = 0 to fixed (aste.csl, 9) - 1;
	     if ptwa (i).phm
	     then do;
		     offed_sw = "1"b;		/* remeber to cam */
		     ptwa (i).phm1 = "1"b;		/* Needed for real write */
		     ptwa (i).phm = "0"b;		/* This statement order is critical */
		end;
	end;

	if offed_sw
	then do;
		call loop_up_fms;
		call page$cam;
	     end;

	return;

loop_up_fms:
     proc;					/* Set fms up tree for hierarchy dumper. */

	dcl     astep1		 pointer;

	if aste.gtms
	then return;
	curtime = clock ();
	astep1 = astep;
	do while (rel (astep1));
	     astep1 -> aste.fms = "1"b;
	     astep1 -> aste.dtm = bit (fixed (curtime, 52), 52);
	     astep1 = ptr (astep1, astep1 -> aste.par_astep);
	end;

     end loop_up_fms;

/* You do not have to lock the page table or clear the AM for any of this. Phm1 will
   always be taken as a signal to write, and page$pwrite will turn them both off when
   camming. Once phm1 is on, failure to set phm, for not camming, is invisible. However, we
   do cam at the end so that the next call to this will get phms. */
%page;
flush:
     entry;					/* here to write out all of core */

/* Synchronized pages are handled as follows:

   flush_core - Page Control (page$pwrite) does the right thing, based on
   the time stamp in the page.

   flush - Modified synchronized pages are abandoned. This is safe, due to
   Ring-2 Data Management protocols.

*/

	dcl     flushing_for_pleasure	 bit (1);
	dcl     hedonism		 fixed bin;
	dcl     pleasure_flush_count	 fixed bin;

	flushing_for_pleasure = "0"b;
	go to flush_join;

flush_core:
     entry;					/* here to start writes for all core. */

	flushing_for_pleasure = "1"b;

flush_join:
	sstp = addr (sst_seg$);			/* get pointers, and lock */
	pvt_arrayp = addr (pvt$array);
	cmp = sstp -> sst.cmp;
	if flushing_for_pleasure
	then hedonism = divide (sst.write_limit, 2, 17, 0);
	pleasure_flush_count = 0;
	call pmut$lock_ptl (oldmask, ptwp);		/* lock and mask */
start_flush:
	do i = sst.first_core_block to sst.last_core_block;
						/* index thru all cmes */
	     ind = -1;				/* no wait event */
	     cmep = addr (cmp -> cma (i));

	     if (cme.ptwp ^= "000000"b3)
	     then do;				/* has real page */
		     ptp = ptr (sstp, cme.ptwp);	/* get ptp */
		     astep = ptr (sstp, cme.astep);	/* get astep */
		     if ^aste.hc_part
		     then do;			/* Don't bother with HC part segs */
			     if ptw.os
			     then ind = fixed (rel (ptp), 18);
						/* if event, wait on it */
			     else do;
				     pageno =
					fixed (rel (ptp), 18) - fixed (rel (astep), 18) - sstp -> sst.astsize;
				     devadd = cme.devadd;
				     if ptw.phm | ptw.phm1
				     then /* Needs writing */
					if drive_ok ((aste.pvtx))
					then /* dont io bad disk */
					     if flushing_for_pleasure
					     then if cme.phm_hedge
						then do;
							call page$pwrite (astep, pageno);
							sst.hedge_writes = sst.hedge_writes + 1;
							pleasure_flush_count = pleasure_flush_count + 1;
						     end;
						else cme.phm_hedge = ^aste.per_process;
						/* change when we prevail across crashes */
						/* if significant, write next time, if not written */
					     else do;
						/* shutdown */
						     if aste.synchronized
						     then ptw.phm, ptw.phm1 = "0"b;
						/* Abandon modified synch pages */
						     else call page$pwrite (astep, pageno);
						end;
				     if ^flushing_for_pleasure
						/* shutdown */
				     then if ^(ptw.phm | ptw.phm1 | ptw.os)
						/* Unmodified */
					then if devadd_null_flag
						/* Null address */
					     then call page$pcleanup (astep, pageno);
						/* Reflect quota */
				     if ptp -> ptw.os
				     then /* if still being written, wait for it */
					ind = fixed (cmp -> cma (i).ptwp, 18);
				     if sstp -> sst.wtct > sstp -> sst.write_limit
				     then /* if too many queued then */
					if (ind > 0) & ^flushing_for_pleasure
					then call wait_then_go_to (start_flush);
						/* wait for one */
				     if pleasure_flush_count >= hedonism
				     then do;	/* All done with PTW */
					     pleasure_flush_count = 0;
						/* time for a nap */
					     call pmut$unlock_ptl (oldmask, ptwp);
					     if flushing_for_pleasure
					     then call pxss$relinquish_priority;
					     call pmut$lock_ptl (oldmask, ptwp);
					end;
				end;
			end;
		end;
	end;					/* end of cme array loop */

	if (ind > 0) & ^flushing_for_pleasure
	then call wait_then_go_to (start_flush);	/* Wait if shutdown and there is stuff to wait for */
	go to quit;				/* done */
%page;
list_deposited_add:
     entry (Astep, First_Page, Last_Page, Records, Listp, Pageno_Listp);
						/* output deposits to seg ctl */


	astep = Astep;				/* copy params */
	first_page = First_Page;			/* place to start */
	last_page = Last_Page;			/* place to stop */
	return_pageno = (Pageno_Listp ^= null ());
	sstp = addr (sst_seg$);			/* set up sstp */
	ptp = addrel (astep, sstp -> sst.astsize);

	records = 0;				/* init count of depositable records */

	call pmut$lock_ptl (oldmask, ptwp);		/* lock the PTL for real work */

	if last_page < 0				/* Scan whole page table */
	then last_page = sst.pts (fixed (astep -> aste.ptsi, 2)) - 1;

	do i = first_page to last_page;		/* loop thru all ptws in ptl */

	     devadd = ptp -> mptwa (i).devadd;		/* assume devadd in ptw -- */

/* Any page in core or on the PD which has a nulled address
   has a right to it: hence, we only list those in the PTW */

	     if devadd_bits.disk
	     then if devadd_null_flag
		then do;				/* a real deposited address */
			deposit_list (records) = devadd;
						/* move to output array */
			if return_pageno
			then pageno_list (records) = i;
			records = records + 1;	/* bump counter */
			ptp -> mptwa (i).devadd, devadd = list_deposit_null_addr;
		     end;
	end;

	call pmut$unlock_ptl (oldmask, ptwp);		/* unlock the page tables */
	do i = 0 to records - 1;
	     Address_Array (i) = deposit_list (i);	/* return to argument array */
	     if return_pageno
	     then Pageno_List (i) = pageno_list (i);
	end;

	Records = records;				/* return the count */
	return;
%page;
deposit_list:
     entry (Pvtx, Records, Listp, Vtocx, Pageno_Listp);	/* entry to deposit a list of addresses */


	records = Records;				/* number of records to be deposited */
	pvtx = Pvtx;				/* phys volume index */

/* The paged fsdct strategy states that the page table lock need
   not be locked to deposit. Nobody can withdraw our bit unless we
   have a problem, and if we find an unprotected address at
   the time we deposit, this will be the case irrespective
   of the page table lock. */

	do i = 0 to records - 1;
	     Devadd_Array (i).add_type = add_type.disk;	/* Make up for sins of vtoc_man */
	end;

	call page$deposit_list ((pvtx), Listp, 1, records, Vtocx, Pageno_Listp);

	return;


/*  Auxiliary entry for truncation/deposition of vtoceless segs */

truncate_deposit_all:
     entry (Astep);


	astep = Astep;				/* Copy astep */

	if aste.uid
	then call syserr (1, "pc: truncate_deposit_all call on VTOCed seg at ^p", astep);
	call truncate (astep, 0);			/* Clean up w.r.t. pc */

	if aste.hc_sdw
	then return;				/* Don't attempt semi-hc deposit */

	call list_deposited_add (astep, 0, -1, records, addr (deposit_list), null ());

	call page$deposit_list ((aste.pvtx), addr (deposit_list), 1, records, -1, null ());

	return;
%page;
move_page_table:
     entry (Old_Astep, New_Astep);


	sstp = addr (sst_seg$);
	cmp = sstp -> sst.cmp;
	old_astep = Old_Astep;
	new_astep = New_Astep;
	call pmut$lock_ptl (oldmask, ptwp);		/* lock and mask */

	if pc_trace
	then call trace ("move_page_table^-old astep = ^p, new astep = ^p", old_astep, new_astep);

	old_ptp = addrel (old_astep, sstp -> sst.astsize);/* get pointer to old page table */
	new_ptp = addrel (new_astep, sstp -> sst.astsize);/* get pointer to new page table */
	do i = 0 to sstp -> sst.pts (fixed (old_astep -> aste.ptsi, 3)) - 1;
	     new_ptp -> ptwa_bits (i) = old_ptp -> ptwa_bits (i);
						/* copy page table words */

	     old_ptp -> ptwa_bits (i) = null_devadd_not_in_core;
	     old_ptp -> mptwa (i).devadd = pc_move_page_table_1_null_addr;
	     ptp = addr (new_ptp -> ptwa (i));		/* point to specific ptw */
	     if atptw.core
	     then do;				/* ptw describes core */
		     cmep = addr (cmp -> cma (core_ptw.frame));
						/* address CME */
		     cme.ptwp = rel (ptp);		/* associate CME with new PTW */
		     cme.astep = rel (new_astep);	/* ditto ASTE */
		     devadd = cme.devadd;		/* get devadd from cme if in core */
		     if cme.notify_requested		/* if someone was waiting on old PTW event, then notify .. */
		     then call pxss$notify (fixed (rel (addr (old_ptp -> ptwa (i))), 18));
						/* him, causing him to rewait on new event */
		end;
	     else devadd = mptw.devadd;		/* get devadd out of ptw if not in core */
	end;

	do i = sstp -> sst.pts (fixed (old_astep -> aste.ptsi, 3))
	     to sstp -> sst.pts (fixed (new_astep -> aste.ptsi, 3)) - 1;

	     new_ptp -> ptwa_bits (i) = null_devadd_not_in_core;
	     new_ptp -> mptwa (i).devadd = pc_move_page_table_2_null_addr;
	end;

/* Now copy the old ASTE into the new ASTE, except fp, bp, ptsi and marker */

	new_astep -> aste_part.two = old_astep -> aste_part.two;

	go to quit;
%page;


segmove:
     entry (Move_Astep, Old_Astep, New_Astep, New_Pvtx, New_Vtocx, Records, Listp, Pageno_Listp, Code);

	astep = Move_Astep;				/* aste under segmove */
	old_astep = Old_Astep;			/* put old addresses here for pcrsst */
	new_astep = New_Astep;			/* put new addresses here for pcrsst or caller to deposit */
	new_pvtx = New_Pvtx;			/* we can reference them without the */
	new_vtocx = New_Vtocx;			/* AST lock */
	sstp = addr (sst_seg$);
	cmp = sst.cmp;
	new_ptp = addwordno (new_astep, sst.astsize);	/* use that page table
						   to store up addresses on new volume */
	old_ptp = addwordno (old_astep, sst.astsize);	/* use that page table
						   to remember old addesses for the purposes of pcrsst */
	move_ptp = addwordno (astep, sst.astsize);	/* this is the page table of affliction. */

	if astep -> aste.ptsi ^= new_astep -> aste.ptsi | new_astep -> aste.ptsi ^= old_astep -> aste.ptsi
	then do;
		Code = error_table_$bad_arg;
		return;
	     end;

	last_page = sst.pts (fixed (astep -> aste.ptsi, 2)) - 1;

	call lock$lock_fast (addr (sst.segmove_lock));	/* Only one at a time */
	sst.segmove_new_addr_astep = new_astep;		/* pc_check_tables_ should deposit anything in here
						   or at least bang on the pvte inconsistency count. */

	call pmut$lock_ptl (oldmask, ptwp);		/* will be unlocked if we have to wait */

/**** Note that deposit_list is declared 0:255 and page$deposit_list expects a
      1:256 array. withdraw_list expects 0:255. Shouldn't be any trouble */

	segmove_records_in_hand = 0;
	segmove_total_records,			/* This many is the grand total that we have accumulated */
	     segmove_records_needed			/** This many are the number that we need to add to the record pile */
	     = fixed (astep -> aste.records, 9);	/* This is the first guess as to the total number of records needed */
						/* However, the guess may be too low since the PTL is unlocked. So */
						/* even when we get records_in_hand up and records_needed to 0, we may */
						/* have to add to total_records and reset records_needed to get the rest */


	move_tries = 0;

augment_record_pile:
/**** + Debug
      call syserr (ANNOUNCE, "pc: (at ARP) aste: np = ^d, records = ^d, csl = ^d", fixed (aste.np), fixed (aste.records), fixed (aste.csl));
*/
	code = 0;
	do while (segmove_records_needed > 0 & code = 0); /* keep calling until free_store gives all we want */
	     call page$withdraw_list (new_pvtx, new_ptp, segmove_records_in_hand, segmove_records_needed, ind, code);
						/* since parm(3) is zero based, zero records_in_hand is interpreted */
						/* as "put the next record in slot zero" which deposit addresses as  */
						/* slot one. */

	     if ind ^= 0
	     then /* wait for volmap */
		call wait_then_go_to (augment_record_pile);
	end;
	if code ^= 0
	then do;					/* out-of-volume */
		Code = code;
		go to SEGMOVE_ABORT_RETURN;
	     end;

/**** At this point, we own all the records we need. We can release the
      PTL while we drag the segment into memory. */

/****  NOTE -- at this point new_ptp contains segmove_total_records records.
      segmove_records_needed can be re-used.
      if we find that we need more records, total_records will grow,
      but in_hand will continue to be the number of addresses in new_addr_aste. */

move_retry:
	segmove_records_needed = 0;			/* re-count the number we need under the PTL */

/**** + Debug
      call syserr (ANNOUNCE, "pc: (at MRT) aste: np = ^d, records = ^d, csl = ^d", fixed (aste.np), fixed (aste.records), fixed (aste.csl));
*/

	move_tries = move_tries + 1;
	if move_tries > 1000
	then go to SEGMOVE_ABORT_RETURN;

	n_io_started = 0;
SEGMOVE_EXAMINE_PAGES:
	do i = 0 to last_page;			/* get all pages into memory */
RE_EXAMINE_PAGE:
	     if move_ptp -> ptwa (i).os
	     then do;				/* wait for i and  also o (quiesce) */

		     ind = wordno (addr (move_ptp -> ptwa (i)));
						/* event to wait on */
		     n_io_started = n_io_started + 1;
		     if n_io_started > sst.segmove_io_limit
		     then call wait_then_go_to (move_retry);
		end;
	     else if move_ptp -> atptwa (i).disk
	     then do;
		     sst.segmove_n_reads = sst.segmove_n_reads + 1;
		     call page$pread (astep, i, temp_ind);
						/* put event into temporary... */
		     if temp_ind ^= 0
		     then do;
			     ind = temp_ind;	/* OK to mung it now... */
			     n_io_started = n_io_started + 1;
			     if n_io_started > sst.segmove_io_limit
			     then call wait_then_go_to (move_retry);
			end;
		     else go to RE_EXAMINE_PAGE;	/* ZERO! */
		end;
	     else if move_ptp -> atptwa (i).core
	     then do;				/* in memory - keep it there */
		     segmove_records_needed = segmove_records_needed + 1;
						/* got another real one in memory */
		     cmep = addr (cmp -> cma (move_ptp -> core_ptwa (i).frame));
		     cme.pin_counter = 1000;
		     if astep -> aste.synchronized & (move_ptp -> core_ptwa (i).phm | move_ptp -> core_ptwa (i).phm1)
						/* any modified page of a synch segment is held until proven elsewise */
		     then call segmove_synch_page (astep, cmep, i);
		end;
	     else if move_ptp -> ptwa (i).add_type ^= "0000"b
						/* mysterious non-null */
	     then /* but unknown! */
		call syserr (CRASH, "pc$segmove: unexpected address type ^4b", move_ptp -> ptwa (i).add_type);
	end SEGMOVE_EXAMINE_PAGES;

/**** At arrival here, the PTL is locked (nothing can be evicted)
      and either all the pages are in memory, or we have some read-ahead
      activity. */

	if n_io_started > 0
	then call wait_then_go_to (move_retry);		/* ind is last read ahead page */

	sst.segmove_max_tries = max (move_tries, sst.segmove_max_tries);

/**** No read aheads. all pages found in core, PTL is locked.
      Start final countdown. Unless, somehow, the segment grew ... */

	if segmove_records_needed > segmove_total_records
	then do;					/* When we counted under the PTL and made them stand still, we found more of them. */
		segmove_total_records = segmove_records_needed;
						/* new count is the right count */
		segmove_records_needed = segmove_records_needed - segmove_records_in_hand;
						/* count of additional records required */
		go to augment_record_pile;		/* get 'em */

	     end;

/**** We have an adequate supply of records on the new volume,
      and everything is in memory. Here we go... */

/**** Since the move segment page table is in its final state
      (all addresses null or in core) we can copy all the ptw's
      to the old_addr_aste. pcrsst will find them there and
      put them back. All the new addreses have been accumulated
      in the new_addr_aste, where shutdown can deposit them.

      Thus the rules are:  if new_addr_astep ^= null (), deposit
      all the non-null addresses in its page table. pc_check_tables_
      does not currently concern itself with deposits, so these
      addresses are abandoned.

      if the move_astep ^= null (), then copy the page table
      from the old_addr_aste to the move_aste. The old_addr_astep
      is guaranteed to be non-null.

      if the old_addr_astep ^= null(), then zap all its ptw's
      to be null addresses. */

	sst.segmove_old_addr_astep = old_astep;		/* still full of nulls */
						/* now, pcrsst will zero all these ptw's */

	begin;					/* copy the page table wholesale from move to old astep */
	     declare pt		      (0:last_page) bit (36) aligned based;
	     old_ptp -> pt = move_ptp -> pt;
	end;					/* this can be copied back verbatim by pc_check_tables_
						   since we are under the PTL and nothing can change. */

	sst.segmove_pvtx = astep -> aste.pvtx;
	sst.segmove_vtocx = astep -> aste.vtocx;
	sst.segmove_astep = astep;			/* now, pcrsst will copy all the devadds from old to here */

/**** Now it only takes one loop to put the new disk devadds into
      the move aste. */

	segmove_records_used = 0;

	if segmove_total_records < fixed (aste.np)
	then call syserr (CRASH, "pc$segmove: miscounted pages.");

	do i = 0 to last_page;			/* now swap addresses */
	     devadd = move_ptp -> mptwa (i).devadd;	/* either core or null */
/**** + Debug
      call syserr (ANNOUNCE, "sgm: page ^d ptw devadd ^.3b",
      i, devadd);
*/
	     if (devadd_add_type & add_type.core) ^= ""b	/* core */
	     then do;
		     if segmove_records_used > segmove_records_in_hand
		     then call syserr (CRASH, "pc$segmove: out of records during move");
		     cmep = addr (cmp -> cma (move_ptp -> core_ptwa (i).frame));
		     move_ptp -> core_ptwa (i).phm1 = "1"b;
						/* modify! */
						/* it will get hierarchy incrementalled, which is unfortunate */
		     segmove_deposit_list (segmove_records_used) = cme.devadd;
/**** + Debug
      call syserr (ANNOUNCE, "sgm: old cme devadd ^.3b", cme.devadd);
*/
		     pageno_list (segmove_records_used) = i;
		     devadd = new_ptp -> mptwa (segmove_records_used).devadd;
						/* new record address + disk flag */
/**** + Debug
      call syserr (ANNOUNCE, "sgm: new devadd ^.3b", devadd);
*/
		     new_ptp -> mptwa (segmove_records_used).devadd = segmove_new_addr_null_addr;
						/* order here is noncritical,
						   pc check tables will zonk all of these anyway */
		     devadd_null_flag = "1"b;		/* you're not on disk yet, buddy! */
		     cme.devadd = devadd;
		     cme.phm_hedge = "1"b;
/**** + Debug
      call syserr (ANNOUNCE, "sgm: new devadd in CME ^.3b", devadd);
*/
		     cme.pin_counter = 0;		/* don't hold page any longer */
		     segmove_records_used = segmove_records_used + 1;
		end;
	end;

	if sst.crash_test_segmove
	then call syserr (CRASH, "pc$segmove: crashing in segment mover.");

	astep -> aste.pvtx = new_pvtx;		/* finish the swap */
	astep -> aste.vtocx = new_vtocx;		/* ... */
	astep -> aste.fmchanged = "1"b;		/* ... */

	sst.segmove_astep = null;			/* dont fix addresses, pvtx, or vtocx.
						   and dont copy page table from old_addr_aste */
	sst.segmove_pvtx = 0;
	sst.segmove_vtocx = 0;

/**** Now cleanup the old addresses, unbinding them from PTW's etc. */

	begin;
	     declare pt		      (0:last_page) bit (36) based;
	     declare px		      fixed bin;

	     declare 1 nptw		      aligned like l68_ptw;
	     declare ptwp		      pointer;

	     unspec (nptw) = ""b;
	     nptw.add = segmove_old_addr_null_addr;	/* thats whats left */
	     do px = 0 to last_page;
		ptwp = addr (old_ptp -> pt (px));	/* all are core addresses, we are under PTL after verifying that */
		devadd = ptwp -> mptw.devadd;
		if (devadd_add_type & add_type.non_null) ^= ""b
		then do;
			if (devadd_add_type & add_type.core) = ""b
			then call syserr (CRASH, "pc$segmove: non-memory PTW in old_addr_aste.");
			old_ptp -> pt (px) = unspec (nptw);
		     end;
	     end;
	end;
	sst.segmove_old_addr_astep = null ();

	call pmut$unlock_ptl (oldmask, ptwp);

	if segmove_records_in_hand > segmove_records_used
	then /* some records on new pvt left over */
	     call page$deposit_list (new_pvtx, new_ptp, segmove_records_used + 1,
		segmove_records_in_hand - segmove_records_used, -1, null ());

	call lock$unlock_fast (addr (sst.segmove_lock));

	Address_Array = segmove_deposit_list;		/* out from under PTL */
	Pageno_List = pageno_list;			/* so we can copy to unwired stack_0 */
	Records = segmove_records_used;		/* starts at zero, used as index
						   to zero-based array, then bumped. */

	return;

SEGMOVE_ABORT_RETURN:
	call pmut$unlock_ptl (oldmask, ptwp);
	if segmove_records_in_hand > 0
	then call page$deposit_list (new_pvtx, new_ptp, 1, segmove_records_in_hand, -1, null ());
						/* Abandon all the records that we collected */
	if Code = 0
	then					/** we may have a specific code */
	     Code = error_table_$action_not_performed;
	call lock$unlock_fast (addr (sst.segmove_lock));
	return;


segmove_synch_page:
     procedure (astep, cmep, pagex);

	declare (astep, cmep)	 pointer;
	declare pagex		 fixed bin;



/**** Call page control to write the page itself. If the synch_hold
      is legit, then .synch_hold will still be on when pwrite returns.
      If .synch_hold is off, the page is no longer held. */

	call page$pwrite (astep, pagex);

	if ^cmep -> cme.synch_held
	then do;
		sst.segmove_synch_disappeared = sst.segmove_synch_disappeared + 1;
		return;				/* page is fine, we can move it */
	     end;

	Code = error_table_$synch_seg_segmove;
	go to SEGMOVE_ABORT_RETURN;
     end segmove_synch_page;


%page;
drive_ok:
     proc (pvtx) returns (bit (1) aligned);		/* test drive state */

	dcl     pvtx		 fixed bin;

	return (^pvt_array (pvtx).device_inoperative);

     end drive_ok;
%page;
wait_then_go_to:
     procedure (lab);				/* quick internal proc to trace and wait for
						   page control events */
	dcl     lab		 label local;

	if ind = 0
	then call syserr (CRASH, "pc: waiting for zero event.");

	if pc_trace
	then call trace ("wait for i/o");
	call page$cam;				/* make sure any work done so far gets done */
	call page$pwait (ind);			/* wait for event */
	go to lab;

     end wait_then_go_to;

/* format: off */
%page; %include sst;
%page; %include pvte;
%page; %include cmp;
%page; %include aste;
%page; %include fm;
%page; %include null_addresses;
%page; %include add_type;
%page; %INCLUDE "ptw.macro";
%page; %include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   pc: unprotected address DDDDD in DSKX_NN VTOCX

   S:	$info

   T:	$run

   M:	The disk address DDDDD
   is not marked as protected
   in the record usage map for the volume mounted on DSKX_NN.
   This condition has been discovered
   while activating the segment with VTOC index VTOCX.
   The segment's damaged switch is turned on, and a page of zeros will
   replace the bad address. This condition may be symptomatic of disk
   or other hardware failure.

   A:	$inform


   Message:
   pc: truncate_deposit_all call on VTOCed seg at ASTEP

   S:	$crash

   T:	$run

   M:	A call to pc$truncate_deposit_all
   has been made on a segment for which this operation is not allowed.
   The AST entry at ASTEP should have a zero unique ID
   but it does not.
   $err
   $crashes

   A:	$recover


   END MESSAGE DOCUMENTATION */

     end pc;




		    pc_abs.pl1.pmac                 11/11/89  1105.1rew 11/11/89  0804.3       97794



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/* format: style4,delnl,insnl,indattr,ifthen,dclind10 */
         /* use: pl1_macro pc_abs.pl1.pmac  -target l68 */
pc_abs:
     procedure;

/* This procedure is responsible for adding and removing blocks of memory
   and for abs-wiring memory for I/O segments.

   The original pc_abs was written by Roger R. Schell in September 1970.
   Rewritten 6/3/74 by Bernard S. Greenberg for evict_page and page$pwait.
   Abs-wire functions removed 6/3/74 by B. Greenberg for I/O Buffer manager.
   Totally rewritten for new cme protocols, no remove list, and 75% code reduction, 03/12/75, BSG.
   Modified to allow evict_page to delete, for automatic parity deletion, BSG, 05/11/78.
   Modified to handle case when pages to be deleted are already gone, Chris Jones, 8/84
   Modified 1984-10-26 BIM to pay attention to the first argument to 
	  wire/unwire.
   Modified 1984-12-07, Keith Loepere, to not avoid abs wiring in low 256K.
*/


/****^  HISTORY COMMENTS:
  1) change(86-10-07,Farley), approve(86-11-20,MECR0002),
     audit(86-11-19,Fawcett), install(86-11-20,MR12.0-1222):
     Added three checks to the unwire_abs entry. First verify that the Astep
     parameter is non-null. Second verify that the page table word does really
     define a wired/in-core page. Third verify that the CME is really abs wired.
     Crash if any of these are incorrect.
  2) change(86-12-19,Farley), approve(86-12-19,MCR7587),
     audit(86-12-19,Fawcett), install(87-01-05,MR12.0-1253):
     Formal installation to close out above MECR0002.
                                                   END HISTORY COMMENTS */


dcl	Code		   fixed bin (35) parameter;
dcl	Absaddr		   fixed bin (26) parameter;
dcl	Fpage		   fixed bin (9) parameter; /* zero based */
dcl	Npages		   fixed bin (9) parameter;
dcl	Fframe		   fixed bin (16) parameter;
dcl	Nframes		   fixed bin (16) parameter;
dcl	Modulus		   fixed bin (16) parameter;
dcl	Astep		   pointer parameter;

dcl	astep		   ptr;
dcl	(ind, aind)	   fixed bin (35);
dcl	(fframe, nframes, frame, modulus)
			   fixed bin (16);
dcl	(fp, np, page)	   fixed bin (9);
dcl	frames		   (0:255) fixed bin (16);

dcl	oldmask		   fixed bin (71) aligned;
dcl	sptp		   ptr;

dcl	based_word	   fixed bin (35) aligned based;

dcl	page$evict	   entry (ptr, fixed bin (35));
dcl	page$pwait	   entry (fixed bin (35));
dcl	page$wire_abs	   entry (ptr, fixed bin (35), ptr, fixed bin (9));
dcl	pmut$lock_ptl	   entry (fixed bin (71) aligned, ptr);
dcl	pmut$unlock_ptl	   entry (fixed bin (71) aligned, ptr);
dcl	syserr		   entry options (variable);

dcl	ALL_ONES		   fixed bin (35) static options (constant) init (-1);
dcl	CORE		   bit (4) static options (constant) init ("8"b4);

dcl	error_table_$out_of_main_memory
			   fixed bin (35) external static;
dcl	sst$abs_wired_count	   fixed bin (35) external;
dcl	sst$astsize	   fixed bin (17) external;
dcl	sst$cmp		   ptr external;
dcl	sst$first_core_block   fixed bin (16) external;
dcl	sst$last_core_block	   fixed bin (16) external;
dcl	sst$nused		   fixed bin (35) external;
dcl	sst$usedp		   bit (18) aligned external;
dcl	sst$wusedp	   bit (18) aligned external;
dcl	sst$wired		   fixed bin (35) external;
dcl	sys_info$page_size	   fixed bin (17) external static;

dcl	(addr, addrel, binary, max, mod, null, ptr, rel, wordno)
			   builtin;

remove_core:
     entry (Fframe, Nframes, Code);

	Code = 0;
	fframe = Fframe;
	nframes = Nframes;

	call lock;				/* wire and lock */

	do frame = 1 to nframes;			/* make sure it is not in use */
	     if sst$cmp -> cma (fframe + frame - 1).abs_w then do;
		call unlock;
		Code = 2;				/* return error code */
		return;
	     end;
	end;

	call remove_frames;				/* get rid of them */

	call unlock;
	return;
%skip (3);
remove_core_mod:
     entry (Nframes, Modulus, Absaddr, Code);

	nframes = Nframes;
	modulus = Modulus;
	Absaddr = -1;
	Code = 0;

	call lock;
	call find_frames;
	call remove_frames;
	call unlock;

	Absaddr = fframe * sys_info$page_size;
	return;

wire_abs_contig:
     entry (Astep, Fpage, Npages, Code);

	astep = Astep;				/* Copy args before locking page table lock */
	fp = Fpage;
	np, nframes = Npages;
	Code = 0;

	call lock;

	modulus = 1;
retry_contig:
	call find_frames;

	if fframe >= 256 then
	     goto noalloc;				/* must keep I/O buffers low */
						/* see iom_connect.alm for details. */

	do frame = 0 to nframes - 1;
	     frames (frame) = fframe + frame;
	end;

	if ^abs_wire_frames () then
	     goto retry_contig;

	call unlock;

	return;

wire_abs:
     entry (Astep, Fpage, Npages, Code);

	astep = Astep;
	fp = Fpage;
	np, nframes = Npages;
	Code = 0;

	call lock;

retry:
	page = 0;
	do fframe = max (sst$first_core_block, 256) to sst$last_core_block while (page < np);
						/* save low 256K for wire_abs_contig */
	     cmep = addr (sst$cmp -> cma (fframe));
	     if (cmep -> based_word ^= ALL_ONES) & ^cme.abs_w & ^cme.removing & cme.abs_usable
		& ((cme.fp ^= ""b) | (cme.ptwp ^= ""b)) then do;
		frames (page) = fframe;
		page = page + 1;
	     end;
	end;
	if page < np then do;
noalloc:
	     call unlock;
	     Code = error_table_$out_of_main_memory;
	     return;
	end;

	if ^abs_wire_frames () then
	     goto retry;

	call unlock;
	return;

unwire_abs:
     entry (Astep, Fpage, Npages);

	astep = Astep;
	fp = Fpage;
	np = Npages;

	if astep = null () then do;
	     call syserr (CRASH, "pc_abs$unwire_abs: Called with NULL astep.");
	     return;
	end;

	do page = fp to fp + np - 1;			/* unwire the pages */
	     ptp = addrel (astep, sst$astsize + page);
	     if (ptw.add_type = CORE) & ptw.wired then do;/* valid PTW */
		frame = core_ptw.frame;		/* find the core frame */

		cmep = addr (sst$cmp -> cma (frame));
		if ^cme.abs_w
		     then call syserr (CRASH, "pc_abs$unwire_abs: Attempt to unwire inconsistent CME at ^p.", cmep);

/* reset wired & abs_w here */

		ptw.phm = "1"b;			/* in case the IOM modified it */
		ptw.wired = "0"b;			/* not wired any more */

		cme.abs_w = "0"b;

		sst$wired = sst$wired - 1;
		sst$abs_wired_count = sst$abs_wired_count - 1;
	     end;
	     else call syserr (CRASH, "pc_abs$unwire_abs: Attempt to unwire inconsistent PTW at ^p.", ptp);
	end;

	return;

find_frames:
     procedure;

dcl	j		   fixed bin (16);

	do fframe = sst$first_core_block + mod (-sst$first_core_block, modulus) by modulus to sst$last_core_block;
						/* find a possible first page */
	     j = 0;
	     if mod (fframe + nframes - 1, 256) < (nframes - 1) then
		goto will_not_do;			/* and we won't cross 256K boundary */
	     do j = 0 to nframes - 1;			/* check each page */
		cmep = addr (sst$cmp -> cma (fframe + j));
						/* get ptr to cme */
		if (cmep -> based_word = ALL_ONES) | cme.abs_w | cme.removing | (^cme.abs_usable)
		     | ((cme.fp = ""b) & (cme.ptwp = ""b)) then
		     go to will_not_do;		/* OS are just fine, as long as... */
	     end;

	     return;

will_not_do:
	     fframe = fframe + j - mod (j, modulus);
	end;

	goto noalloc;

     end find_frames;

remove_frames:
     procedure;

	do frame = 1 to nframes;			/* mark all frames */
	     sst$cmp -> cma (fframe + frame - 1).removing = "1"b;
	end;

	ind = -1;					/* do at least one pass */
	do while (ind ^= 0);			/* loop until it's done */
	     ind = 0;
	     do frame = 1 to nframes;			/* for each frame to be evicted */
		cmep = addr (sst$cmp -> cma (fframe + frame - 1));
						/* find CME */
		if cmep -> based_word ^= ALL_ONES then do;
						/* it has not yet been deleted */
		     call page$evict (cmep, aind);	/* start it out */
		     if (cmep -> based_word ^= ALL_ONES) & (aind = 0) then do;
			ptr (cmep, cme.fp) -> cme.bp = cme.bp;
						/* unthread it */
			ptr (cmep, cme.bp) -> cme.fp = cme.fp;
			if sst$usedp = rel (cmep) then
			     sst$usedp = cme.fp;
			if sst$wusedp = rel (cmep) then
			     sst$wusedp = cme.fp;
			cmep -> based_word = ALL_ONES;/* mark it gone */
			cme.abs_usable, cme.removing = "0"b;
			sst$nused = sst$nused - 1;
		     end;
		     else if ind = 0 then
			ind = aind;		/* multiplex waits */
		end;
	     end;
	     if ind ^= 0 then
		call page$pwait (ind);
	end;

	if (fframe + nframes) > sst$last_core_block then
	     sst$last_core_block = fframe - 1;

	return;

     end remove_frames;

abs_wire_frames:
     procedure returns (bit (1) aligned);

/**** In this procedure, "page" is the index (from zero) 
      into the array of abs_usuable pages found in the core map,
      and fp + page is the index into the segment's page table. */

	do frame = 1 to nframes;			/* mark them used */
	     sst$cmp -> cma (frames (frame - 1)).abs_w = "1"b;
	end;

	ind = -1;
	do while (ind ^= 0);
	     ind, aind = 0;
	     do page = 0 to np - 1;
		cmep = addr (sst$cmp -> cma (frames (page)));
		if (wordno (astep) + sst$astsize + fp + page) ^= binary (cme.ptwp, 18) then
		     call page$evict (cmep, aind);

		if cmep -> based_word = ALL_ONES then do;
		     call syserr (CRASH, "pc_abs: Parity error in I/O buffer.");
		     return ("0"b);
		end;

		if aind = 0 then
		     call page$wire_abs (cmep, aind, astep, fp + page);

		if ind = 0 then
		     ind = aind;
	     end;

	     if ind ^= 0 then
		call page$pwait (ind);
	end;

	sst$abs_wired_count = sst$abs_wired_count + nframes;
	return ("1"b);

     end abs_wire_frames;

lock:
     procedure;

	call pmut$lock_ptl (oldmask, sptp);		/* lock the ptl */
	return;

     end lock;


unlock:
     procedure;

	call pmut$unlock_ptl (oldmask, sptp);		/* almost done */
	return;

     end unlock;

%include syserr_constants;
%page;
%include cmp;
%INCLUDE "ptw.macro";

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   pc_abs: Parity error in I/O buffer.

   S:	$crash

   T:	$run

   M:	$err

   A:	$recover

   Message:
   pc_abs$unwire_abs: Called with NULL astep.

   S:	$crash

   T:	$run

   M:	$err

   A:	$inform
   $recover

   Message:
   pc_abs$unwire_abs: Attempt to unwire inconsistent CME at CMEP.

   S:	$crash

   T:	$run

   M:	The core map entry for the page being abs unwired did not
   have the abs_w flag on, which indicates that it was properly abs wired.
   $err

   A:	$inform
   $recover

   Message:
   pc_abs$unwire_abs: Attempt to unwire inconsistent PTW at PTP.

   S:	$crash

   T:	$run

   M:	A page at PTP, within the range of pages being unwired for,
   was found to either not be wired or no longer in memory.
   $err

   A:	$inform
   $recover

   END MESSAGE DOCUMENTATION */

     end pc_abs;




		    pc_deposit.pl1                  11/11/89  1105.1r w 11/11/89  0804.3      137385



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/* format: style3 */
pc_deposit:
     proc (Pvtx, Devadd, Vtocx, Pageno);

/*  Routine to deposit an address or a list of addresses to the Volume
    Map. It is called from ALM Page Control when the address or addresses
    cannot be deposited into the record stock. This can happen only if
    the record stock is full. Asynchronous record stock management
    will deposit excess addresses to the Volume Map as we update each
    Volume Map page.

    This routine is also called during a volume scavenge, when addresses
    are to be deposited to the volume being scavenged. Asynchronous
    scavenger action is done here (that is, the scavenger data block
    for this volume is updated - addresses being deposited are checked
    for conflicts and their states are updated). 

    Written March 1982 by J. Bongiovanni
    Modified July 1982 by J. Bongiovanni for the scavenger
*/


/****^  HISTORY COMMENTS:
  1) change(86-06-10,Hartogs), approve(86-06-10,MCR7383),
     audit(86-06-11,Coppola), install(86-07-17,MR12.0-1097):
     Calls to syserr modified to report on subvolumes.
                                                   END HISTORY COMMENTS */


/*  Parameter  */

dcl	Pvtx		fixed bin parameter;	/* PVTE index */
dcl	Devadd		bit (36) aligned parameter;	/* Single address to deposit */
dcl	Vtocx		fixed bin;		/* VTOCE index (used by scavenger) */
dcl	Pageno		fixed bin;		/* Page number within segment (used by scavenger) */
dcl	List_ptr		ptr parameter;		/* Pointer to list of addresses */
dcl	First		fixed bin;		/* First element to deposit in array */
dcl	Last		fixed bin;		/* Last element to deposit in array */
dcl	Pageno_list_ptr	ptr;			/* Pointer to list of page numbers */

/*  Automatic  */

dcl	check_scavenger	bit (1) aligned;
dcl	conflict		bit (1) aligned;
dcl	grabbed_vpage	fixed bin;
dcl	listx		fixed bin;
dcl	listx1		fixed bin;
dcl	p99		pic "99";
dcl	pageno		fixed bin;
dcl	pages		fixed bin;
dcl	pf_begin		fixed bin (35);
dcl	pf_end		fixed bin (35);
dcl	Single_addressp	ptr;
dcl	this_vpage	fixed bin;
dcl	vcpu_begin	fixed bin (71);
dcl	vcpu_end		fixed bin (71);
dcl	volmap_locked	bit (1);
dcl	vpage_found	bit (1);
dcl	vpage_list	(256) fixed bin;
dcl	vpage_no		fixed bin;
dcl	vpage_ptr		ptr;
dcl	vtoc_index	fixed bin;

/*  Static  */

dcl	NULL_SDW		fixed bin (71) int static options (constant) init (0);
dcl	RECORDS_PER_WORD	fixed bin int static options (constant) init (32);

/*  Based  */

dcl	1 List		(Last) aligned like Single_address based (List_ptr);
dcl	Pageno_list	(Last) fixed bin based (Pageno_list_ptr);
dcl	1 Single_address	aligned based (Single_addressp),
	  2 Null_flag	bit (1) unaligned,
	  2 Address	fixed bin (17) unsigned unaligned,
	  2 Pad		bit (18) unaligned;

/*  External  */

dcl	volmap_abs_seg$	external;

/*  Entry  */

dcl	page$grab_volmap_page_unwired
			entry (ptr, fixed bin, ptr);
dcl	page$lock_volmap	entry (ptr);
dcl	page$unlock_volmap	entry (ptr);
dcl	page$write_volmap_page_unwired
			entry (ptr, fixed bin);
dcl	pmut$swap_sdw	entry (ptr, ptr);
dcl	syserr		entry options (variable);
dcl	usage_values	entry (fixed bin (35), fixed bin (71));

/*  Condition  */

dcl	cleanup		condition;
dcl	page_fault_error	condition;

/*  Builtin  */

dcl	addr		builtin;
dcl	convert		builtin;
dcl	divide		builtin;
dcl	mod		builtin;
dcl	null		builtin;
dcl	ptr		builtin;
dcl	stacq		builtin;
dcl	unspec		builtin;
%page;
/*  Deposit a single record address into the Volume Map  */

	call usage_values (pf_begin, vcpu_begin);
	pages = 1;

	pvtep = addr (addr (pvt$array) -> pvt_array (Pvtx));
	record_stockp = pvte.volmap_stock_ptr;
	Single_addressp = addr (Devadd);
	volmap_locked = "0"b;
	grabbed_vpage = -1;

	call CHECK_FOR_SCAVENGE;

	vtoc_index = Vtocx;
	pageno = Pageno;

	call FIND_VOLMAP_PAGE (Single_addressp, vpage_no, pageno, conflict);
	if conflict
	then goto RETURN;

	on cleanup call UNLOCK_RESET;

	call LOCK_SETUP;

	on page_fault_error
	     begin;
		call IO_ERROR;
		goto RETURN;
	     end;

	call page$grab_volmap_page_unwired (pvtep, vpage_no - 1, vpage_ptr);
	grabbed_vpage = vpage_no - 1;

	call DEPOSIT_TO_PAGE ((Single_address.Address), vpage_no, vpage_ptr);

	call page$write_volmap_page_unwired (pvtep, vpage_no - 1);
	grabbed_vpage = -1;

RETURN:
	revert page_fault_error;

	call UNLOCK_RESET;

	call METER;

	return;
%page;
/*  Deposit a list of addresses into the Volume Map. Go through the list
    some number of times. For each candidate found, compute the Volume
    Map page number, grab the page, and deposit all addresses in the list
    which belong to that page.
*/

pc_deposit$deposit_list:
     entry (Pvtx, List_ptr, First, Last, Vtocx, Pageno_list_ptr);

	call usage_values (pf_begin, vcpu_begin);
	pages = Last - First + 1;

	pvtep = addr (addr (pvt$array) -> pvt_array (Pvtx));
	record_stockp = pvte.volmap_stock_ptr;
	volmap_locked = "0"b;
	grabbed_vpage = -1;

	call CHECK_FOR_SCAVENGE;

	vtoc_index = Vtocx;

	do listx = First to Last;
	     if Pageno_list_ptr = null ()
	     then pageno = -1;
	     else pageno = Pageno_list (listx);
	     call FIND_VOLMAP_PAGE (addr (List (listx)), vpage_list (listx), pageno, conflict);
	     if conflict
	     then vpage_list (listx) = -1;
	end;

	on cleanup call UNLOCK_RESET;

	call LOCK_SETUP;

	on page_fault_error
	     begin;
dcl	pagex		fixed bin;

		if grabbed_vpage >= 0
		then do;
			do pagex = First to Last;
			     if vpage_list (pagex) = grabbed_vpage + 1
			     then vpage_list (pagex) = -1;
			end;
			call IO_ERROR;
		     end;
		goto VPAGE_RETRY;
	     end;

VPAGE_RETRY:
	vpage_found = "0"b;
	do listx = First to Last;
	     if vpage_list (listx) > 0
	     then do;
		     vpage_found = "1"b;
		     this_vpage = vpage_list (listx);
		     call page$grab_volmap_page_unwired (pvtep, this_vpage - 1, vpage_ptr);
		     grabbed_vpage = this_vpage - 1;
		     do listx1 = listx to Last;
			if vpage_list (listx1) = this_vpage
			then do;
				call DEPOSIT_TO_PAGE ((List (listx1).Address), this_vpage, vpage_ptr);
				vpage_list (listx1) = -1;
			     end;
		     end;
		     call page$write_volmap_page_unwired (pvtep, grabbed_vpage);
		     grabbed_vpage = -1;
		end;
	end;

	if vpage_found
	then goto VPAGE_RETRY;

	revert page_fault_error;

	call UNLOCK_RESET;

	call METER;

	return;
%page;
/* Internal Procedure to find the Volume Map page associated with a given
   address */

FIND_VOLMAP_PAGE:
     proc (Devaddp, Volmap_pageno, Page_no, Conflict);

dcl	Devaddp		ptr parameter;
dcl	Volmap_pageno	fixed bin parameter;
dcl	Page_no		fixed bin parameter;
dcl	Conflict		bit (1) aligned parameter;

dcl	vpagex		fixed bin;
dcl	vpage_found	bit (1);
dcl	address		fixed bin;

dcl	1 Devaddr		aligned like Single_address based (Devaddp);

	vpage_found = "0"b;
	address = Devaddr.Address;
	Conflict = "0"b;

	if address < pvte.baseadd | address >= pvte.baseadd + pvte.totrec
	then call syserr (CRASH, "pc_deposit: Address ^o out of paging region on ^a_^a^[^a^;^s^].", address, pvte.devname,
		convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);

	do vpagex = record_stock.n_volmap_pages to 1 by -1 while (^vpage_found);
	     if address >= record_stock.volmap_page (vpagex).baseadd
	     then do;
		     vpage_found = "1"b;
		     Volmap_pageno = vpagex;
		end;
	end;

	if ^vpage_found
	then call syserr (CRASH, "pc_deposit: Invalid address ^o on ^a_^a^[^a^;^s^].", address, pvte.devname,
		convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);

	if check_scavenger
	then Conflict = CHECK_ADDRESS_FOR_SCAVENGER (address, Page_no);

	return;


     end FIND_VOLMAP_PAGE;
%page;
/* Internal Procedure to deposit a single record address to the Volume Map */

DEPOSIT_TO_PAGE:
     proc (Record_address, Vpage_no, Vpage_ptr);

dcl	Record_address	fixed bin;
dcl	Vpage_no		fixed bin;
dcl	Vpage_ptr		ptr;

dcl	bit_no		fixed bin;
dcl	word_no		fixed bin;

dcl	1 Vm_page		aligned based (Vpage_ptr),
	  2 Word		(0:1023) aligned,
	    3 Pad1	bit (1) unaligned,
	    3 Bit		(0:31) bit (1) unaligned,
	    3 Pad2	bit (3) unaligned;

	word_no = divide (Record_address - record_stock.volmap_page (Vpage_no).baseadd, RECORDS_PER_WORD, 17);
	if word_no < 0 | word_no > 1023 | (Vpage_no = 1 & word_no < 64)
	then call syserr (CRASH, "pc_deposit: Invalid address ^o on ^a_^a^[^a^;^s^].", Record_address, pvte.devname,
		convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);

	bit_no = mod (Record_address - record_stock.volmap_page (Vpage_no).baseadd, RECORDS_PER_WORD);

	if Vm_page.Word (word_no).Bit (bit_no)
	then do;
		call syserr (ANNOUNCE, "pc_deposit: Deposit in-use address ^o on ^a_^a^[^a^;^s^].", Record_address,
		     pvte.devname, convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);
		pvte.vol_trouble_count = pvte.vol_trouble_count + 1;
						/* Add to inconsistency count */
	     end;
	else do;
		Vm_page.Word (word_no).Bit (bit_no) = "1"b;
		pvte.nleft = pvte.nleft + 1;
		record_stock.volmap_page (Vpage_no).n_free = record_stock.volmap_page (Vpage_no).n_free + 1;
	     end;

	return;

     end DEPOSIT_TO_PAGE;
%page;
/*  Internal Procedure to handle I/O Error on the Volume Map  */

IO_ERROR:
     proc;

	pvte.vol_trouble_count = pvte.vol_trouble_count + 1;
	if grabbed_vpage >= 0
	then if record_stock.volmap_page (grabbed_vpage + 1).n_free > 0
	     then do;
		     record_stock.volmap_page (grabbed_vpage + 1).n_free = 0;
		     call syserr (BEEP,
			"pc_deposit: Unrecoverable I/O error on Volmap page ^d of ^a_^a^[^a^;^s^]. Addresses lost.",
			grabbed_vpage, pvte.devname, convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name);
		end;

     end IO_ERROR;
%page;
/*  Internal procedure to see whether there's a scavenge goin' on for this
    physical volume and set a flag accordingly.
*/

CHECK_FOR_SCAVENGE:
     proc;

	check_scavenger = "0"b;

	scavenger_blockp = null ();
	scavenger_datap = addr (scavenger_data$);

	if pvte.scavenger_block_rel ^= ""b
	then if pvte.scav_check_address
	     then do;
		     check_scavenger = "1"b;
		     scavenger_blockp = ptr (scavenger_datap, pvte.scavenger_block_rel);
		end;

     end CHECK_FOR_SCAVENGE;
%page;
/*  Internal Procedure to check an address against the scavenger block for
    this physical volume. The state is updated and conflicts marked
    appropriately. Indication of conflict is returned to the caller,
    so that the address is not deposited.
*/

CHECK_ADDRESS_FOR_SCAVENGER:
     proc (Record_address, Page_no) returns (bit (1) aligned);

dcl	Record_address	fixed bin parameter;
dcl	Page_no		fixed bin parameter;

dcl	1 A_record_block	aligned like record_block;
dcl	Ap		ptr;
dcl	conflict		bit (1) aligned;
dcl	locked		bit (1) aligned;
dcl	1 Q_record_block	aligned like record_block;
dcl	Qp		ptr;
dcl	Wp		ptr;

dcl	A		bit (36) aligned based (Ap);
dcl	Q		bit (36) aligned based (Qp);
dcl	W		bit (36) aligned based (Wp);


	record_blockp = addr (scavenger_block.records (Record_address - pvte.baseadd + 1));

	locked = "0"b;
	Ap = addr (A_record_block);
	Qp = addr (Q_record_block);
	Wp = record_blockp;
	do while (^locked);
	     unspec (Q_record_block) = unspec (record_block);
	     unspec (A_record_block) = unspec (Q_record_block);
	     if ^A_record_block.lock
	     then do;
		     A_record_block.lock = "1"b;
		     locked = stacq (W, A, Q);
		end;
	end;

	if record_block.state = STATE_UNSEEN
	then record_block.state = STATE_FREE;
	else if record_block.state = STATE_FREE
	then record_block.state = STATE_CONFLICT;
	else if record_block.state = STATE_IN_USE
	then do;
		if Page_no >= 0 & vtoc_index >= 0 & record_block.vtocx = vtoc_index & record_block.pageno = Page_no
		then do;
			record_block.vtocx = 0;
			record_block.pageno = 0;
			record_block.state = STATE_FREE;
		     end;
		else record_block.state = STATE_CONFLICT;
	     end;

	if record_block.state = STATE_CONFLICT
	then conflict = "1"b;
	else conflict = "0"b;

	record_block.lock = "0"b;

	return (conflict);


     end CHECK_ADDRESS_FOR_SCAVENGER;


%page;
/*  Internal Procedure to lock the Volume Map lock, setup volmap_abs_seg  */

LOCK_SETUP:
     proc;

	call page$lock_volmap (pvtep);
	volmap_locked = "1"b;
	call pmut$swap_sdw (addr (volmap_abs_seg$), addr (pvte.volmap_seg_sdw));

     end LOCK_SETUP;
%page;
/*  Internal Procedure to Cleanup  */

UNLOCK_RESET:
     proc;

	if grabbed_vpage ^= -1
	then call page$write_volmap_page_unwired (pvtep, grabbed_vpage);
	grabbed_vpage = -1;

	call pmut$swap_sdw (addr (volmap_abs_seg$), addr (NULL_SDW));

	if volmap_locked
	then call page$unlock_volmap (pvtep);
	volmap_locked = "0"b;

     end UNLOCK_RESET;
%page;
/*  Internal Subroutine to meter CPU time, number of calls, and number of pages
    whose addresses were deposited  */

METER:
     proc;

	stock_segp = addr (stock_seg$);
	stock_seg.meters.pc_deposit_calls = stock_seg.meters.pc_deposit_calls + 1;
	stock_seg.meters.pc_deposit_pages = stock_seg.meters.pc_deposit_pages + pages;
	call usage_values (pf_end, vcpu_end);
	stock_seg.meters.pc_deposit_time = stock_seg.meters.pc_deposit_time + vcpu_end - vcpu_begin;

     end METER;

%page;
%include pvte;
%page;
%include scavenger_data;
%page;
%include stock_seg;
%page;
%include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   pc_deposit: Address XXXXXX out of paging region on dskX_NN{s}.

   S:     $crash

   T:	$run

   M:	An attempt was made to return disk address XXXXXX on device dskX_NN{s}
   to the free pool. The address is not in the paging region.

   A:	$recover
   It may be necessary to run the physical volume salvager on the device.

   Message:
   pc_deposit: Invalid address XXXXXX on dskX_NN{s}.

   S:     $crash

   T:	$run

   M:	In attempting to deposit address XXXXXX on device dskX_NN{s}, an invalid
   volume map offset was computed. 

   A:	$recover
   It may be necessary to run the physical volume salvager on the device.

   Message:
   pc_deposit: Deposit in-use address XXXXXX on dskX_NN{s}.

   S:     $beep

   T:	$run

   M:	An attempt was made to return address XXXXXX on device dskX_NN{s} to
   the free record pool, but the address was already marked as free. This 
   indicates damage to control structures on the device. This damage can
   be corrected by a physical volume salvage.

   A:     $inform

   Message:
   pc_deposit: Unrecoverable I/O error on Volmap page M of dskX_NN{s}. Addresses lost.

   S:     $beep

   T:	$run

   M:	There was an unrecoverable I/O error on a page of the Volume Map,
   which describes free records of the volume. All free records described
   by that page have been lost.

   A:     It may be possible to recover the lost addresses by a volume
   salvage. If there is a hard device error, the volume salvage will
   fail. In this case, it will be necessary to recover the volume onto
   a good pack.

   END MESSAGE DOCUMENTATION */

     end pc_deposit;




		    pc_signal.pl1                   11/11/89  1105.1r   11/11/89  0804.3       27792



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
/* format: style3 */
pc_signal:
     proc (Error_Type, Astep, Ptwp);

/*  Program to build structures for the signaller when a signallable error
    is detected by Page Control.

    Written October 1982 by J. Bongiovanni
*/

/*  Parameter  */

dcl	Error_Type	fixed bin parameter;	/* Index of error */
dcl	Astep		ptr unaligned parameter;	/* -> ASTE of interest */
dcl	Ptwp		ptr unaligned parameter;	/* -> PTW of interest */

/*  Automatic  */

dcl	error_type	fixed bin;
dcl	1 page_fault_error_code
			aligned,			/* Error code hack until info structure implemented */
	  2 add		bit (18) unaligned,
	  2 add_type	bit (4) unaligned,
	  2 pad		bit (5) unaligned,
	  2 pvtx		fixed bin (9) unsigned unaligned;
dcl	ptwp		ptr;

/*  Static  */

dcl	SIGNAL_NAME	(0:3) char (32) internal static options (constant)
			init ("record_quota_overflow", "page_fault_error", "invalid_page_fault",
			"invalid_page_error");

/*  Based  */

dcl	1 Aste		aligned like aste based (Astep);
dcl	1 Ptw		aligned like ptw based (Ptwp);

/*  External  */

dcl	1 pds$condition_name
			aligned external,
	  2 len		fixed bin (8) unaligned,
	  2 chars		char (21) unaligned;
dcl	1 pds$page_fault_data
			aligned like mc external;
dcl	1 pds$signal_data	aligned like mc external;
dcl	sst$rqover	fixed bin (35) external;

/*  Builtin  */

dcl	bin		builtin;
dcl	bit		builtin;
dcl	length		builtin;
dcl	rtrim		builtin;
dcl	unspec		builtin;


%page;
	if (Error_Type < 0) | (Error_Type > PAGE_ERROR_MAXTYPE)
	then error_type = PAGE_ERROR_INVERROR;
	else error_type = Error_Type;

	unspec (pds$signal_data) = unspec (pds$page_fault_data);

	pds$condition_name.len = length (rtrim (SIGNAL_NAME (error_type)));
	pds$condition_name.chars = rtrim (SIGNAL_NAME (error_type));

	goto TYPE_SPECIFIC (error_type);

TYPE_SPECIFIC (0):					/* record quota overflow */
	pds$signal_data.fim_temp.fcode = bit (bin (record_quota_overflow_sct_index, 17), 17);
	pds$signal_data.errcode = sst$rqover;
	return;

TYPE_SPECIFIC (1):					/* page I/O error */
	pds$signal_data.fim_temp.fcode = bit (bin (page_fault_error_sct_index, 17), 17);
	unspec (page_fault_error_code) = ""b;
	page_fault_error_code.add = Ptw.add;
	page_fault_error_code.add_type = Ptw.add_type;
	page_fault_error_code.pvtx = Aste.pvtx;
	unspec (pds$signal_data.errcode) = unspec (page_fault_error_code);

	return;

TYPE_SPECIFIC (2):					/* bad machine conditions */
TYPE_SPECIFIC (3):					/* Invalid error type */
	return;

/* format: off */
%page;  %include aste;
%page;  %include mc;
%page;  %include page_error_types;
%page;  %include ptw;
%page;  %include static_handlers;
        
end pc_signal;




		    pc_trace.alm                    11/11/89  1105.1r w 11/11/89  0804.3       48474



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	pc_trace		tracing routine called by the alm
"			part of page control to print out tracing
"			information by calling pc_trace_pl1 with
"			pre-canned arument lists.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " "

" Written sometime by somebody, whose august identity is now sadly
"  lost in the dim mists of antiquity.
" Modified 03/01/81, W. Olin Sibert, for new sst include file and ADP conversion
"
	name	pc_trace

	include	pxss_page_stack
	include	sst
	include	page_info

	segdef	move_page,zero_page,no_paging_device,rws_truncated
	segdef	done,page_fault,page_fault_end,write_page
	segdef	abort_complete,running,rws_complete
	segdef	tr_pd_delete_,tr_rws,rehash,depositing,withdrawing

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

page_fault:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace_pf,dl
	tze	0,7
	spribp	arg+18
	tsx5	setup_argl_4
	call	pc_trace_pl1$page_fault(arg)
	tra	0,7

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

page_fault_end:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace_pf,dl
	tze	0,7
	spribp	arg+18
	tsx5	setup_argl_4
	call	pc_trace_pl1$page_fault_end(arg)
	tra	0,7

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

write_page:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace_pf,dl
	tze	0,7
	eppap	sst|0,4
	spriap	arg+18
	tsx5	setup_argl_4
	call	pc_trace_pl1$write_page(arg)
	tra	0,7

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

done:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace_pf,dl
	tze	0,7
	eppap	sst|0,4
	spriap	arg+18
	tsx5	setup_argl_4
	call	pc_trace_pl1$done(arg)
	tra	0,7

" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

abort_complete:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	eppap	sst|0,1		get a pointer to the pdmep
	spriap	arg+18
	spribp	arg+20		save ptp
	tsx5	setup_argl_1
	call	pc_trace_pl1$abort_complete(arg)
	tra	0,7

setup_argl_1:
	epplb	arg+18
	sprilb	arg+2
	epplb	arg+20
	sprilb	arg+4
	ldaq	argl1
	staq	arg
	tra	0,5
	even
argl1:
	zero	4,4
	zero	0,0

" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

move_page:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	tsx5	setup_argl_2
	call	pc_trace_pl1$move_page(arg)
	tra	0,7

setup_argl_2:
	epplb	devadd
	sprilb	arg+2
	ldaq	argl2
	staq	arg
	tra	0,5
	even
argl2:
	zero	2,4
	zero	0,0

" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

zero_page:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	spribp	arg+18		save ptp
	tsx5	setup_argl_3
	call	pc_trace_pl1$zero_page(arg)
	tra	0,7

	even
setup_argl_3:
	epplb	arg+18
	sprilb	arg+4
	epplb	devadd
		sprilb	arg+2
	ldaq	argl3
	staq	arg
	tra	0,5
	even
argl3:
	zero	4,4
	zero	0,0

" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

no_paging_device:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	spribp	arg+18		save ptp
	tsx5	setup_argl_3
	call	pc_trace_pl1$no_pd_(arg)
	tra	0,7

" " " " " " " " "" " " " " " " " " " " " " " " " " " " " "

rws_truncated:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	eppap	sst|0,1
	spriap	arg+18		save pointer to pdme
	tsx5	setup_argl_3
	call	pc_trace_pl1$rws_truncated(arg)
	tra	0,7

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

tr_pd_delete_:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	eppap	sst|0,0
	spriap	arg+18
	tsx5	setup_argl_4
	call	pc_trace_pl1$tr_pd_delete_(arg)
	tra	0,7

setup_argl_4:
	epplb	arg+18
	sprilb	arg+2
	ldaq	argl2
	staq	arg
	tra	0,5
	even
argl4:
	zero	2,4
	zero	0,0
argl0:
	zero	0,0
	zero	0,0

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

tr_rws:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	eppap	sst|0,1
	spriap	arg+18
	tsx5	setup_argl_4
	call	pc_trace_pl1$tr_rws(arg)
	tra	0,7

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

rehash:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	lda	ap|2,*		old devadd
	sta	arg+18
	lda	ap|4,*
	sta	devadd
	tsx5	setup_argl_3
	call	pc_trace_pl1$rehash(arg)
	tra	0,7

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

depositing:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,0
	tsx5	setup_argl_2
	call	pc_trace_pl1$depositing(arg)
	tra	0,0

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

withdrawing:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,0
	tsx5	setup_argl_2
	call	pc_trace_pl1$withdrawing(arg)
	tra	0,0

" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

running:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,6
	call	pc_trace_pl1$running(argl0)
	tra	0,6

" " " " " " " " " " " " " " " " " " " " " " " " " " " " "

rws_complete:
	ldq	sst|sst.trace_sw
	canq	sst.pc_trace,dl
	tze	0,7
	eppap	sst|0,1
	spriap	arg+18
	tsx5	setup_argl_4
	call	pc_trace_pl1$rws_complete(arg)
	tra	0,7
" 
	end




		    pc_trace_pl1.pl1                11/11/89  1105.1r w 11/11/89  0804.3       44334



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */


pc_trace_pl1: proc;

/* RE Mullen, v2pl1, oct 1973 */
/* RE Mullen, v2pl1, oct 1973 */

dcl (cmep, pdmep, ptp, a_pdmep, a_ptp) ptr,
     format1 char (22) aligned static init ("                    ^w"),
     format4 char (34) aligned static init ("                    ^w  ^w  ^w  ^w"),
     fword (0:10) fixed bin based,
    (devadd, a_devadd, bdevadd, b_devadd) fixed bin,
     trace entry options (variable);

done:	entry (a_pdmep);

	cmep = a_pdmep;
	call trace ("done                cmep = ^p", cmep);
	call trace (format4, cmep -> fword (0), cmep -> fword (1), cmep -> fword (2), cmep -> fword (3));
	return;

/* * * * * * * * * * * * * * *  * * * * * * * * * * * * * * */

page_fault: entry (a_pdmep);

	ptp = a_pdmep;
	call trace ("page fault          ptp = ^p", ptp);
	call trace (format1, ptp -> fword (0));
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

page_fault_end: entry (a_pdmep);

	ptp = a_pdmep;
	call trace ("end page fault      ptp = ^p", ptp);
	call trace (format1, ptp -> fword (0));
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

write_page: entry (a_pdmep);

	cmep = a_pdmep;
	call trace ("write page          cmep = ^p", cmep);
	call trace (format4, cmep -> fword (0), cmep -> fword (1), cmep -> fword (2), cmep -> fword (3));
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
abort_complete: entry (a_pdmep, a_ptp);

	pdmep = a_pdmep;
	ptp = a_ptp;
	call trace ("abort complete      pdmep = ^p, ptw = ^w", pdmep, ptp -> fword (0));
	call trace (format4, pdmep -> fword (0), pdmep -> fword (1), pdmep -> fword (2), pdmep -> fword (3));
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * */

move_page: entry (a_devadd);

	devadd = a_devadd;
	call trace ("moving page         ^w", devadd);
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * */

zero_page: entry (a_devadd, a_ptp);

	devadd = a_devadd;
	ptp = a_ptp;
	call trace ("zero page           ptw = ^w, devadd = ^w", ptp -> fword (0), devadd);
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

no_pd_:	entry (a_devadd, a_ptp);

	devadd = a_devadd;
	ptp = a_ptp;
	call trace ("no paging device    ptw = ^w, devadd = ^w", ptp -> fword (0), devadd);
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

rws_truncated: entry (a_devadd, a_ptp);

	devadd = a_devadd;
	pdmep = a_ptp;				/* on purpose ... for efficiency */
	call trace ("rws truncated       pdmep = ^p, devadd = ^w", pdmep, devadd);
	call trace (format4, pdmep -> fword (0), pdmep -> fword (1), pdmep -> fword (2), pdmep -> fword (3));
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

withdrawing: entry (a_devadd);

	devadd = a_devadd;
	call trace ("withdrawing         devadd = ^w", devadd);
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

depositing: entry (a_devadd);

	devadd = a_devadd;
	call trace ("depositing          devadd = ^w", devadd);
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

tr_pd_delete_: entry (a_pdmep);

	pdmep = a_pdmep;
	call trace ("pd_delete_          pdmep = ^p", pdmep);
	call trace (format4, pdmep -> fword (0), pdmep -> fword (1), pdmep -> fword (2), pdmep -> fword (3));
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

tr_rws:	entry (a_pdmep);

	pdmep = a_pdmep;
	call trace ("read/write start    pdmep = ^p", pdmep);
	call trace (format4, pdmep -> fword (0), pdmep -> fword (1), pdmep -> fword (2), pdmep -> fword (3));
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

rehash:	entry (a_devadd, b_devadd);

	devadd = a_devadd;
	bdevadd = b_devadd;
	call trace ("rehashing           old devadd = ^w, new devadd = ^w", devadd, bdevadd);
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

running:	entry;

	call trace ("running the devices");
	return;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

rws_complete: entry (a_pdmep);

	pdmep = a_pdmep;
	call trace ("rws complete        pdmep = ^p", pdmep);
	call trace (format4, pdmep -> fword (0), pdmep -> fword (1), pdmep -> fword (2), pdmep -> fword (3));
	return;

     end;




		    pc_wired.pl1.pmac               11/11/89  1105.1r w 11/11/89  0804.3       66042



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

         /* use: pl1_macro pc.pl1.pmac  -target l68 */
pc_wired: proc;

/* RE Mullen, v2pl1, oct 1973 */
/* Modified for unified page wait primitive, B. Greenberg 6/6/74 */
/* write_wait_uid for new lock, 11/3/75 by BSG */
/* Modified for ADP conversion, 03/03/81, W. Olin Sibert */
/* Modified for unwire_write_wait, February 1982, J. Bongiovanni */
/* Modified for write_wait_uid_list, November 1982, J. Bongiovanni */

dcl  a_astep pointer parameter;			/* pointer to AST entry */
dcl  first_page fixed bin parameter;			/* first page affected */
dcl  no_pages fixed bin parameter;			/* number of pages, or -1 if all remaining */
dcl  a_uid bit (36) aligned parameter;			/* arg uid of segment */
dcl  a_listp ptr parameter;				/* pointer to list of pages */
dcl  a_list (0:255) fixed bin based (a_listp);		/* list of pages */

dcl  fp fixed bin;					/* first page */
dcl  waitev fixed bin (35);				/* wait event from pread */
dcl  i fixed bin;					/* loop index */
dcl (j, k) fixed bin (35);				/* temporary wait indices */
dcl  rptp fixed bin (18);				/* offset of page table */
dcl  lp fixed bin;					/* last page */
dcl  np fixed bin;					/* number of pages */
dcl  max_page fixed bin;				/* highest page number allowed */
dcl  increment fixed bin;				/* do loop increment */
dcl  uid bit (36) aligned;				/* uid of segment */
dcl  oldmask fixed bin (71);				/* saved interrupt mask */
dcl  ptwp ptr;					/* saved pointer to ptw for wired stack pages */

dcl  do_io bit (1) aligned;				/* flag on if I/O is to be done */
dcl  io bit (1) aligned;				/* ="1"b for read, "0"b for write */
dcl  must_wait bit (1) aligned;			/* on if must wait for I/O to complete */
dcl  set_wired bit (1) aligned;			/* on if wired bit is to be set */
dcl  wired bit (1) aligned;				/* value of wired bit, if to be set */
dcl  uent bit (1) aligned;				/* on if must check uid before looking around */
dcl  have_list bit (1) aligned;			/* on if we were passed a list of pages */

dcl  page_no fixed bin;				/* current page number */
dcl  wptwp ptr;					/* pointer to current PTW */

dcl  list (0:255) fixed bin;				/* copy of list of pages */

dcl  1 wptw aligned like ptw based (wptwp);		/* working PTW */

dcl  pmut$lock_ptl entry (fixed bin (71), ptr);
dcl  pmut$unlock_ptl entry (fixed bin (71), ptr);
dcl  page$pread entry (ptr, fixed bin, fixed bin (35));
dcl  page$pwrite entry (ptr, fixed bin);
dcl  page$pwait entry (fixed bin (35));

dcl  sst$astsize fixed bin external static;
dcl  sst$pts (0 : 3) fixed bin external static;
dcl  sst$wired fixed bin external static;

dcl (addrel, binary, min, rel) builtin;

/*  */

pc_wired$wire_wait: entry (a_astep, first_page, no_pages);	/* entry to get pages into core and wire down */

	io = "1"b;
	do_io = "1"b;
	must_wait = "1"b;
	set_wired = "1"b;
	wired = "1"b;
	uent = "0"b;
	have_list = "0"b;
	go to join;

pc_wired$wire: entry (a_astep, first_page, no_pages);	/* entry to wire pages */

	do_io = "0"b;
	must_wait = "0"b;
	set_wired = "1"b;
	wired = "1"b;
	uent = "0"b;
	have_list = "0"b;
	go to join;


pc_wired$read: entry (a_astep, first_page, no_pages);	/* entry to read pages */

	io = "1"b;
	do_io = "1"b;
	must_wait = "0"b;
	set_wired = "0"b;
	uent = "0"b;
	have_list = "0"b;
	go to join;


pc_wired$unwire: entry (a_astep, first_page, no_pages);	/* entry to turn off wired bit */

	io = "0"b;
	must_wait = "0"b;
	set_wired = "1"b;
	wired = "0"b;
	uent = "0"b;
	have_list = "0"b;
	go to join;


pc_wired$write_wait: entry (a_astep, first_page, no_pages); /* entry to issue write and wait for I/O */

	io = "0"b;
	do_io = "1"b;
	must_wait = "1"b;
	set_wired = "0"b;
	uent = "0"b;
	have_list = "0"b;
	go to join;


pc_wired$write: entry (a_astep, first_page, no_pages);	/* entry to issue a write */

	io = "0"b;
	do_io = "1"b;
	must_wait = "0"b;
	set_wired = "0"b;
	uent = "0"b;
	have_list = "0"b;
	go to join;


pc_wired$write_wait_uid: entry (a_astep, first_page, no_pages, a_uid); /* For cleanup */

	io = "0"b;
	do_io = "1"b;
	must_wait = "1"b;
	set_wired = "0"b;
	uent = "1"b;
	uid = a_uid;
	have_list = "0"b;
	go to join;

pc_wired$write_wait_uid_list: entry (a_astep, a_listp, first_page, no_pages, a_uid);
			
          io = "0"b;
	do_io = "1"b;
	must_wait = "1"b;
	set_wired = "0"b;
	uent = "1"b;
	uid = a_uid;
	have_list = "1"b;
	goto join;

pc_wired$unwire_write_wait: entry (a_astep, first_page, no_pages);
		        
          io = "0"b;
	do_io = "1"b;
	must_wait = "1"b;
	set_wired = "1"b;
	wired = "0"b;
	uent = "0"b;
	have_list = "0"b;



join:	astep = a_astep;				/* Copy args. */
	np = no_pages;
	max_page = sst$pts (binary (astep ->  aste.ptsi, 3)) - 1;	/* Highest valid page number */
	fp = first_page;

	if have_list then do;
	     list = a_list;
	     lp = fp + np - 1;
	end;
	else do;
	     if np = -1 then lp = binary (astep -> aste.csl, 9) - 1;
	     else lp = fp + np - 1;
	end;

	call pmut$lock_ptl (oldmask, ptwp);		/* lock and mask */

	ptp = addrel (astep, sst$astsize);		/* get a pointer to the page table */
	rptp = binary (rel (ptp), 18); 		/* get offset for pwait calls */


	if set_wired then do i = fp to lp;		/* Unwire/wire all needed pages. */
	     if have_list then page_no = list (i);
	     else page_no = i;
	     if page_no <= max_page then do;
		wptwp = addr (ptp -> ptwa (page_no));
		if wired ^= wptw.wired		/* if changing wired bit */
		     then if wired
		          then sst$wired = sst$wired + 1; /* change total */
		     else sst$wired = sst$wired - 1;
		wptw.wired = wired;			/* Wire/unwire as needed. */
	     end;
	end;

loop:	k, j, waitev = -1;				/* Set out of service indicator. */
	if uent then				/* Racing with cleanup, but we are in same racket */
	     if uid ^= astep -> aste.uid then go to nomore;

	do i = lp to fp by -1;			/* Loop backwards to optimize disk spiral */
	     if have_list then page_no = list (i);
	     else page_no = i;
	     if page_no <= max_page then do;
		wptwp = addr (ptp -> ptwa (page_no));
		if wptw.os then k = page_no + rptp;		/* If out of service remember to wait. */
		else if do_io then do;
		     if ^wptw.valid then do;		/* Try to read in a page. */
			if io then call page$pread (astep, page_no, waitev); /* try to read the page */
			if waitev > 0 then j = waitev;/* use new wait event */
		     end;
		     else do;			/* page is in core, probably want to write */
			if ^io then if (wptw.phm | wptw.phm1) then
			     call page$pwrite (astep, page_no); /* issue the write request */
			if wptw.os then j = page_no + rptp;
		     end;
		end;
	     end;
	end;

	if k ^= -1 then do;
	     j = k;
	     go to wait1;
	end;

	if must_wait & j ^= -1 then do;		/* See if we must wait */
wait1:	     call page$pwait (j);			/* wait for event */
	     go to loop;
	end;

nomore:	call pmut$unlock_ptl (oldmask, ptwp);		/* unlock and unmask */
	return;

%page;	%include aste;
%page;
%INCLUDE "ptw.macro";

     end pc_wired;




		    post_purge.alm                  11/11/89  1105.1r w 11/11/89  0803.8       66447



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" HISTORY COMMENTS:
"  1) change(85-10-28,Fawcett), approve(86-04-03,MCR7277),
"     audit(86-04-03,Farley), install(86-04-07,MR12.0-1036):
"      Fix a looping problem that caused the system to hang
"                                                      END HISTORY COMMENTS


" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	post_purge -- This entry contains the code to post purge a process.
"
"	Last Modified (Date and Reason)
"	4/8/74 by S.H.Webber to change decision tree and add scheduling trace
"	03/18/81, W. Olin Sibert, for ADP conversion
"	06/21/82, E. N. Kittlitz, to move core map.
"         83-12-03 BIM to sys_trace.incl.alm
"
"	This program was originally part of pre_page but has since been renamed
"	as we no longer do anything about pre_paging.
"
" " " " " " " " " " " " " " " " " " " " " " " " "

	name	post_purge
	segdef	post_purge

	include	pxss_page_stack
	include	add_type
	include	page_info
	include	sst
	include	sys_trace
	include	aste
	include	sdw
	include	ptw
	include	cmp
	include	apte

" 

"	The following is the decision tree used
"	at post-purge time.
"
"	The current algorithm is as follows:
"
"	post_purge		never
"	move			if per-process and in core
"	used bit off		never
"	working set		if used in quantum by some process
"
"
	bool	working_set,000010	" How to interpret the bits
	bool	used_bit_off,000004
	bool	post_purge_bit,000002
	bool	moved_bit,000001

	equ	ptw.pre_paged,ptw.er " Special use for this bit here

code_tree:
	oct	020042104200
	oct	020042104200
	oct	020042104200
	oct	020042104200
	oct	020042104200
	oct	062146314620
	oct	020042104200
	oct	062146314620

post_purge:
	push
	tsx6	page_fault$init_savex initialize x7 save stack
	lda	post_purge_entry,dl set entry switch
	sta	entry_sw
	tsx7	page_fault$lock_ptl lock the page table lock

	read_clock		meter post-purge time
	staq	pre_time		save start time in stack

	fld	0,dl		initialize counters
	staq	pre_temp
	staq	pre_temp+2
	staq	pre_temp+4

"
"	The post purge code starts searching the post purge trace list from "trace_index"
"	to "trace_size" -- watching out for possible wrap-around.
"
	eppap	pds$trace 	get pointer to trace data
	ldx0	ap|trace.index_word	get starting index
post_loop:
	cmpx0	ap|trace.next_free_word	are we done?
	tze	done_post 	yes, finish up
	increment sst|sst.post_list_size count number of pages in core at purge
	sxl0	pre_temp+1	save current index
	lda	ap|trace.data+1,0	get page number from entry
	cana	=o770000,du	this better be a page fault list entry
	tnz	next_entry	it isn't, skip it
	sta	temp		save it for a second
	ldx3	ap|trace.data,0	get current AST entry pointer
	eax2	aste_size,3	fabricate page table pointer
	adlx2	temp		add in word number to get ptwp
	eppbp	sst|0,2		get a pointer to the PTW
	lda	ptw.pre_paged,dl	check if we've already looked at this ptw
	cana	ptw|0		..
	tze	looked		we haven't, continue
	increment sst|sst.thrashing	count thrashing
	tra	next_entry	and skip this one
looked:
	orsa	ptw|0		turn on pre_paged bit (already looked)
	lda	ptw|0		refetch the ptw
"
"	Now get decision index
"
	ldq	0,dl		The object of this game is to make Q1, Q2,
	cana	ptw.phu1,dl	and Q3 contain PHU, PHM, and PHU1, resp.
	tze	*+2		We accomplish this by inspecting each PTW bit
	orq	=o040000,du	and setting the appropriate bit in Q.
	cana	ptw.phm+ptw.phm1,dl
	tze	*+2
	orq	=o100000,du
	cana	ptw.phu,dl
	tze	*+2
	orq	=o200000,du

	cana	add_type.core,dl	check if core address
	tze	not_in_core	if not skip cme stuff
"
"	It's in core, get CMEP
"
	orq	=o400000,du	turn on the in core bit for decision
	arl	3-1		compute core map entry pointer
	eax4	sst|sst.cmp,*au
	increment sst|sst.post_in_core meter
	lda	page_fault$cme_devadd,*4 extract device ID from core map entry
not_in_core:
	cana	add_type.pd,dl	is this on pd?
	tnz	pp.yes_pd
	eaa	0
	tra	*+2
pp.yes_pd:
	lda	1,dl
	lrl	1
	lda	ast|aste.per_process_word,3	get aste word
	cana	aste.per_process,du 	is it p/p?
	tnz	pp.yes_pp
	eaa	0
	tra	*+2
pp.yes_pp:
	lda	1,dl
	lrl	1		shift in mlsw bit to complete index
	qrl	30		right justify the decision index
	increment sst|sst.tree_count,ql meter the decision
	stq	pre_temp+5	save index in stack

	lls	33		split the index into wordno and shift value
	qrl	15
	lrl	3
	qrl	15
"
"	QU now contains the word offset
"	QL contains the shift index
"
	lda	code_tree,qu	get code word in a
	arl	code_shift,ql*	shift to lower a
	ana	=o17,dl		leave only decision bits
	sta	pre_temp

	cana	working_set,dl	should we count this page in working set ?
	tze	*+2		no, skip count instruction
	aos	pre_temp+4	yes, count it

	cana	post_purge_bit,dl	should we purge the page?
	tze	check_move	no, go check if we should move the core map entry

	lxl0	ptw|0		see if page is out of service
	canx0	ptw.os,du 	..
	tnz	check_move	yes, skip write request
	canx0	ptw.valid,du	see if page not in core
	tze	check_move	yes, skip write request
	increment sst|sst.post_purgings
	tsx7	page_fault$write_page see if must write the page and do so if must
	eppap	pds$trace get pointer to array again
check_move:
	lda	pre_temp		see if we should move in list
	cana	moved_bit,dl
	tze	check_used	no, look at next entry
	tsx7	page_fault$thread_to_lru yes, move in core map
check_used:
	lda	pre_temp		retrieve coded value again
	cana	used_bit_off,dl
	tze	next_entry
	lcq	ptw.phu+ptw.phu1+1,dl	turn OFF used bit in PTW
	ansq	ptw|0

next_entry:
	lxl0	pre_temp+1	get next free slot in pre-page list
	eax0	2,0		increment to next entry
	cmpx0	ap|trace.last_available_word
	tmi	*+2
	eax0	0		yes, reset index
	tra	post_loop 	loop back for another entry

done_post:
"
"	Now reset all pre-paged flags
"
	lca	ptw.pre_paged+1,dl	get mask to turn off flag
	ldx0	ap|trace.index_word	start at beginning of list again
turn_off: cmpx0	ap|trace.next_free_word are we done?
	tze	mtime		yes, abort loop
	ldq	ap|trace.data+1,0	get word 1 for page number
	canq	=o770000,du	see if page fault entry
	tnz	next_turn_off	no, skip the entry
	stq	temp		save for subtract
	ldx3	ap|trace.data,0	get astep
	eax2	aste_size,3	fabricate ptp
	adlx2	temp		..
	ansa	sst|0,2		turn off pre-paged bit
next_turn_off:
	eax0	2,0		go to next entry
	cmpx0	ap|trace.last_available_word wrap-around?
	tmi	*+2		no,
	eax0	0		yes
	tra	turn_off		loop back

mtime:
	ldx0	ap|trace.next_free_word reset pointer to start of active list
	stx0	ap|trace.index_word

	eppap	pds$apt_ptr,*	set pre-page-size in APT entry
	ldq	pre_temp+4
	mpy	tc_data$working_set_factor
	qrl	18
	adq	tc_data$working_set_addend
	stq	ap|apte.ws_size
	asq	sst|sst.pre_page_size

	read_clock		meter time
	sbaq	pre_time
	adaq	sst|sst.post_purge_time
	staq	sst|sst.post_purge_time
	increment sst|sst.post_purge_calls

	tsx7	page_fault$trace_scheduling
	tsx7	page_fault$unlock_ptl
	return

code_shift:
	arg	32
	arg	28
	arg	24
	arg	20
	arg	16
	arg	12
	arg	8
	arg	4


	end




		    quotaw.pl1                      11/11/89  1105.1r   11/11/89  0804.7       70623



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */



quotaw: proc;

/* RE Mullen, v2pl1, oct 1973 */
/* Modified by Bernard Greenberg, 04/28/75 for New Storage System */
/* Modified by Bernard Greenberg, 02/18/77 for online quota reconstructor */
/* Modified by David Spector, 02/18/79 for 18 bit quota */
/* Modified by Keith Loepere, 12/13/84 to count dirs pages against its own dir quota. */

dcl (a_astep, a_astep2) ptr,
     a_t fixed bin (1),
    (csw, a_csw) fixed bin (2);
dcl  a_q fixed bin (18);
dcl  a_code fixed bin (17);
dcl  a_uc fixed bin (18);

dcl (addr, fixed, ptr) builtin;

dcl (astpp, astep1, astep2, ptwp) ptr,
    (uchange, tchange, qchange, quota) fixed bin (34),
     code fixed bin,
    (tsw, ct, nt, qt) fixed bin (1),
    (a_osu, osu, a_odu, odu, a_nsu, nsu, a_ndu, ndu) fixed bin (34),
     new_quota fixed bin (34),
     pcsw bit (1),
     a_qt bit (1) aligned,
     pds$processid ext bit (36),
     pds$quota_inhib ext fixed bin (17),
     oldmask fixed bin (71),
     privileged_mode_ut$lock_ptl ext entry (fixed bin (71), ptr),
     privileged_mode_ut$unlock_ptl ext entry (fixed bin (71), ptr);

	% include aste;

declare sst$rqover fixed bin (35) external static;
declare sst_seg$ external static;
declare sstp pointer;

/* entry to changed used records for an active account */

cu:	entry (a_astep, a_uc, a_qt, a_csw, a_code);
	csw = a_csw;				/* check switch: = 1 check only, = 0 check and make change */
						/* 2 = make change and dont complain */
	pcsw = "0"b;
	go to cum;
cu_for_pc: entry (a_astep, a_uc, a_qt);
						/* Special side-door for pc$truncate */
	pcsw = "1"b;
	csw = 0;					/* Do it */
cum:


	astep = a_astep;				/* ptr to AST entry of dir in which file resides */
	uchange = a_uc;				/* change to used */
	qt = fixed (a_qt, 1);			/* quota type, 0 = segs, 1 = dirs */
	code = 0;

	sstp = addr (sst_seg$);
	if ^pcsw then call privileged_mode_ut$lock_ptl (oldmask, ptwp); /* lock, switch_stack and mask */

cu1:	astpp = astep;
cu2:	if csw ^= 1
	then astpp -> aste.used (qt) = astpp -> aste.used (qt) + uchange;
	if csw = 2 then do;
	     if uchange > 0 & astpp -> aste.used (qt) > aste.quota (qt)
	     then code = sst$rqover;
	     go to finish;
	end;
	if astpp -> aste.tqsw (qt) = "0"b then do;
	     astpp = ptr (sstp, astpp -> aste.par_astep); /* loop over parents */
	     go to cu2;
	end;
	if pds$quota_inhib ^= 0
	then go to finish;				/* Patch for reloader, etc */
	if code ^= 0
	then go to finish;				/* second time thru the loop */
	if uchange <= 0 then go to finish;		/* don't check quota when decreasing */
	if csw = 1
	then tchange = uchange;			/* change has not been added in */
	else tchange = 0;				/* change has been added in */
	if astpp -> aste.quota (qt) < (astpp -> aste.used (qt) + tchange)
	then do;					/* change is not ok */
	     uchange = -uchange;			/* prepare to remove change */
	     code = sst$rqover;
	     if csw = 0
	     then go to cu1;			/* loop thru and undo change if any */
	end;

finish:	if pcsw then return;
	call privileged_mode_ut$unlock_ptl (oldmask, ptwp); /* unlock, switch back and unmask */
	a_code = code;
	return;


/* * * * * * * * * * * * * * * * * * * * * * * * * */

/* entry to set a quota and change the terminal state of an active AST */

sq:	entry (a_astep, a_q, a_qt, a_t);


	astep = a_astep;				/* ptr to ast entry to set quota on */
	quota = a_q;				/* new quota */
	qt = fixed (a_qt, 1);
	tsw = a_t;				/* = 1 if quota is being changed from non-term to term */
						/* = 0 if quota is being changed from term to non-term */
	sstp = addr (sst_seg$);

	call privileged_mode_ut$lock_ptl (oldmask, ptwp); /* mask, switch stack and lock */

	if tsw = 1
	then uchange = astep -> aste.used (qt);		/* used records that will no longer be carried up */
	else uchange = -astep -> aste.used (qt);	/* used records will be added sup acct */
	astpp = astep;
sq1:	astpp = ptr (sstp, astpp -> aste.par_astep);	/* loop to find terminal account */
	astpp -> aste.used (qt) = astpp -> aste.used (qt) - uchange; /* subtract used from parents */
	if astpp -> aste.tqsw (qt) = "0"b
	then go to sq1;

	astep -> aste.quota (qt) = quota;
	astep -> aste.tqsw (qt) = (tsw = 1);

	call privileged_mode_ut$unlock_ptl (oldmask, ptwp); /* unlock, switch back and unmask */

	return;

/* * * * * * * * * * * * * * * * * * */

/* entry to move quota from parent ast (ast1) to inferior ast (ast2) */

mq:	entry (a_astep, a_astep2, a_q, a_qt, a_code);


	astep1 = a_astep;				/* ptr to parent ast entry */
	astep2 = a_astep2;				/* ptr to target ast entry */
	qchange = a_q;				/* amount of quota to be moved from ast1 to ast2 */
	qt = fixed (a_qt, 1);
	code = 0;
	sstp = addr (sst_seg$);

	call privileged_mode_ut$lock_ptl (oldmask, ptwp); /* mask, switch stack and lock */

	ct = fixed (astep2 -> aste.tqsw (qt), 1);	/* ct = 1 if ast2 currently has term quota */
	if astep2 -> aste.quota (qt) + qchange ^= 0
	then do;					/* ast2 will have terminal quota */
	     nt = 1;
	     if astep2 -> aste.quota (qt) + qchange < astep2 -> aste.used (qt)
	     then go to error;
						/* new quota must cover used */
	     if ct = 0
	     then uchange = -astep2 -> aste.used (qt);	/* subtract used from current terminal quota */
	     else uchange = 0;			/* no change from terminal state */
	end;
	else do;					/* ast2 will not have terminal quota */
	     nt = 0;
	     if ct = 1
	     then uchange = astep2 -> aste.used (qt);	/* add used into new terminal quota */
	     else uchange = 0;
	end;
	new_quota = astep1 -> aste.quota (qt) - qchange;
	if new_quota <= 0 then go to error;		/* Insure no zero terminal quota */
	if new_quota < astep1 -> aste.used (qt)+uchange then go to error;
	astep1 -> aste.quota (qt) = new_quota;		/* Change quota */
	astep1 -> aste.used (qt) = astep1 -> aste.used (qt)+uchange; /* change parent used */
	astep2 -> aste.quota (qt) = astep2 -> aste.quota (qt)+qchange; /* change target quota */
	astep2 -> aste.tqsw (qt) = (nt = 1);

mqfinish:
	call privileged_mode_ut$unlock_ptl (oldmask, ptwp); /* unlock, switch back and unmask */

	a_code = code;
	return;

error:	code = sst$rqover;
	go to mqfinish;

/* * * * * * * * * * * * * * * * * * * * * * * * * */

rvq:	entry (a_astep, a_osu, a_odu, a_nsu, a_ndu);

/*	Entry to determine active inferior and current active quota totals for revalidator */

	astep = a_astep;

	sstp = addr (sst_seg$);

	call privileged_mode_ut$lock_ptl (oldmask, ptwp); /* mask, lock */

	osu = aste.used (0);
	odu = aste.used (1);			/* Copy current, incorrect totals */
	nsu = 0;					/* Zero totals to be accumulated */
	ndu = fixed (aste.records, 9);		/* dirs records count towards itself */

	do astep = ptr (sstp, aste.infp) repeat ptr (sstp, aste.infl) while (astep ^= sstp);
						/* Map over inferiors */
	     if aste.dirsw then do;
		if ^aste.tqsw (0) then nsu = nsu + aste.used (0); /* Add inferior dir totals */
		if ^aste.tqsw (1) then ndu = ndu + aste.used (1);	/* records of dir already counted in quota used */
	     end;
	     else nsu = nsu + fixed (aste.records, 9);	/* Account to right place */
	end;

	call privileged_mode_ut$unlock_ptl (oldmask, ptwp);

	a_osu = osu;				/* Copy out answers */
	a_odu = odu;
	a_nsu = nsu;
	a_ndu = ndu;

	return;
     end quotaw;




		    stock.alm                       11/11/89  1105.1r w 11/11/89  0804.7      133290



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	stock
"
"	Record Stock Management Routines
"
"	Entries:
"	
"	  withdraw - withdraws a single record address from a stock
"
"	  withdraw_range - withdraws a single record address from
"	            a stock within a range of addresses
"
"	  withdraw_range_ext - same as withdraw_range, available
"	  	  outside ALM Page Control
"
"	  deposit - deposits a single record address into a stock
"
"	  reset_os - resets all out-of-service bits in a stock
"
"	  flush_os - removes all out-of-service entries from a stock.
"		  Called when there is an unrecoverable I/O error
"		  on a Volume Map page.
"
"	  check_low_threshold - checks for stock below threshold and 
"		  selects a volume map page to replenish it
"
"	  recover - adjust stock counts (called during ESD)
"
"	Written January 1982 by J. Bongiovanni
"	Modified July 1982, J. Bongiovanni, for withdraw_range_ext
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	stock
	segdef	deposit
	segdef	withdraw
	segdef	withdraw_range
	segdef	withdraw_range_ext
	segdef	reset_os
	segdef	flush_os
	segdef	check_low_threshold
	segdef	recover

	bool	live_address,377777
	bool	os_address,400000

reset_os_upper_bits:
	oct	377777777777		" reset_os
	oct	000000777777		" flush_os
reset_os_lower_bits:
	oct	777777377777		" reset_os
	oct	777777000000		" flush_os

high_record_address:
	oct	377777000000

"
	include	aste
"
	include	page_info
"
	include	ptw
"
	include	pvte
"
	include	pxss_page_stack
"

	include	stack_frame

	include	stock_seg
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	withdraw - routine to withdraw a single record address
"
"	tsx7	stock$withdraw
"	<return if no addresses in stock>
"	<return if succeed with withdrawal>
"
"	On entry
"	    ab -> stock_seg$meters
"	    bb -> stock of interest
"
"	On exit
"	    Areg contains address
"
"
"	withdraw_range - routine to withdraw a single record address
"	     within a range specified
"
"	Same as above, except on entry
"	    AU = high address (rec < high address)
"	    AL = low address  (rec >= low address)
"
"	withdraw_range_ext - withdraw range accessible outside
"	    ALM Page control
"
"	    call page$withdraw_range (pvtep, low_address, high_address, record_address)
"
"	No locks are required by this routine.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

withdraw_range_ext:
	push
	
	stz	ap|8,*			" Clear returned address
	tsx6	page_fault$init_savex

	eppbp	ap|2,*			" bp -> ptr -> PVTE
	eppbp	bp|0,*			" bp -> PVTE
	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> stock
	epbpab	bb|0			" ab -> base of stock_seg
	eppab	ab|stock_seg.meters		" ab -> meters

	lda	ap|6,*			" AL = high address
	als	18			" AU = high address
	ora	ap|4,*			" AU = high address, AL = low address
	tsx7	withdraw_range		" Try for an address
	tra	withdraw_range_ext_ret	" None

	eppap	sp|stack_frame.arg_ptr,*	" Restore argument list ptr
	sta	ap|8,*			" Record address

withdraw_range_ext_ret:
	return



withdraw:
	eax6	0			" withdraw
	stz	stock_temp_1		" low address
	lda	high_record_address
	sta	stock_temp_2		" high address
	increment	ab|rsmeters.n_withdraw_attempt
	tra	withdraw_join

withdraw_range:
	eax6	1			" withdraw_range
	increment	ab|rsmeters.n_withdraw_range
	sta	stock_temp_2		" high address
	ana	-1,dl
	als	18			" low address
	sta	stock_temp_1

withdraw_join:
	lxl0	bb|record_stock.stock_offset
	eppap	bb|0,x0			" ap -> stock

	eax6	0,x6			" withdraw_range?
	tnz	withdraw_set_begin		" Yes

	lxl0	bb|record_stock.search_index	" Roving pointer
	eax0	-1,x0
	tra	withdraw_common

withdraw_retry:
	eax6	0,x6			" withdraw_range?
	tze	withdraw_set_begin		" No
	eax6	1,x6			" Bump bail-out counter
	cmpx6	2,du			" Gone through once
	tpl	0,x7			" Yes -- once is enough

withdraw_set_begin:
	ldx0	-1,du			" Start at the beginning

withdraw_common:
	ldx1	bb|record_stock.n_free_in_stock " Any free?
	tze	0,x7			" No -- give up

withdraw_loop:
	increment	ab|rsmeters.withdraw_stock_steps " Meter
	eax0	1,x0			" Next 2 entires
	cmpx0	bb|record_stock.n_words_in_stock " Any left
	tpl	withdraw_retry		" No - retry from the top

withdraw_loop_retry:
	ldq	ap|0,x0			" Next 2 entries
	tze	withdraw_loop		" Both empty
	lda	ap|0,x0			" Protected by Q, stacq
	eax1	0,au			" Check upper address
	tmoz	withdraw_check_lower	" Empty or out-of-service
	cmpx1	stock_temp_1		" >= low address
	tmi	withdraw_check_lower	" No
	cmpx1	stock_temp_2		" < high address
	tpl	withdraw_check_lower	" No
	ana	-1,dl			" Mark upper as empty
	tra	withdraw_try		" And attempt lockless withdraw
withdraw_check_lower:
	eax1	0,ql			" Look at lower entry
	tmoz	withdraw_loop		" Empty or out-of-service
	cmpx1	stock_temp_1		" >= low address
	tmi	withdraw_loop		" No
	cmpx1	stock_temp_2		" < high address
	tpl	withdraw_loop		" No
	ana	-1,du			" Mark lower as empty

withdraw_try:				
	stacq	ap|0,x0			" Attempt lockless withdraw
	tze	withdraw_succeed		" Made it
	increment	ab|rsmeters.withdraw_stock_losses
	tra	withdraw_loop_retry		" Meter and retry

withdraw_succeed:
	eax6	0,x6			" withdraw_range ?
	tnz	withdraw_leave_pointer	" Yes -- don't adjust pointer
	sxl0	bb|record_stock.search_index	" Roving pointer
withdraw_leave_pointer:
	ldq	bb|record_stock.n_free_in_stock " Adjust count lockless
	lda	bb|record_stock.n_free_in_stock
	sba	1,du			" One fewer free record
	stacq	bb|record_stock.n_free_in_stock
	tnz	withdraw_leave_pointer	" Lost race, retry

	eaa	0,x1			" Record address
	arl	18			" Areg = record address
	increment	ab|rsmeters.n_pages_withdraw_stock
	tra	1,x7

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	deposit - routine to deposit a single address
"
"	tsx7	stock$deposit
"	<return if fail>
"	<return if succeed>
"
"	On entry,
"	    Areg = address to deposit
"	    ab -> stock_seg$meters
"	    bb -> stock of interest
"
"	No locks are required by this routine.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

deposit:
	cana	live_address,dl		" Valid record address
	tze	page_error$deposit_zero_address " No - bad lossage

	sta	stock_temp_1		" Record address
	als	18			" Into upper
	sta	stock_temp_2

	increment	ab|rsmeters.n_deposit_attempt

	lxl0	bb|record_stock.stock_offset
	eppap	bb|0,x0			  " ap -> stock
	lxl0	bb|record_stock.search_index	" Roving pointer
	eax0	1,x0			" Adjust for initial decrement
	tra	deposit_common

deposit_retry:
	ldx0	bb|record_stock.n_words_in_stock " Start at the top

deposit_common:
	lxl1	bb|record_stock.n_os_in_stock	" Check whether any free slots
	adlx1	bb|record_stock.n_free_in_stock "   exist
	cmpx1	bb|record_stock.n_in_stock	
	tpl	0,x7			" None free

deposit_loop:
	increment	ab|rsmeters.deposit_stock_steps
	eax0	-1,x0			" 2 entries/word
	tmi	deposit_retry		" None left

deposit_loop_retry:
	ldq	ap|0,x0			" Next 2 entries
	lda	ap|0,x0			" Protected by Qreg, stacq
	tze	deposit_try_upper		" Both entries free

	eax1	0,au			" Check upper entry
	tnz	deposit_check_lower		" Not free
deposit_try_upper:
	ora	stock_temp_2		" Dep address into upper
	tra	deposit_try

deposit_check_lower:
	eax1	0,al			" Check lower entry
	tnz	deposit_loop		" Not empty
	ora	stock_temp_1		" Dep address into lower

deposit_try:
	stacq	ap|0,x0			" Lockless deposit
	tze	deposit_succeed		" We win
	increment ab|rsmeters.deposit_stock_losses
	tra	deposit_loop_retry		" Lose - meter and retry

deposit_succeed:
	lda	1,dl			" Set up to increment number OS
	ldx1	stock_temp_2		" Address just deposited
	tmi	deposit_os		" An out-of-service address
	lda	1,du			" Set up to increment number free
	sxl0	bb|record_stock.search_index	" Roving pointer

deposit_os:
	sta	stock_temp_2		" Save for lost race
deposit_os_retry:
	ldq	bb|record_stock.n_free_in_stock
	lda	stock_temp_2		" Restore
	adla	bb|record_stock.n_free_in_stock
	stacq	bb|record_stock.n_free_in_stock  " Lockless update
	tnz	deposit_os_retry		" Lost - retry

	increment	ab|rsmeters.n_pages_deposit_stock
	tra	1,x7

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	reset_os - routine to reset all out-of-service bits
"
"	tsx7	stock$reset_os
"
"	On entry,
"	    ab -> stock_seg$meters
"	    bb -> stock of interest
"
"	No locks are required by this routine
"
"	flush_os - routine to remove all out-of-service entries
"	   from a stock.
"
"	On entry, same as above
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

reset_os:
	eax6	0			" reset_os
	tra	reset_os_common

flush_os:
	eax6	1			" flush_os

reset_os_common:
	increment	ab|rsmeters.reset_os_calls

	lxl0	bb|record_stock.stock_offset
	eppap	bb|0,x0			 " ap -> stock
	ldx0	bb|record_stock.n_words_in_stock

reset_os_loop:
	eax0	-1,x0			" One less
	tmi	0,x7			" Done - exit

reset_os_loop_retry:
	ldq	ap|0,x0			" Next 2 addresses
	ldx1	0,du			" Count of OS reset
	lda	ap|0,x0			" Protected by Qreg, stacq
	tze	reset_os_loop		" None in use
	tpl	reset_os_check_lower	" High address not OS
	ldx1	1,du			" Count of OS reset
	ana	reset_os_upper_bits,x6	" Reset/Flush
reset_os_check_lower:
	cana	=o400000,dl		" Low address OS
	tze	reset_os_try		" No
	adlx1	1,du			" Bump counter
	ana	reset_os_lower_bits,x6	" Reset/Flush

reset_os_try:
	eax1	0,x1			" Any to reset
	tze	reset_os_loop		" No
	stacq	ap|0,x0			" Lockless
	tze	reset_os_update_count	" Won
	increment	ab|rsmeters.reset_os_losses	" Lost - meter and retry
	tra	reset_os_loop_retry

reset_os_update_count:
	stz	stock_temp_1
	stz	stock_temp_2
	sxl1	stock_temp_2		" To decrement count of OS
	eax6	0,x6			" Flush call
	tnz	reset_os_update_retry	" Yes - don't increment free count
	stx1	stock_temp_1		" To increment count of free
reset_os_update_retry:
	ldq	bb|record_stock.n_free_in_stock " Change count of OS, free
	lda	bb|record_stock.n_free_in_stock " Lockless
	adla	stock_temp_1
	sbla	stock_temp_2
	stacq	bb|record_stock.n_free_in_stock
	tnz	reset_os_update_retry	" lost race
	tra	reset_os_loop


"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	check_low_threshold - routine to check whether a stock is below
"		threshold, and (if so) to select a volmap page to
"		replenish it
"
"	tsx7	stock$check_low_threshold
"	<return if within threshold or no page selected>
"	<return if below threshold and page selected>
"
"	On entry,
"	    ab -> stock_seg$meters
"	    bb -> stock of interest
"	    bp -> pvte
"
"	On exit,
"	    if page selected, page number is in Areg
"
"	This routine requires the Global Page Table Lock, the per-volume
"	volume map lock (with async state idle)
"
"	A volmap page is selected as follows:
"
"	1. If a page is in memory, it is selected
"	2. If no page is in memory, the lowest page which can replenish
"	   the stock to target is selected
"	3. Otherwise, the page with the largest number of free records
"	   is selected
"	
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

check_low_threshold:
	lxl0	bb|record_stock.n_os_in_stock
	adlx0	bb|record_stock.n_free_in_stock
	cmpx0	bb|record_stock.low_threshold	" Below threshold
	tpl	0,x7			" No

	aos	ab|rsmeters.low_thresh_detected " Meter
	stx0	stock_temp_1		" Free + OS
	ldx0	bb|record_stock.target	" Target for Free + OS
	sbx0	stock_temp_1		" Shortfall
	stx0	stock_temp_1

	lprpap	bp|pvte.volmap_astep	" ap -> ASTE for volmap_seg
	eppap	ap|aste_size		" ap -> Page Table for volmap_seg
	lxl0	bb|record_stock.n_volmap_pages
	stz	stock_temp_2
	sxl0	stock_temp_2
	lda	0,dl			" Page number
	ldx1	-1,du			" First page which can replenish
	ldx2	-1,du			" Page with largest number free

check_low_mem:
	ldx0	bb|record_stock.n_free,al	" Number free records this page
	tze	check_low_next		" None - skip
	ldq	ap|0,al			" Qreg = PTW
	canq	ptw.valid,dl		" In memory
	tnz	1,x7			" Yes - exit with page number in Areg
	cmpx0	stock_temp_1		" Enough to replenish to target
	tmi	check_low_not_enough	" No
	eax1	0,x1			" Found such yet
	tpl	check_low_next		" Yes - use first such
	eax1	0,al			" No - this is such
	tra	check_low_next

check_low_not_enough:
	eax2	0,x2			" Largest number records so far
	tpl	check_low_highest		" One such found
	eax2	0,al			" This is it
	tra	check_low_next
check_low_highest:
	cmpx0	bb|record_stock.n_free,x2	" Is this one higher
	tmoz	check_low_next		" No
	eax2	0,al			" Yes

check_low_next:
	ada	1,dl			" Bump page number
	cmpa	stock_temp_2		" Done all pages
	tmi	check_low_mem		" No
	eaa	0,x1			" First which can replenish
	tpl	check_low_got		" One was found
	eaa	0,x2			" Largest number records
	tpl	check_low_got		" Somebody found
	aos	ab|rsmeters.low_thresh_fails	" Nobody found - meter
	tra	0,x7			" And exit

check_low_got:
	arl	18			" Page number in AL
	tra	1,x7
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	recover - routine to recompute counts in the record stock for ESD.
"		The system may have crashed due to a stock inconsistency,
"		and this may allow ESD to succeed. Of course, major
"		trashage to the stock cannot be bypassed.
"
"	On entry,
"	    ab -> stock_seg$meters
"	    bb -> stock of interest
"	    bp -> pvte
"
"	This routine should be called only during ESD
"
"	
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

recover:
	stz	stock_temp_1		" Number free
	stz	stock_temp_2		" Number out-of-service

	sprpbp	bb|record_stock.pvtep	" Restore pointer to PVTE
	lxl0	bb|record_stock.stock_offset
	eppap	bb|0,x0			" ap -> stock array

	ldx0	bb|record_stock.n_words_in_stock

recover_loop:
	eax0	-1,x0			" Index into stock array
	tmi	recover_done		" None left
	lda	ap|0,x0			" Next 2 entries
	tze	recover_loop		" Both empty
	tpl	recover_check_upper		" Upper not out-of-service
	aos	stock_temp_2		" Upper out-of-service
	tra	recover_check_lower
recover_check_upper:
	cana	live_address,du		" Upper empty
	tze	recover_check_lower		" Yes
	aos	stock_temp_1		" No
recover_check_lower:
	cana	os_address,dl		" Lower out-of-service
	tze	recover_check_lower_inuse	" No
	aos	stock_temp_2		" Yes
	tra	recover_loop

recover_check_lower_inuse:
	cana	live_address,dl		" Lower empty
	tze	recover_loop		" Yes
	aos	stock_temp_1		" No
	tra	recover_loop

recover_done:
	lda	stock_temp_1		" Number free
	als	18			" Align
	ora	stock_temp_2		" Merge in number out-of-service
	sta	bb|record_stock.n_free_in_stock " And set count into stock

	tra	0,x7

	end




		    thread.alm                      11/11/89  1105.1r w 11/11/89  0803.8       56106



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

"
"	THREAD
"
"	This procedure is used by the supervisor to manage threaded lists of
"	objects. Every such object should have a declaration which begins:
"
"	dcl 1 thing aligned based,
"	    2 forward_ptr bit (18) unaligned,
"	    2 back_ptr bit (18) unaligned,
"
"	The first word of each object must contain two eighteen bit pointers
"	(segment-base relative) to the next and previous objects in the list.
"
"	This procedure also maintains a pointer into the list. It must be an
"	18 bit relative offset, and appear in the upper halfword of a word.
"	The caller of thread may therefore declare it aligned.
"
"	No checking is done to insure that these requirements for alignment
"	and location are being followed.
"
"	10/03/73, R. E. Mullen, in v2pl1
"	04/17/75, A. Bensoussan, to zero the fp and bp when threading out.
"	03/26/81, W. Olin Sibert, to re-code in ALM
"

	name	thread
	segdef	lin		" Thread in, to linear list
	segdef	cin		" Thread in, to circular list
	segdef	out		" Thread out, of either type

	equ	thread,1		" PR1 points to thread word throughout
	equ	object,2		" PR2 points to object
	equ	base,3		" PR3 points to base of segment containing
				" the object (though perhaps not the thread)

	equ	.object,0 	" X0 is offset of object
	equ	.next,1		" X1 is offset of next object
	equ	.prev,2		" X2 is offset of previous object
	equ	.thread,3 	" X3 is the value of the thread word (on entry)


" 
"
"	THREAD$LIN -- Thread object into linear list
"
"	dcl  thread$lin entry (pointer, bit (18) unaligned);
"
"	call thread$lin (astep, sst.ausedp (0));
"


lin:	epp	object,ap|2,*
	epp	thread,ap|4,*	" Pointer to thread word
	epp	object,object|0,*	" Pointer to object

	eax	.object,object|0	" Offset of object
	ldx	.thread,thread|0	" Current value of thread (next_object)

				" Is list empty now?
	tnz	lin.non_empty	" No -- go thread into nonempty list

" It was empty, so the thing we're threading in will be the only thing in the list.

	stx	.object,thread|0	"   object.bp = null, object.fp = null
	stz	object|0		"   thread = object_ptr

	short_return		"


" Since it was nonempty, we thread this object in at the end of the list. The
" thread ends up pointing at the object we are threading in, and the object
" it used to point to is adjusted to point (back) at the new one.

lin.non_empty:
	epbp	base,object|0	" Get a pointer to the base of the segment
	stz	object|0		     " object.bp = null
	stx	.thread,object|0	     " object.fp = thread (prev_object_ptr)
	stx	.object,thread|0	     " thread = object_ptr
	sxl	.object,base|0,.thread   " prev_object.bp = object_ptr

	short_return


" 
"
"	THREAD$CIN -- Thread object into circular list
"
"	dcl  thread$cin entry (pointer, bit (18) unaligned);
"
"	call thread$cin (astep, sst.ausedp (0));
"


cin:	epp	object,ap|2,*	" (pointer argument)
	epp	thread,ap|4,*	" Pointer to thread word
	epp	object,object|0,*	" Pointer to object

	eax	.object,object|0	" Offset of object
	ldx	.thread,thread|0	" Current value of thread (next_object)

				" Is list empty now?
	tnz	cin.non_empty	" No -- go thread into nonempty list

				" It was empty, so all threads point to it
	stx	.object,object|0	"   object.fp = object_ptr
	sxl	.object,object|0	"   object.bp = object_ptr
	stx	.object,thread|0	"   thread = object_ptr

	short_return


" Since it was not empty, we will now thread in the new object between the "previous"
" and "next" objects -- the thread is always considered to point to the "next"
" object. After our object has been threaded in, it will be at the very end of
" the list.

cin.non_empty:
	epbp	base,object|0	" Get a pointer to the base of the segment
	stx	.thread,object|0	     " object.fp = thread (next_object_ptr)
	lxl	.prev,base|0,.thread     " prev_object_ptr
	sxl	.prev,object|0	     " object.bp = prev_object.bp
	stx	.object,base|0,.prev     " prev_object.fp = object_ptr
	sxl	.object,base|0,.thread   " next_object.bp = object_ptr

	short_return


" 
"
"	THREAD$OUT -- Thread object out of the list
"
"	dcl  thread$out entry (pointer, bit (18) unaligned);
"
"	call thread$out (astep, sst.ausedp (0));
"


out:	epp	object,ap|2,*	" (pointer argument)
	epp	thread,ap|4,*	" Pointer to thread word
	epp	object,object|0,*	" Pointer to object

	eax	.object,object|0	" Offset of object
	ldx	.thread,thread|0	" Current value of thread (next_object)

	epbp	base,object|0	" Get a pointer to the base of the segment
	ldx	.next,object|0	" and pointers to the previous and next object
	lxl	.prev,object|0
	tze	out.no_previous	" if prev pointer is non-null,
				" rethread forward pointer for prev object
	stx	.next,base|0,.prev	"   prev_object.fp = next_object_ptr
				" (fall through)
out.no_previous:
	canx	.next,=o777777,du	" if next pointer is non-null, rethread
	tze	out.no_next	" backward pointer for next object

	sxl	.prev,base|0,.next	"   next_object.bp = prev_object_ptr
				" (fall through)
out.no_next:
	cmpx	.object,thread|0	" If thread pointed to object we are threading
	tnz	out.not_this_one	" out, adjust it to point to the next, instead

	stx	.next,thread|0	"   thread = next_object_ptr

out.not_this_one:			" If this object points to itself, we are
	cmpx	.object,object|0	" removing the only object on a circular
	tze	out.last_in_list	" list, so we should zero the thread word

	stz	object|0		" Finally, zero the threads in the object
				" being removed.
	short_return


out.last_in_list:			" Can't use an STZ here, because there may
	ldx	.thread,0,du	" be something else in the lower halfword
	stx	.thread,thread|0	"   thread = null
	stz	object|0		" Finally, zero the threads in the object
				" being removed.
	short_return

	end




		    volmap.alm                      11/11/89  1105.1r w 11/11/89  0804.6      100701



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************


" HISTORY COMMENTS:
"  1) change(87-02-18,Lippard), approve(87-03-16,MCR7640),
"     audit(87-06-17,Farley), install(87-07-17,MR12.1-1043):
"     Added volmap word validity check (fix by Swenson).
"                                                      END HISTORY COMMENTS


" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	volmap
"
"	Routines for manipulating the volume map, migrating record addresses
"	between the volume map and the stock. 
"
"	Entries:
"		withdraw_from_volmap - volmap into stock
"		deposit_to_volmap    - stock into volmap
"		drain_stock	 - empty stock into volmap
"		reset_pvte	 - reset lock, state for ESD
"
"	These routines are controlled by threshold values in the stock.
"
"	This version has some quick kludges for the old volmap format.
"	It will be changed for the new format.
"
"	Written February 1982 by J. Bongiovanni
"	Modified December 1982 by J. Bongiovanni to reset ovfl before fno
"	
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	volmap

	segdef	withdraw_from_volmap
	segdef	deposit_to_volmap
	segdef	drain_stock
	segdef	reset_pvte

	equ	word_to_record.ls,5
	equ	volmap_page_high,1024
	equ	volmap_first_page,64
	bool	high_record_address,377777
	bool	os_address,400000
	bool	volmap_word_mask,400000000007

	link	volmap_abs_seg_link,volmap_abs_seg$

"
	include	page_info
"
	include	pvte
"
	include	pxss_page_stack
"
	include	stock_seg
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	withdraw_from_volmap
"
"	tsx7	volmap$withdraw_from_volmap
"
"	On entry,
"	    bp -> pvte
"	    ab -> stock_seg$meters
"	    bb -> record_stock
"	    Areg contains page number in volmap_seg
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

withdraw_from_volmap:
	increment	ab|rsmeters.n_v_withdraw_attempts

	ldx0	bb|record_stock.volmap_page,al " Number free records this page
	tze	0,x7			" None to be had

	ldx0	bb|record_stock.target	" Is volume shut down
	tze	0,x7			" Yes

	tsx6	page_fault$savex
	sta	volmap_temp
	tsx6	setup_abs_seg		" To read volmap_seg

	lda	volmap_temp		" Page number in volmap_seg
	als	page_power		" Offset within segment
	eppap	volmap_abs_seg$		" ap -> base of volmap_seg
	eppap	ap|0,al			" ap -> page of volmap
	spriap	volmap_save_ptr

withdraw_loop:
	lca	1,dl			" Bail-out counter
	sta	volmap_temp+1

	lxl0	volmap_temp		" Page number
	ldx1	bb|record_stock.volmap_page,x0 " Records left this page
	tmoz	withdraw_returns		" None
	ldx1	bb|record_stock.old_volmap_page,x0 " Roving pointer
	eppap	volmap_save_ptr,*

	eax0	0,x0			" Page number
	tnz	withdraw_inner_loop		" Not first page
	cmpx1	volmap_first_page,du	" Kludge for old volmap
	tpl	withdraw_inner_loop		" Above bound
	ldx1	volmap_first_page,du	" Set to minimum value

withdraw_inner_loop:
	increment	ab|rsmeters.withdraw_volmap_steps
	lda	ap|0,x1			" Any free this word
	tnz	withdraw_got		" Yes
	eax1	1,x1			" Bump to next word
	cmpx1	volmap_page_high,du		" End of page
	tmi	withdraw_inner_loop		" No
	aos	volmap_temp+1		" Bump bail-out counter
	tpnz	page_error$volmap_inconsistent
	ldx1	0,du			" Start at the beginning
	eax0	0,x0			" Unless its page 0
	tnz	withdraw_inner_loop
	ldx1	volmap_first_page,du	
	tra	withdraw_inner_loop

withdraw_got:
	cana	=v36/volmap_word_mask	" Check validity of word
	tnz	page_error$invalid_volmap_word " mbz bits are not
	ldi	0,dl			" Let fno work as expected, not as advertised
	lde	0,du			" Find first bit on
	fno
	stz	volmap_temp_1
	ste	volmap_temp_1
	lda	volmap_temp_1
	neg
	arl	17-7			" Record within word
	sta	volmap_temp_1

	arl	18			" AL = Record within word
	eaq	0,x1			" QU = Word offset within volmap page
	lrl	18			" QU = Record within word
					" QL = Word offset within  volmap page

	eaa	0,x1			" Word offset within volmap page
	als	word_to_record.ls		" Record offset of begin of word
	asa	volmap_temp_1		" Record offset within volmap page
	lxl2	bb|record_stock.volmap_page,x0 " Base address of page
	adlx2	volmap_temp_1		" True address
	eaa	0,x2
	arl	18
	ora	os_address,dl		" Out-of-service until write completes
	stx1	bb|record_stock.old_volmap_page,x0 " Roving pointer
	stq	volmap_temp_1		" QU = Record within word
					" QL = Word offset within volmap page
	tsx7	stock$deposit
	tra	withdraw_returns		" Stock is full

	eppap	volmap_save_ptr,*		" ap -> page of volmap
	lda	volmap_temp_1		" AU = Record within word
					" AL = Word offset within volmap page
	ldq	=o200000,du		" Reset bit in volmap
	qrl	0,au
	ersq	ap|0,al

	increment	ab|rsmeters.n_pages_withdraw_async
	ldx0	bp|pvte.nleft
	sblx0	1,du
	tmi	page_error$volmap_inconsistent
	stx0	bp|pvte.nleft
	lxl1	volmap_temp
	ldx0	bb|record_stock.volmap_page,x1
	sblx0	1,du
	tmi	page_error$volmap_inconsistent
	stx0	bb|record_stock.volmap_page,x1
	lxl0	bb|record_stock.n_os_in_stock
	adlx0	bb|record_stock.n_free_in_stock
	cmpx0	bb|record_stock.target	" Are we there yet
	tmi	withdraw_loop		" No

withdraw_returns:
	tsx6	restore_abs_seg
	tsx6	page_fault$unsavex
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	deposit_to_volmap
"
"	tsx7	volmap$deposit_to_volmap
"
"	On entry,
"	    bp -> pvte
"	    ab -> stock_seg$meters
"	    bb -> record_stock
"	    Areg contains page number in volmap_seg
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

deposit_to_volmap:
	increment	ab|rsmeters.n_v_deposit_attempts

	tsx6	page_fault$savex

	eax0	0,al			" Page number
	stx0	volmap_temp
	tsx6	setup_abs_seg

	lda	volmap_temp		" Page number
	ana	-1,du			"   in AU
	arl	18-page_power		" Offset in AL
	eppap	volmap_abs_seg$
	eppap	ap|0,al			" ap -> base of page

	ldx0	volmap_temp		" Page number
	lda	bb|record_stock.volmap_page,x0
	ana	-1,dl			" AL = base address
	sta	volmap_temp+1

	ldx1	high_record_address,du	" Set for last page
	lxl2	bb|record_stock.n_volmap_pages " Number of pages in volmap
	sblx2	1,du			" Index of last page
	cmpx2	volmap_temp		" Is this page the last
	tze	deposit_last		" Yes
	lxl1	bb|record_stock.volmap_page+1,x0 " Pick up base address of next
deposit_last:
	stx1	volmap_temp+1		" Low address in lower/high address is upper
	spriap	volmap_save_ptr

deposit_loop:
	lxl0	bb|record_stock.n_os_in_stock
	adlx0	bb|record_stock.n_free_in_stock
	cmpx0	bb|record_stock.target	" Are we done
	tmoz	deposit_returns		" Yes
	
	lda	volmap_temp+1		" Range of addresses this page
	tsx7	stock$withdraw_range	" Get an address within the rage
	tra	deposit_returns		" None left

	eppap	volmap_save_ptr,*
	ldx0	volmap_temp		" Page number
	lxl1	bb|record_stock.volmap_page,x0 " Base address of page
	stz	volmap_temp_1
	stx1	volmap_temp_1
	sta	devadd			" Save address for page_error
	als	18			" Address in AU
	sbla	volmap_temp_1		" Relative address within page
	tmi	page_error$bad_volmap_address	" Bogus
	arl	18			" Address in AL
	ldq	0,dl
	lrl	word_to_record.ls		" Word offset in AL
	qrl	18-word_to_record.ls	" Bit within word in QU
	eax1	0,qu			" Bit within word in x1
	ldq	=o200000,du		" Mask to set bit
	qrl	0,x1			" Shift to the right bit
	cmpa	1024,dl			" Within a page
	tpl	page_error$bad_volmap_address	" No
	canq	ap|0,al			" Already marked as free
	tze	deposit_valid		" No
	szn	pvt$shutdown_state		" In ESD?
	tnz	deposit_loop		" Yes, this can happen normally
	ldx1	1,du
	asx1	bp|pvte.vol_trouble_count	" Add to inconsistency count
	tsx7	page_error$deposit_inuse_address " And tell the world
	tra	deposit_loop

deposit_valid:
	orsq	ap|0,al			" Mark address as free
	increment	ab|rsmeters.n_pages_deposit_volmap
	ldx0	1,du
	asx0	bp|pvte.nleft
	ldx1	volmap_temp
	asx0	bb|record_stock.volmap_page,x1
	tra	deposit_loop

deposit_returns:
	tsx6	restore_abs_seg
	tsx6	page_fault$unsavex
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	drain_stock
"
"	call page$drain_record_stock (pvtep)
"
"	Where
"	    pvtep -> PVTE
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

drain_stock:
	push
	tsx6	page_fault$init_savex

	eppbp	ap|2,*			" bp -> ptr -> PVTE
	eppbp	bp|0,*			" bp -> PVTE
	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> record stock
	epbpab	bb|0			" ab -> base of stock_seg
	eppab	ab|stock_seg.meters		" ab -> meters

drain_retry:
	tsx7	lock_volmap$lock_wired_wait	" Get lock, async idle
	tra	drain_waits		" Failed, wait event in APTE

	ldx0	0,du			" Succeeded
	stx0	bb|record_stock.low_threshold	" Clear thresholds
	sxl0	bb|record_stock.high_threshold " And deposit will do the rest
	stx0	bb|record_stock.target
	lda	bb|record_stock.n_volmap_pages
	ana	-1,dl			" Areg = number of pages in volmap
	sta	volmap_temp_2

drain_loop:
	lda	volmap_temp_2
	sba	1,dl			" Next page to drain
	sta	volmap_temp_2
	tmi	drain_returns		" Done
	tsx7	deposit_to_volmap		" Clear this page
	tra	drain_loop

drain_returns:
	tsx7	lock_volmap$unlock_wired	" Unlock
	return

drain_waits:
	call	pxss$wait			" APTE already has event
	tra	drain_retry

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	reset_pvte
"
"	call page$reset_pvte (pvtep)
"
"	Where
"	     pvtep -> PVTE
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

reset_pvte:
	push

	eppbp	ap|2,*			" bp -> ptr -> PVTE
	eppbp	bp|0,*			" bp -> PVTE

	stz	bp|pvte.volmap_lock		" Clear lock
	stz	bp|pvte.volmap_async_state	" Set state to Idle, page to 0
	stz	bp|pvte.vtoc_map_lock	" Clear lock

	lda	bp|pvte.volmap_stock_ptr	" See whether stock exists
	tze	reset_pvte_returns		" No
	ana	=o007777,du		" Check for null pointer
	cmpa	=o007777,du
	tze	reset_pvte_returns		" Is null - no stock

	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> record stock
	epbpab	bb|0			" ab -> base of stock seg
	eppap	ap|stock_seg.meters		" ab -> meter area

	tsx7	stock$recover		" Attempt to fix any damage
	tsx7	stock$reset_os		" Reset any out-of-service
					" Safe since ESD doesn't withdraw

reset_pvte_returns:
	return

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Internal procedure to set up and restore the volmap_abs_seg
"
"	tsx6	setup_abs_seg
"		bp -> PVTE
"
"	tsx6	restore_abs_seg
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

setup_abs_seg:

	ldx0	lp|volmap_abs_seg_link	" Segment number in x0
	adlx0	lp|volmap_abs_seg_link	" Offset in dseg
	ldaq	dseg$0,x0			" Previous SDW
	staq	volmap_save_sdw		" Save into stack
	ldaq	bp|pvte.volmap_seg_sdw	" Volmap seg of interest
	staq	dseg$0,x0			" Set the SDW
	cams				" And the SDWAM
	camp				" And the PTWAM
	tra	0,x6

restore_abs_seg:

	ldx0	lp|volmap_abs_seg_link	" Segment number in x0
	adlx0	lp|volmap_abs_seg_link	" Offset in dseg
	ldaq	volmap_save_sdw		" Previous value
	staq	dseg$0,x0			" Set the SDW
	cams				" And the SDWAM
	tra	0,x6

	end




		    volmap_page.alm                 11/11/89  1105.1r w 11/11/89  0804.2      133362



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Bull Inc., 1987                *
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	volmap_page
"
"	Routines to act on single pages of a volume map
"
"	Entries:
"
"	    grap_volmap_page_unwired  - wires and reads in a volmap page
"                                         deposits excess stock to volume map
"
"	    write_volmap_page_unwired - writes and unwires a volmap page
"
"	    start_async_read          - starts an asynchronous read cycle to
"				  the volume map
"
"	    start_async_write         - starts an asynchronous write cycle to
"				  the volume map
"
"	    post_io                   - posts a volume map i/o
"
"	    poll_io                   - polls for complete volume map i/os
"
"	Written February 1982 by J. Bongiovanni
"	Modified September 1982, J. Bongiovanni, not to do read on OS page
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	volmap_page
	segdef	grab_volmap_page_unwired
	segdef	write_volmap_page_unwired
	segdef	start_async_read
	segdef	start_async_write
	segdef	post_io
	segdef	poll_io

	link	volmap_abs_seg_link,volmap_abs_seg$

	even
pc_wired_arg_list:
	vfd	18/6,18/4,36/0
pread_arg_list:
	vfd	18/6,18/4,36/0
pwrite_arg_list:
	vfd	18/4,18/4,36/0
notify_arg_list:
	vfd	18/2,18/4,36/0

one:	dec	1
"
	include	aste
"
	include	page_info
"
	include	ptw
"
	include	pvte
"
	include	pxss_page_stack
"
	include	stock_seg
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	grab_volmap_page_unwired
"
"	call page$grab_volmap_page_unwired (pvtep, page_no, page_ptr)
"
"	    pvtep = pointer to PVTE (Input)
"	    page_no = page number in volume map (Input)
"	    page_ptr = pointer to page in volume map (Output)
"
"	The volume map must be locked to this process with asynchronous
"	state of idle. volmap_abs_seg must be set to refer to this volume
"	map.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

grab_volmap_page_unwired:
	push
	tsx6	page_fault$init_savex	" Recursive use of x7
	
	eppbp	ap|2,*			" bp -> ptr -> PVTE
	eppbp	bp|0,*			" bp -> PVTE
	tsx6	check_valid_call		" Check lock, async state, abs seg

	lprpab	bp|pvte.volmap_astep	" ab -> ASTE for volume map
	spriab	arg+8
	eppab	arg+8
	spriab	arg+2
	eppab	ap|4,*			" Page number
	spriab	arg+4
	eppab	one			" Number of pages
	spriab	arg+6
	ldaq	pc_wired_arg_list
	staq	arg
	call	pc_wired$wire_wait(arg)

	lda	ap|4,*			" Page number
	als	page_power		" Offset in segment
	eppab	volmap_abs_seg$0,al		" ab -> page
	spriab	ap|6,*			" Return to caller

	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> record stock
	lxl0	bb|record_stock.high_threshold " Above high threshold
	cmpx0	bb|record_stock.n_free_in_stock
	tpl	grab_volmap_returns		" No
	epbpab	bb|0			" ab -> base of stock_seg
	eppab	ab|stock_seg.meters		" ab -> meters
	aos	ab|rsmeters.high_thresh_detected
	lda	ap|4,*			" Page number
	tsx7	volmap$deposit_to_volmap	" Deposit excess for this page

grab_volmap_returns:
	return
"

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	write_volmap_page_unwired
"
"	call page$write_volmap_page_unwired (pvtep, page_no)
"
"	    pvtep = pointer to PVTE (Input)
"	    page_no = page number in volume map (Input)
"
"	The volume map must be locked to this process with asynchronous
"	state of idle. volmap_abs_seg must be set to refer to this volume
"	map.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

write_volmap_page_unwired:
	push
	eppbp	ap|2,*			" bp -> ptr -> PVTE
	eppbp	bp|0,*			" bp -> PVTE
	tsx6	check_valid_call		" Check lock, async state, abs-seg

	lprpab	bp|pvte.volmap_astep	" ab -> ASTE for volmap_seg
	spriab	arg+8
	eppab	arg+8
	spriab	arg+2
	eppab	ap|4,*			" Page number
	spriab	arg+4
	eppab	one			" One page
	spriab	arg+6
	ldaq	pc_wired_arg_list
	staq	arg
	call	pc_wired$unwire_write_wait(arg)

	return
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	start_async_read
"
"	tsx7	volmap_page$start_async_read
"	<return if page already in memory>
"	<return if page not in memory>
"
"	On entry,
"	    bp -> PVTE
"	    ab -> stock_seg.meters
"	    Areg = page number in volume map
"	    Volume map locked to this process, async state idle
"	    PTL locked to this process
"
"	On exit,
"	    Async state is Read
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

start_async_read:
	tsx6	page_fault$savex		" Recursive use of x7

	increment	ab|rsmeters.async_read_calls

	sta	volmap_page_temp		" Page number

	lda	pds$processid		" Check PTL
	cmpa	sst$ptl
	tnz	page_error$ptl_not_locked
	cmpa	bp|pvte.volmap_lock		" Volmap lock held
	tnz	page_error$volmap_page_invalid_call " No
	ldx0	bp|pvte.volmap_async_state	" State idle
	cmpx0	VOLMAP_ASYNC_IDLE,du
	tnz	page_error$volmap_page_invalid_call  " No
	lda	volmap_page_temp		" Page number
	ana	-1,dl			" Just to be sure
	ora	VOLMAP_ASYNC_READ,du	" New async state
	sta	bp|pvte.volmap_async_state

	lda	volmap_page_temp		" Page number
	lprpap	bp|pvte.volmap_astep	" ap -> ASTE for volmap_seg
	ldq	ap|aste_size,al		" PTW
	canq	ptw.valid,dl		" In memory
	tnz	page_fault$unsavex		" Yes
	canq	ptw.os,dl			" I/O already in progress?
	tnz	page_fault$unsavex_1	" Yes - should never happen

	increment	ab|rsmeters.async_page_reads
	increment	sst$volmap_seg_page_faults
	spriap	arg+8
	eppap	arg+8
	spriap	arg+2
	eppap	volmap_page_temp		" Page number
	spriap	arg+4
	eppap	arg+10
	spriap	arg+6
	ldaq	pread_arg_list
	staq	arg
	call	page_fault$pread(arg)

	tsx7	post_io_pvtep		" Check for screw case
	tra	page_fault$unsavex_1

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	start_async_write
"
"	tsx7	page_fault$start_async_write
"	<return if page is in memory>
"	<return if page in not in memory>
"
"	On entry,
"	    bp -> PVTE
"	    Volmap async state is Read
"	    PTL locked to process
"
"	On exit,
"	    Volmap async state is Write
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

start_async_write:
	tsx6	page_fault$savex		" Recursive use of x7

	sta	volmap_page_temp		" Page number
	lda	pds$processid
	cmpa	sst$ptl			" PTL held
	tnz	page_error$ptl_not_locked

	ldx0	bp|pvte.volmap_async_state
	cmpx0	VOLMAP_ASYNC_READ,du
	tnz	page_error$wrong_async_state

	lda	volmap_page_temp		" Page number
	ana	-1,dl			" Just in case
	ora	VOLMAP_ASYNC_WRITE,du	" New state
	sta	bp|pvte.volmap_async_state

	lda	volmap_page_temp		" Page number
	lprpap	bp|pvte.volmap_astep	" ap -> ASTE for volmap_seg
	ldq	ap|aste_size,al		" PTW
	canq	ptw.valid,dl		" In memory
	tze	page_fault$unsavex_1	" No
	canq	ptw.os,dl			" Someone else writing it?
	tnz	page_fault$unsavex		" Yes - skip call to pwrite

	spriap	arg+6			" astep
	eppap	arg+6
	spriap	arg+2
	eppap	volmap_page_temp		" Page number
	spriap	arg+4
	ldaq	pwrite_arg_list
	staq	arg
	call	page_fault$pwrite(arg)

	tsx7	post_io_pvtep		" Check for screw case
	tra	page_fault$unsavex
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	post_io
"
"	tsx7	volmap_page$post_io
"
"	On entry,
"	    Areg = pvtx
"	    PTL locked to process
"
"	post_io_pvtep - internal procedure, registers already setup
"
"	tsx7	post_io_pvtep
"
"	On entry,
"	    bp -> PVTE
"	    PTL locked to process
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "


post_io:
	eax0	0			" Pvtx given
	sta	volmap_page_temp		" pvtx
	tra	post_io_join

post_io_pvtep:
	eax0	1			" Pvtep given

post_io_join:
	read_clock
	staq	post_io_start_time		" For metering

	eax0	0,x0			" Pvtep given
	tpnz	post_got_pvtep		" Yes
	ldq	pvte_size,dl		" Compute pvtep
	mpy	volmap_page_temp		" Offset in array, one too high
	eppbp	pvt$array
	eppbp	bp|-pvte_size,ql		" bp -> PVTE

post_got_pvtep:
	lda	bp|pvte.volmap_async_state	" State in AU, page in AL
	tra	post_io_state,au		" Do what's appropriate
post_io_state:
	tra	0,x7			" Idle
	tra	post_read			" Read
	tra	post_write		" Write

post_read:
	tsx6	page_fault$savex		" Recursive use of x7
	lprpap	bp|pvte.volmap_astep	" ap -> ASTE for volmap_seg
	ldq	ap|aste_size,al		" PTW
	canq	ptw.er,dl			" I/O Error
	tze	post_read_noerr		" No
	tsx7	io_error			" Yes - handle
	tra	post_idle			" Set state to idle and notify
post_read_noerr:
	canq	ptw.valid,dl		" In memory
	tnz	post_read_in_mem		" Yes
	canq	ptw.os,dl			" Did we lose the I/O?
	tnz	page_fault$unsavex		" No
	tra	post_idle			" Yes, reset it..time will cure all

post_read_in_mem:
	ana	-1,dl			" Page number
	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> record stock
	epbpab	bb|0			" ab -> base of stock seg
	eppab	ab|stock_seg.meters		" ab -> meters
	tsx7	volmap$withdraw_from_volmap	" Replenish stock

	lda	bp|pvte.volmap_async_page
	ana	-1,dl			" Page number
	tsx7	start_async_write		" Write it back
	tra	post_meter_exit
	tra	page_error$volmap_page_async_error " Not in memory

post_write:
	tsx6	page_fault$savex		" Recursive use of x7
	lprpap	bp|pvte.volmap_astep	" ap -> ASTE for volmap_seg
	ldq	ap|aste_size,al		" PTW
	canq	ptw.er,dl			" I/O Error
	tze	post_write_noerr		" No
	tsx7	io_error			" Yes - handle
	tra	post_idle			" Set state to idle and notify
post_write_noerr:
	canq	ptw.os,dl			" I/O finished
	tnz	page_fault$unsavex		" No

	canq	ptw.valid,dl		" In memory
	tze	post_write_not_mod		" No, write surely done
	canq	ptw.phm+ptw.phm1,dl		" Page modified
	tze	post_write_not_mod		" No, write completed

"	Write posted but page modified. Possibly a race, although the locking
"	strategy should prevent this. More likely, the disk went offline.
"	In this case, the write is notified with no error by page control.
"	We recover by re-issuing the I/O

	spriap	arg+6			" ptr -> ASTE of volmap_seg
	eppap	arg+6
	spriap	arg+2
	lda	bp|pvte.volmap_async_page	" Page number in lower
	ana	-1,dl
	sta	arg+8
	eppap	arg+8
	spriap	arg+4
	ldaq	pwrite_arg_list
	staq	arg
	call	page_fault$pwrite(arg)
	tra	page_fault$unsavex

post_write_not_mod:
	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> record stock
	epbpab	bb|0			" ab -> base of stock seg
	eppab	ab|stock_seg.meters		" ab -> meters
	tsx7	stock$reset_os		" Write finished, OK to use addresses

post_idle:
	stz	bp|pvte.volmap_async_state	" Idle
post_write_retry:
	ldq	bp|pvte.volmap_idle_notify_word " Anybody waiting for idle
	lda	bp|pvte.volmap_idle_notify_word
	cana	pvte.volmap_idle_notify,dl
	tze	post_meter_exit		" No
	era	pvte.volmap_idle_notify,dl	" Reset notify switch
	stacq	bp|pvte.volmap_idle_notify_word
	tnz	post_write_retry		" Lost race

	eaa	bp|0			" AU = PVTE offset
	arl	18			" AL = PVTE offset
	ora	pvt$volmap_idle_wait_constant " Areg = wait event
	sta	arg+4
	eppap	arg+4
	spriap	arg+2
	ldaq	notify_arg_list
	staq	arg
	call 	pxss$notify(arg)

post_meter_exit:
	increment	ab|rsmeters.async_post_io_calls
	read_clock
	sbaq	post_io_start_time
	adaq	ab|rsmeters.async_post_io_time
	staq	ab|rsmeters.async_post_io_time
	tra	page_fault$unsavex

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	poll_io
"
"	call page$poll_volmap_io
"
"	Called with no locks held, wired and masked
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

poll_io:
	push
	tsx6	page_fault$init_savex		" Recursive use of x7

	tsx7	page_fault$lock_ptl			" Spin lock

	ldq	pvte_size,dl			" Index to last PVTE
	mpy	pvt$n_entries
	eax0	0,ql				" x0 -> one beyond end
	stx0	volmap_page_temp_1			" Save
poll_loop:
	ldx0	volmap_page_temp_1			" Restore PVTE index
	eax0	-pvte_size,x0			" One fewer to go
	tmi	poll_done
	stx0	volmap_page_temp_1			" Save index to PVTE
	eppbp	pvt$array
	eppbp	bp|0,x0				" bp -> PVTE
	ldq	bp|pvte.used_word
	canq	pvte.used,dl			" PVTE in use
	tze	poll_loop				" No - skip
	ldx1	bp|pvte.volmap_async_state		" Asynchronous activity state
	cmpx1	VOLMAP_ASYNC_IDLE,du		" Idle
	tze	poll_loop				" Yes - skip

	sxl1	volmap_page_temp_1			" Save async state
	tsx7	post_io_pvtep			" Try to post the I/O
	lxl1	volmap_page_temp_1			" Restore async state
	cmpx1	bp|pvte.volmap_async_state		" Did state change?
	tze	poll_loop				" No
	tsx7	page_error$poll_state_change		" Yes - report it
	tra	poll_loop

poll_done:
	eppbb	sst$				" Needed by unlock_ptl
	tsx7	page_fault$unlock_ptl
	return


"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	io_error - internal procedure to handle unrecoverable I/O error
"
"	tsx7	io_error
"
"	On entry,
"	  bp -> PVTE
"	  Areg = page number in volmap_seg
"
"	The strategy is to lose all free addresses on the page with the
"	I/O error. Any OS pages are flushed from the stock, and the
"	count of free addresses on that page is set to zero.
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

io_error:
	tsx6	page_fault$savex		" Recursive use of x7
	sta	volmap_page_temp
	lprpbb	bp|pvte.volmap_stock_ptr	" bb -> Record stock
	epbpab	bb|0			" ab -> base of stock_seg
	eppab	ab|stock_seg.meters		" ab -> stock_seg$meters

	tsx7	stock$flush_os		" Flush any out-of-service addresses
	
	lda	volmap_page_temp		" Page number
	ldx0	bp|pvte.nleft		" Total number records left
	sblx0	bb|record_stock.volmap_page,al " Minus number free this page
	tpl	io_error_nleft_ok		" If positive
	eax0	0
io_error_nleft_ok:
	stx0	bp|pvte.nleft		" Becomes new number left
	eax0	0
	stx0	bb|record_stock.volmap_page,al " Clear count of free this page
	ldx0	bp|pvte.vol_trouble_count	" Increment the trouble count
	adlx0	1,du
	stx0	bp|pvte.vol_trouble_count

	tsx7	page_error$volmap_io_error	" Tell the world
	tra	page_fault$unsavex		" And return

"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	check_valid_call - internal procedure to validate that
"	volume map is locked to this process, async state is idle,
"	and volmap_abs_seg is setup.
"
"	tsx6	check_valid_call
"
"	On entry,
"	    bp -> PVTE
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

check_valid_call:
	ldx0	lp|volmap_abs_seg_link	" Segment number of volmap_abs_seg
	adx0	lp|volmap_abs_seg_link	" Offset of SDW in DSEG
	ldaq	dseg$0,x0			" SDW
	cmpaq	bp|pvte.volmap_seg_sdw	" The right one
	tnz	page_error$volmap_page_invalid_call

	lda	pds$processid
	cmpa	bp|pvte.volmap_lock		" Volmap lock held
	tnz	page_error$volmap_page_invalid_call

	ldx0	bp|pvte.volmap_async_state	" State idle
	cmpx0	VOLMAP_ASYNC_IDLE,du
	tnz	page_error$volmap_page_invalid_call

	tra	0,x6




	end




		    volmap_util.pl1                 11/11/89  1105.1r w 11/11/89  0804.7       49590



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
volmap_util$free_address_for_scavenge:
     proc (Pvtx, Record_Address);

/*  Volume Map Utilities

    free_address_for_scavenge   - ensures that a record address is not free
			    by removing from stock and volume map

    Written July 1982 by J. Bongiovanni
    Modified November 1982, J. Bongiovanni, to check stock under volmap lock
*/

/*  Parameter  */

	dcl     Pvtx		 fixed bin;	/* PVTE index */
	dcl     Record_Address	 fixed bin (18);

/*  Automatic  */

	dcl     bit_no		 fixed bin;
	dcl     page_no		 fixed bin;
	dcl     p99		 pic "99";
	dcl     record_address	 fixed bin (18);
	dcl     volmap_locked	 bit (1) aligned;
	dcl     vpage_ptr		 ptr;
	dcl     word_no		 fixed bin;

/*  Static  */

	dcl     NULL_SDW		 fixed bin (71) int static options (constant) init (0);
	dcl     RECORDS_PER_WORD	 fixed bin int static options (constant) init (32);

/*  Based  */

	dcl     1 vpage		 aligned based (vpage_ptr),
		2 word		 (0:1023) aligned,
		  3 pad1		 bit (1) unaligned,
		  3 bits		 (0:31) bit (1) unaligned,
		  3 pad2		 bit (3) unaligned;

/*  External  */

	dcl     volmap_abs_seg$	 external;

/*  Entry  */

	dcl     condition_		 entry (char (*), entry);
	dcl     page$grab_volmap_page_unwired entry (ptr, fixed bin, ptr);
	dcl     page$lock_volmap	 entry (ptr);
	dcl     page$unlock_volmap	 entry (ptr);
	dcl     page$withdraw_range	 entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18));
	dcl     page$write_volmap_page_unwired entry (ptr, fixed bin);
	dcl     pmut$swap_sdw	 entry (ptr, ptr);
	dcl     syserr		 entry options (variable);
%page;
	record_address = Record_Address;

	page_no = -1;
	volmap_locked = "0"b;

	call SETUP_LOCK;

	call condition_ ("page_fault_error", PAGE_FAULT_ERROR);

	call FIND_VOLMAP_PAGE (record_address, page_no);

	call page$grab_volmap_page_unwired (pvtep, page_no - 1, vpage_ptr);

	call page$withdraw_range (pvtep, record_address, record_address + 1, (0));

	word_no = divide (record_address - record_stock.volmap_page (page_no).baseadd, RECORDS_PER_WORD, 17);
	bit_no = mod (record_address - record_stock.volmap_page (page_no).baseadd, RECORDS_PER_WORD);
	vpage.word (word_no).bits (bit_no) = "0"b;

	call page$write_volmap_page_unwired (pvtep, page_no);
	page_no = -1;

	call UNLOCK_RESET;

	return;
%page;
/*  Internal Procedure to setup pointers and lock the volume map  */

SETUP_LOCK:
     proc;

	pvtep = addr (addr (pvt$array) -> pvt_array (Pvtx));
	record_stockp = pvte.volmap_stock_ptr;

	call page$lock_volmap (pvtep);
	volmap_locked = "1"b;

	call pmut$swap_sdw (addr (volmap_abs_seg$), addr (pvte.volmap_seg_sdw));

     end SETUP_LOCK;



/*  Internal Procedure to reset and unlock  */

UNLOCK_RESET:
     proc;


	if page_no > 0
	then call page$write_volmap_page_unwired (pvtep, page_no - 1);
	page_no = -1;

	if volmap_locked
	then call page$unlock_volmap (pvtep);
	volmap_locked = "0"b;

	call pmut$swap_sdw (addr (volmap_abs_seg$), addr (NULL_SDW));

     end UNLOCK_RESET;
%page;
/* Internal Procedure to find the Volume Map page associated with a given
   address */

FIND_VOLMAP_PAGE:
     proc (Devadd, Page_no);

	dcl     Devadd		 fixed bin (18) parameter;
	dcl     Page_no		 fixed bin parameter;

	dcl     vpagex		 fixed bin;
	dcl     vpage_found		 bit (1);
	dcl     address		 fixed bin;


	vpage_found = "0"b;
	address = Devadd;

	if address < pvte.baseadd | address >= pvte.baseadd + pvte.totrec
	then call syserr (CRASH, "volmap_util: Address ^o out of paging region on ^a_^a.", address, pvte.devname,
		convert (p99, pvte.logical_area_number));

	do vpagex = record_stock.n_volmap_pages to 1 by -1 while (^vpage_found);
	     if address >= record_stock.volmap_page (vpagex).baseadd
	     then do;
		     vpage_found = "1"b;
		     Page_no = vpagex;
		end;
	end;

	if ^vpage_found
	then call syserr (CRASH, "volmap_util: Invalid address ^o on ^a_^a.", address, pvte.devname,
		convert (p99, pvte.logical_area_number));
	return;

     end FIND_VOLMAP_PAGE;
%page;
/*  Internal Procedure to clean up and continue signalling of
    page_fault_error
*/

PAGE_FAULT_ERROR:
     proc (Mcptr, Condition, Coptr, Infoptr, Continue) options (non_quick);

	dcl     Mcptr		 ptr;
	dcl     Condition		 char (*);
	dcl     Coptr		 ptr;
	dcl     Infoptr		 ptr;
	dcl     Continue		 bit (1) aligned;

	call UNLOCK_RESET;
	Continue = "1"b;

     end PAGE_FAULT_ERROR;
%page;
%include pvte;
%page;
%include stock_seg;
%page;
%include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   volmap_util: Address XXXXXX out of paging region on dskX_NN.

   S:     $crash

   T:	During a physical volume scavenge

   M:	The scavenger attempted to remove an invalid address from the
   volume map.

   A:     $recover

   Message:
   volmap_util: Invalid address XXXXXX on dskX_NN.

   S:     $crash

   T:	During a physical volume scavenge

   M:	In attempting to deposit address XXXXXX on device dskX_NN, an invalid
   volume map offset was computed. 

   A:	$recover


   END MESSAGE DOCUMENTATION */

     end volmap_util$free_address_for_scavenge;





		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
