



		    access_viol.pl1                 11/11/89  1101.2rew 11/11/89  0808.4       13770



/****^  ***********************************************************
        *                                                         *
        * 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.
                                                   END HISTORY COMMENTS */


access_viol$am_fault:	proc (mc_ptr);

/* modified by E. Stone April 1974 to convert to v2 pl1 */
/* modified by THVV 8/77 to remove obsolete entry $ring_alarm */

dcl  mc_ptr ptr;				/* pointer to machine conditions */

dcl syserr entry options (variable);

	call syserr(1, "access_viol: associative memory fault.");
	return;

/* BEGIN MESSAGE DOCUMENTATION

Message:
access_viol: associative memory fault.

S:	$crash

T:	$run

M:	The processor associative memory has detected a usage count error.

A:	Notify Field Engineering personnel.



END MESSAGE DOCUMENTATION */

end;




		    activate.pl1                    11/11/89  1101.2r w 11/11/89  0806.7      137889



/****^  ***********************************************************
        *                                                         *
        * 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-28,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-28,Coppola), install(86-07-17,MR12.0-1097):
     Add support for subvolumes.
                                                   END HISTORY COMMENTS */

/*
   astep = activate (branchp, code)

   FUNCTION -

   This procedure activates the segment whose branch is pointed  to  by  the  input
   argument  "branchp",  and it returns the aste pointer for that segment. In order
   to activate the segment this procedure activates  any  superior  directory  that
   happens  to  be inactive. If the operation is successful, the return occurs with
   the following state: astep ^= null, code = 0  and  AST  is  locked.  It  is  the
   responsability  of  the  caller to unlock the AST whenever it is appropriate. If
   the operation fails, the return occurs with the following state: astep  =  null,
   code ^= 0 and AST is unlocked.


   MODIFICATIONS -

   85-01-04 by Keith Loepere to set aste.multi_class.
   84-01-31 by BIM. SST reformat. Close window due to extra AST unlock for
   parent segfault that I missed the first time.
   05/30/83 by E. N. Kittlitz for search_ast$check
   10/26/82 by J. Bongiovanni for synchronized segments, filemap checksum
   7/10/82 by J. Bongiovanni to read entire VTOCE
   3/7/82 by J. Bongiovanni for new PVTE
   12/25/81 by Benson I. Margulies to not depend on the directory read
   lock as protection against activations.
   5/31/81 by J. Bongiovanni to validate fields in VTOCE
   03/21/81, W. Olin Sibert, for ADP PTWs and SDWs, and get_ptrs_$given_sdw
   02/81 by E. N. Kittlitz for activate_long entry
   04/77 by THVV for damaged sw and messages
   8/76 by D. Vinograd to add entry for activating without parent being active.
   This entry, backup_activate, is used only by the volume dumper.
   09/13/76 by Greenberg to meter activations and fixe demount window error reporting
   03/25/76 by R. Bratt to fix gtpd bug and add explicit user deactive capability
   04/08/75 by Andre Bensoussan. This procedure has been completely rewritten for
   the new storage system.
*/
/* format: style4 */
%page;

activate: proc (branchp, code) returns (ptr);


dcl  branchp ptr,					/* Input  - branch pointer */
     a_vtocep ptr,
     a_pvtx fixed bin,
     a_vtocx fixed bin,
     a_activated_sw bit (1) aligned,
     code fixed bin (35);				/* Output - error code */


dcl  ast_unlocked bit (1) aligned;
dcl  (par_astep, par_sdwp) ptr;
dcl  (pvtx, vtocx, esw) fixed bin (17);
dcl  (uid, pvid, temp) bit (36) aligned;
dcl  old_par_ehs bit (1);
dcl  already_active_by_backup bit (1);
dcl  dirsw bit (1);
dcl  multi_class bit (1);

dcl  long_sw bit (1) aligned;
dcl  1 local_vtoce like vtoce aligned;
dcl  1 par_aste like aste aligned based (par_astep);
dcl  checksum bit (36) aligned;
dcl  p99 pic "99";

dcl  normal fixed bin internal static init (1);
dcl  backup fixed bin internal static init (2);

dcl  sst$checksum_filemap fixed bin (35) external static;
dcl  sst$damaged_ct fixed bin (35) external static;
dcl  sst$dm_enabled bit (1) aligned external static;
dcl  sst$activations fixed bin (35) external static;
dcl  sst$backup_activations fixed bin (35) external static;
dcl  sst$dir_activations fixed bin (35) external static;
dcl  dseg$ (0:1023) fixed bin (71) external static;
dcl  error_table_$synch_seg_limit fixed bin (35) ext;
dcl  error_table_$vtoce_connection_fail fixed bin (35) ext;
dcl  error_table_$pvid_not_found ext fixed bin (35);
dcl  error_table_$illegal_activation fixed bin (35) ext;
dcl  error_table_$invalid_vtoce fixed bin (35) ext;
dcl  error_table_$dm_not_enabled fixed bin (35) ext;

dcl  pc$fill_page_table entry (ptr, ptr, fixed bin);
dcl  get_aste entry (fixed bin) returns (ptr);
dcl  get_aste$synchronized entry (fixed bin) returns (ptr);
dcl  lock$lock_ast entry;
dcl  lock$unlock_ast entry;
dcl  search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr);
dcl  search_ast$hash_in entry (ptr);
dcl  get_pvtx entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
dcl  vtoc_man$get_vtoce entry (bit (36) aligned, fixed bin, fixed bin, bit (3), ptr, fixed bin (35));
dcl  get_ptrs_$given_sdw entry (pointer) returns (pointer);
dcl  filemap_checksum_ entry (ptr, fixed bin, bit (36) aligned);
dcl  sdw_util_$get_valid entry (pointer) returns (bit (1) aligned);
dcl  syserr entry options (variable);
dcl  syserr$binary entry options (variable);

dcl  (addr, baseno, bin, convert, dim, divide, fixed, null,
     ptr, rel, rtrim) builtin;
%page;
	long_sw = "0"b;
	goto START;


/* activate_long is the same as activate, except that extra information
   is returned to the caller. */

activate_long: entry (branchp, a_activated_sw, code) returns (ptr);

	long_sw = "1"b;
	a_activated_sw = "0"b;

START:
	ep = branchp;
	dp = ptr (ep, 0);
	uid = entry.uid;
	pvid = entry.pvid;
	vtocx = entry.vtocx;
	dirsw = entry.dirsw;
	multi_class = entry.multiple_class;
	temp_entry_name = addr (ep -> entry.primary_name) -> names.name;
	pvtx = get_pvtx (pvid, code);
	if code ^= 0 then return (null);
	esw = normal;

COMMON:
	code = 0;
	already_active_by_backup = "0"b;
	pvt_arrayp = addr (pvt$array);
	pvtep = addr (pvt_array (pvtx));
	call lock$lock_ast;

/**** before multi-read directory locks, the directory lock was
      sufficient to protect against another processor making an activation.
      Thus the code below could unlock the AST, do VTOC I/O, and lock
      the AST, secure in the knowledge that nobody else was going
      to do the same thing while it was waiting for the I/O. This
      had the additional side effect of locking out any directory
      accesses for the duration.

      Now, the AST hash table is searched a second time after
      the AST is relocked after the VTOC I/O. If the uid is found,
      the code go-to's to ACTIVATED_BY_SOMEONE_ELSE to rejoin
      the same sequence that it would have taken had the segment
      been active to begin with.

      Under the new locking strategy, a program that wishes to protect
      against activations in a directory MUST HOLD A WRITE LOCK ON
      THAT DIRECTORY, or some higher lock.
****/

	astep = search_ast$check (uid, pvid, vtocx, code);
ACTIVATED_BY_SOMEONE_ELSE:
	if code ^= 0 then				/* double uid */
	     do;
ret_ulast:     call lock$unlock_ast;
	     return (null);
	end;
	ast_unlocked = "0"b;
	if astep ^= null then
	     do;
	     if aste.par_astep ^= "0"b | aste.uid = (36)"1"b then do;
		aste.multi_class = multi_class;	/* update after possible setfaults */
		return (astep);			/* the normal case */
	     end;
	     already_active_by_backup = "1"b;		/* set switch */
	end;
	if esw = normal then do;
	     if ^already_active_by_backup then do;
		ast_unlocked = "1"b;
		call lock$unlock_ast;
		vtocep = addr (local_vtoce);
		call vtoc_man$get_vtoce (pvid, pvtx, vtocx, "111"b, vtocep, code);
		if code ^= 0 then return (null);
		if vtoce.uid ^= uid then code = error_table_$vtoce_connection_fail;
		else if vtoce.dirsw ^= dirsw | vtoce.deciduous then do;
		     code = error_table_$vtoce_connection_fail;
		     call syserr (LOG, "activate: error on ^[deciduous ^]^[dir ^]^a",
			vtoce.deciduous, vtoce.dirsw, temp_entry_name);
		end;
		else code = 0;
		if code ^= 0 then return (null);
		call lock$lock_ast;
	     end;

	     par_sdwp = addr (dseg$ (fixed (baseno (dp), 18))); /* ptr to parent sdw */
	     do while (sdw_util_$get_valid (par_sdwp) = "0"b); /* If parent active */
		ast_unlocked = "1"b;
		call lock$unlock_ast;		/* Unlock the global lock */
		temp = dp -> dir.uid;		/* Cause a segfault on parent dir */
		call lock$lock_ast;			/* relock */
	     end;
	     if (pvte.pvid ^= pvid) | pvte.being_demounted then do;
		code = error_table_$pvid_not_found;	/* Check demount with AST locked */
		go to ret_ulast;
	     end;

/**** now check to make sure it hasn't been activated
      while we were not under the AST lock */

	     if ast_unlocked & ^already_active_by_backup
	     then do;
		astep = search_ast$check (uid, pvid, vtocx, code);
		if astep ^= null | code ^= 0
		then go to ACTIVATED_BY_SOMEONE_ELSE;
	     end;

	     par_astep = get_ptrs_$given_sdw (par_sdwp);

	     old_par_ehs = par_aste.ehs;		/* Save old ehs on parent */
	     par_aste.ehs = "1"b;			/* Do not let son deactivate his father */

	     if already_active_by_backup then do;
		aste.par_astep = rel (par_astep);	/* set parent astep */
		aste.infl = par_aste.infp;
		par_aste.infp = rel (astep);
		aste.per_process = par_aste.per_process;
		aste.multi_class = multi_class;	/* fix this now that we know */
		par_aste.ehs = old_par_ehs;
		return (astep);			/* not that hard */
	     end;
	end;

/* validate some fields in the VTOCE which could really kill us
   if they're bogus										*/

	if fixed (vtoce.records) > fixed (vtoce.csl)
	     | fixed (vtoce.csl) > fixed (vtoce.msl)
	     | fixed (vtoce.msl) > dim (vtoce.fm, 1)
	then do;
	     code = error_table_$invalid_vtoce;
	     goto ret_ulast;
	end;

/*  checksum the file map  */

	if vtoce.fm_checksum_valid & (sst$checksum_filemap ^= 0)
	     & ^vtoce.fm_damaged then do;
	     call filemap_checksum_ (addr (vtoce.fm), fixed (vtoce.csl, 9), checksum);
	     if vtoce.fm_checksum ^= checksum then do;
		segdamage.pvid = pvte.pvid;
		segdamage.lvid = pvte.lvid;
		segdamage.uid = vtoce.uid;
		segdamage.vtocx = vtocx;
		segdamage.pno = -1;
		segdamage.uid_path = vtoce.uid_path;
		call syserr$binary (LOG, addr (segdamage), SB_vtoc_salv_dam, SBL_vtoc_salv_dam,
		     "activate: Setting damaged switch on ^a at ^o (^a^[^a^]). Filemap damaged.",
		     vtoce.primary_name, vtocx, pvte.devname || "_" || convert (p99, pvte.logical_area_number),
		     pvte.is_sv, pvte.sv_name);
		vtoce.damaged = "1"b;
		vtoce.fm_damaged = "1"b;
		sst$damaged_ct = sst$damaged_ct + 1;
		pvte.vol_trouble_count = pvte.vol_trouble_count + 1;
	     end;
	end;

	if ^vtoce.synchronized then do;		/* Normal case */
	     astep = get_aste (fixed (vtoce.csl));
	     if astep = null () then do;
		code = error_table_$illegal_activation;
		goto ret_ulast;
	     end;
	end;
	else do;					/* Synchronized segment */
	     if ^sst$dm_enabled then do;		/* No journal */
		code = error_table_$dm_not_enabled;
		goto ret_ulast;
	     end;
	     astep = get_aste$synchronized (fixed (vtoce.csl));
	     if astep = null () then do;
		code = error_table_$synch_seg_limit;
		goto ret_ulast;
	     end;
	end;


	if esw = normal then do;
	     if astep = par_astep then call syserr (CRASH, "activate: activating into father ^p", astep);
	     par_aste.ehs = old_par_ehs;

/*	aste.fp, aste.bp	= have been set by get_aste or deactivate  */
	     aste.infl = par_aste.infp;
	     par_aste.infp = rel (astep);
	     aste.par_astep = rel (par_astep);
	     aste.per_process = par_aste.per_process;	/* Inherit this one */
	end;
						/*	aste.uid = uid;	*/ /* dont fill in now -protect against shutdown */
	aste.msl = vtoce.msl;
	aste.pvtx = pvtx;
	aste.vtocx = vtocx;
	aste.usedf = "1"b;
	aste.gtus = "1"b;
	aste.gtms = "1"b;
	aste.explicit_deact_ok = "1"b;
	aste.dnzp = vtoce.dnzp;
	aste.damaged = vtoce.damaged;
	aste.fm_damaged = vtoce.fm_damaged;
	aste.synchronized = vtoce.synchronized;
	aste.nqsw = vtoce.nqsw;
	aste.dirsw = vtoce.dirsw;
	aste.dtu = vtoce.dtu;
	aste.dtm = vtoce.dtm;
	aste.csl = vtoce.csl;
	aste.nid = vtoce.nid;
	aste.records = vtoce.records;
	aste.multi_class = multi_class;

	sst$activations = sst$activations + 1;
	if esw = backup then
	     sst$backup_activations = sst$backup_activations + 1;
	if long_sw then
	     a_activated_sw = "1"b;			/* indicate activation occured */
	if dirsw then do;
	     aste.master_dir = vtoce.master_dir;
	     aste.quota = vtoce.quota;
	     aste.used = vtoce.used;
	     aste.tqsw (0) = vtoce.received (0) ^= 0 | vtoce.master_dir;
	     aste.tqsw (1) = vtoce.received (1) ^= 0;
	     sst$dir_activations = sst$dir_activations + 1;
	end;
	else seg_aste.usage = seg_vtoce.usage;		/* Segments have no quota. keep pf count */

	call pc$fill_page_table (astep, addr (vtoce.fm), fixed (vtoce.csl)); /* fill in page table */

	aste.uid = uid;				/* aste is stable now */

	call search_ast$hash_in (astep);

	nm_astep = astep;

%include make_sstnt_entry;

	return (astep);				/* return a pointer to the new AST entry */

%page;

backup_activate: entry (a_vtocep, a_vtocx, a_pvtx, code) returns (ptr);

	esw = backup;
	long_sw = "0"b;
	vtocep = a_vtocep;
	pvtx = a_pvtx;
	vtocx = a_vtocx;
	uid = vtoce.uid;				/* set local variables */
	dirsw = vtoce.dirsw;
	multi_class = "0"b;				/* will get fixed up if someone else should activate this */
	temp_entry_name = vtoce.primary_name;
	goto COMMON;				/* with multiple entries you have to have one label */

/* format: off */
%page; %include aste;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include dir_name;
%page; %include pvte;
%page; %include segdamage_msg;
%page; %include sstnt;
%page; %include syserr_binary_def;
%page; %include syserr_constants;
%page; %include vtoce;

/* format: on */
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   activate: error on (deciduous) (dir) NAME

   S:	$log

   T:	$run

   M:	An attempt has been made to activate a
   deciduous segment,
   or to activate a segment
   when the VTOCE's directory switch did not match the branch.
   A connection failure is returned to the user process.
   This information is logged for the use of system programmers.

   A:	$ignore


   Message:
   activate: activating into father PPPP

   S:	$crash

   T:	$run

   M:	The AST entry pointer returned by get_aste
   is identical to the AST entry pointer for the parent of the segment being activated.
   $err
   $crashes

   A:	$recover


   Message:
   activate: Setting damaged switch on NAME at VTOCX (dskX_NN{s}). Filemap damaged.

   S:     $log

   T:	$run

   M:	The segment's File Map in the VTOCE had an invalid checksum, which
   indicates likely damage to the File Map. The segment is marked as damaged.
   It is possible that there is other damage on the physical volume due
   to invalid or reused disk addresses. The count of volume inconsistencies is
   incremented by 1.

   A:      Examine the VTOCE for damage using dump_vtoce. If other damage
   is evident, delete it using hp_delete_vtoce -clear and recover the
   segment. Run the physical volume scavenger as soon as possible to
   detect and correct other damage on the physical volume.


   END MESSAGE DOCUMENTATION */

     end activate;




		    alm_syserr_caller.pl1           11/11/89  1101.2r w 11/11/89  0808.4       44415



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


/****^  HISTORY COMMENTS:
  1) change(86-01-15,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-21,Coppola), install(86-07-17,MR12.0-1097):
     Add support for subvolumes.
  2) change(87-02-04,Fawcett), approve(87-04-27,MCR7670),
     audit(87-04-27,Farley), install(87-04-28,MR12.1-1028):
     Correct ioa_ format string in syserr call.
                                                   END HISTORY COMMENTS */


/* format: style4 */
alm_syserr_caller: proc;

/* 83-05-30 E. N. Kittlitz */

/* this routine contains calls to syserr which are just not worth coding
   in the ALM routines from which we wish to call syserr. */

dcl  a_pvid bit (36) aligned;
dcl  a_uid bit (36) aligned;
dcl  a_vtocx fixed bin;
dcl  a_ignore1 fixed bin;
dcl  a_ignore2 fixed bin;

dcl  code fixed bin (35);
dcl  p99 pic "99";
dcl  pv_loc char (32) varying;
dcl  pvid bit (36) aligned;
dcl  pvtx fixed bin;
dcl  uid bit (36) aligned;
dcl  vtocx fixed bin;

dcl  get_pvtx entry (bit (36) aligned, fixed bin (35)) returns (fixed bin);
dcl  search_ast entry (bit (36) aligned) returns (ptr);
dcl  syserr entry options (variable);

dcl  (addr, convert, null, rtrim) builtin;

	return;					/* no syserr_caller$syserr_caller */
%page;

search_ast_hash_error: entry;

	call syserr (CRASH, "search_ast: hash error");
	return;


/* search_ast$check entry (a_uid, a_pvid, a_vtocx, a_code) returns (ptr)
   calls this entry with the same argument list. */

search_ast_double_uid: entry (a_uid, a_pvid, a_vtocx, a_ignore1, a_ignore2);

	uid = a_uid;
	pvid = a_pvid;
	vtocx = a_vtocx;
	pvt_arrayp = addr (pvt$array);
	pvtx = get_pvtx (pvid, code);
	if code = 0 then do;
	     pvtep = addr (pvt_array (pvtx));
	     pv_loc = pvte.devname || "_" || convert (p99, pvte.logical_area_number);
	     if pvte.is_sv then pv_loc = rtrim (pv_loc) || rtrim (pvte.sv_name);
	end;
	else do;
	     pvtep = null;
	     pv_loc = "*not-mounted*";
	end;
	astep = search_ast ((uid));
	if astep = null then
	     call syserr (CRASH, "syserr_caller$search_ast_double_uid spurious call, astep=null, uid=^w, pv=^a(^w), vtocx=^o.",
		uid, pv_loc, pvid, vtocx);
	else if pvt_array (aste.pvtx).pvid = a_pvid & aste.vtocx = a_vtocx then
	     call syserr (CRASH, "syserr_caller$search_ast_double_uid spurious call, aste=^p, uid=^w, pv=^a(^w), vtocx=^o",
		astep, uid, pv_loc, pvid, vtocx);
	else call syserr (LOG, "search_ast: double uid ^w. vtocx ^o on ^a(^w). active vtocx ^o on ^a^[^a^;^1s^](^w).",
		uid, vtocx, pv_loc, pvid,
		aste.vtocx, pvt_array (aste.pvtx).devname || "_" ||
		convert (p99, pvt_array (aste.pvtx).logical_area_number),
		pvt_array (aste.pvtx).is_sv, pvt_array (aste.pvtx).sv_name,
		pvt_array (aste.pvtx).pvid);
	return;

/* format: off */
%page; %include aste;
%page; %include pvte;
%page; %include syserr_constants;
%page;
/* format: on */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   search_ast: hash error

   S:	$crash

   T:	$run

   M:	$err

   A:	$recover


   Message:
   search_ast: double uid UID. vtocx VTOCX on DRIVE(PVID). active vtocx VTOCX2 on DRIVE2(PVID2).

   S:	$log

   T:	$run

   M:	A mismatch has been detected between the branch and the ASTE
   for a segment. The two segments indicated by VTOCE index and
   physical volume location/identifier claim to have the same file system
   unique identifier. The operation either proceeds or returns a connection
   failure to the user process, as appropriate. This message is logged for the
   use of system programmers.

   This error can occur if damage to a directory branch has caused
   its unique ID to become incorrect, and if the incorrect unique ID
   happens to be identical to the unique ID of a segment already active.

   A:	$inform


   Message:
   syserr_caller$search_ast_double_uid spurious call, astep=null, uid=UID, pv=DRIVE(PVID), vtocx=VTOCX.

   S:	$log

   T:	$run

   M:	A call was made to indicate a double unique_id, but it was not possible
   to reconstruct the error. The unique_id, physical volume location/identifier,
   and VTOCE index are provided.

   A:	$ignore

   Message:
   syserr_caller$search_ast_double_uid spurious call, aste=desired, uid=UID, pv=DRIVE(PVID), vtocx=VTOCX.

   S:	$log

   T:	$run

   M:	A call was made to indicate a double unique_id, but it was not possible to
   reconstruct the error. The unique id, physical volume location/identifier,
   and vtoce index are provided.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end alm_syserr_caller;




		    boundfault.pl1                  11/11/89  1101.2rew 11/11/89  0807.4       95580



/****^  ***********************************************************
        *                                                         *
        * 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-30,Swenson), approve(88-07-04,MCR7930),
     audit(88-07-11,Parisek), install(88-07-15,MR12.2-1057):
     Modified to really fix maxlength increases.
                                                   END HISTORY COMMENTS */


boundfault: proc (a_mcptr);

/* Last modified BIM 84-02-06 to handle removal of setfaults for maxlength increases. */
/* last modified by M. Grady on 08/17/79 to fix EIS decimal boundfault case  */
/* last modified by R. Bratt on 09/17/76 for per-process boundfault metering */
/* last modified by A. Bensoussan on 04/25/75 for the new storage system. */
/* last modified by Greenberg on 10-14-74 for SST name table */
/* last modified by Kobziar on 11-15-73 to respect only max_length */
dcl  a_mcptr ptr;

dcl (tsdwp, old_astep, new_astep, pastep, temptr, kstp, par_astep) ptr,
    (pw1, pw2, pageno, segno, csl, pts, old_pts, ptsi) fixed bin,
     offset fixed bin (18),
     code fixed bin (35),
    (time1, time2) fixed bin (71),
    (last, relp) bit (18) aligned,
    (lsw, par_ehs_status) bit (1) aligned,
     tsdw fixed bin (71),
     read_lock bit (36) aligned init ("0"b);

dcl (error_table_$boundviol, error_table_$illegal_deactivation, error_table_$synch_seg_limit,
     error_table_$mylock, error_table_$root) ext fixed bin (35),
     kst_seg$ ext fixed bin,
     pds$bounds_faults fixed bin (35) ext,
     dseg$ (0 : 512) bit (72) aligned ext;

dcl  page$enter_data ext entry (fixed bin, fixed bin),
     pc$move_page_table ext entry (ptr, ptr),
     syserr entry options (variable),
     usage_values ext entry (fixed bin, fixed bin (71)),
     sum$getbranch_root_my ext entry (ptr, bit (36) aligned, ptr, fixed bin (35)),
     lock$dir_unlock ext entry (ptr),
     lock$lock_ast entry,
     lock$unlock_ast entry,
     get_ptrs_$given_segno ext entry (fixed bin) returns (ptr),
     get_aste ext entry (fixed bin) returns (ptr),
     get_aste$synchronized entry (fixed bin) returns (ptr),
     put_aste ext entry (ptr),
     search_ast$hash_in ext entry (ptr),
     search_ast$hash_out ext entry (ptr),
     setfaults ext entry (ptr, bit (1) aligned);

declare pmut$swap_sdw entry (pointer, pointer);
declare sdw_util_$set_size entry (pointer, fixed binary (19));
declare sdw_util_$get_address entry (pointer) returns (fixed bin (26));
dcl  sst_seg$ external static;
dcl  sst$pts (0 : 3) fixed bin external static;
dcl  sst$cpu_bf_time fixed bin (71) external static;
dcl  sst$total_bf_pf fixed bin (35) external static;
dcl  sst$total_bf fixed bin (35) external static;
dcl  sstp pointer;

dcl (addr, baseptr, bin, divide, max, min, null, ptr, rel) builtin;


% include mc;
% include trace_types;
% include dir_header;
% include dir_entry;
% include dir_name;
% include aste;
% include sstnt;


	call usage_values (pw1, time1);		/* meter bound fault time */
	code = 0;
	sstp = addr (sst_seg$);			/* get pointers */
	kstp = addr (kst_seg$);
	tsdwp = addr (tsdw);

	scup = addr (a_mcptr -> mc.scu (0));
	offset = bin (scup -> scu.ca, 18);		/* get the word offset causing the OOB */
	pageno = divide (offset, 1024, 17, 0);		/* get the page number in which the word is */
	if scup -> scu.apu.ptw2 then pageno = pageno + 1;	/* if decimal unit prepage, up page number */
	segno = bin (bin (scup -> scu.tsr, 15), 17);	/* get the segment number of the faulting segment */
	call page$enter_data (segno, boundfault_start);	/* place entry in the trace list */

	lsw = "1"b;				/* set lock switch on */
						/* return with entry pointer and dir locked */
	call sum$getbranch_root_my (baseptr (segno), read_lock, ep, code);
	if code ^= 0
	then if code = error_table_$mylock		/* dir already locked */
	     then lsw = "0"b;			/* turn off lock switch */
	     else if code = error_table_$root		/* this is the root */
	     then call syserr (2, "boundfault: on the root");
	     else go to update;			/* for any other error */

	code = 0;					/* May have had a mylock */
	dp = ptr (ep, 0);				/* pointer to directory */
	if sdw_util_$get_address (addr (dseg$ (segno))) = 0 then go to un; /* if segment not connected, return */

	temp_entry_name = (addr (ep -> entry.primary_name) -> names.name);
						/* Copy name into stack, as we cannot
						   touch branch with AST locked */
	call lock$lock_ast;				/* lock the AST */

	old_astep = get_ptrs_$given_segno (segno);	/* get a pointer to the AST entry */
	if old_astep = null then goto unlock_set;	/* If deactivated since boundfault, return and retake */

	if pageno >= bin (old_astep -> aste.msl, 9)	/* check max length of segment */
	then do;
	     code = error_table_$boundviol;		/* return OOB error code */
	     go to unlock_set;			/* unlock ASTE and DIR and return code */
	end;

	if old_astep -> aste.ehs then do;		/* check for the entry hold switch being ON */
	     code = error_table_$illegal_deactivation;	/* return illegal deactivation */
	     goto unlock_set;
	end;

	ptsi = bin (old_astep -> aste.ptsi, 2);		/* get the page table index for the old aste */
	old_pts = sst$pts (ptsi);		/* get the page table size of the old AST */
     /**** Before we attempt to find a new, adequately sized page table, ensure
           that the current page table size is not adequate.  If it is, then all
           we need to do is update the SDW bounds field.  This discrepancy may
           occur because, for efficiency reasons, we do not fault the SDW when
           the maximum length of a segment is increased.  We just wait until
           the next OOB occurs (this one).  Note that we've already ascertained
           that the page being referenced is within the ASTE max length. */

              if pageno < old_pts then                          /* fits within current page table */
                    begin;
     declare  temp_sdw bit (72) aligned;

	     temp_sdw = dseg$ (segno);

	     call sdw_util_$set_size ( addr (temp_sdw), min (old_pts, bin (old_astep -> aste.msl, 9)) * 1024); /* fix the sdw */
	     call pmut$swap_sdw (baseptr (segno), addr (temp_sdw));

	     call lock$unlock_ast;
	     code = 0;				/* make fim restart */
	     go to un;
	end;

	/* ? */ if ptsi >= 3 then do;			/* already at largest allowed page table size */
	     code = error_table_$boundviol;		/* return illegal bounds violation code */

unlock_set:    call lock$unlock_ast;			/* Unlock the AST */
	     go to un;				/* unlock the directory and update meters */
	end;

	call setfaults (old_astep, "0"b);		/* set faults for old AST entry */

	csl = bin (old_astep -> aste.csl, 9);		/* get the current length of the segment (in pages) */
	pts = max (pageno+1, csl);			/* get new page table size */

	if pts <= old_pts then do;			/* Used to happen for prepage decimal ops */
	     call lock$unlock_ast;
	     code = error_table_$boundviol;
	     go to un;
	end;

/* Entry hold the father to avoid deactivating him during get_aste */

	par_astep = ptr (sstp, old_astep -> aste.par_astep);
	par_ehs_status = par_astep -> aste.ehs;
	par_astep -> aste.ehs = "1"b;


	if ^old_astep -> aste.synchronized
	then new_astep = get_aste (pts);		/* get a new AST entry */
	else do;
	     new_astep = get_aste$synchronized (pts);
	     if new_astep = null () then do;
		call lock$unlock_ast;
		code = error_table_$synch_seg_limit;
		goto un;
	     end;
	end;
	

/* Copy the synchronized switch. This will ensure that page control does the
   right thing during the page table move, preventing writes before they
   should be done. */

	new_astep -> aste.synchronized = old_astep -> aste.synchronized;

/* Restore father's ehs status */

	if new_astep = par_astep then call syserr (1, "boundfault: activating into father ^p", new_astep);
	par_astep -> aste.ehs = par_ehs_status;

/* Now copy the page table from the old entry into the new */

	call pc$move_page_table (old_astep, new_astep);	/* clean up the page table move */
	nm_astep = new_astep;


/* Now replace the old aste by the new one in the inferior list */

	pastep = ptr (sstp, old_astep -> aste.par_astep); /* get a pointer to the parent to update the inferior list */

	last = "0"b;
	relp = pastep -> aste.infp;			/* get a pointer to the inferiror list */
	do while (relp ^= rel (old_astep));		/* loop searching for the current entry */
	     last = relp;				/* chain to next, save old */
	     relp = ptr (sstp, relp) -> aste.infl;	/* get next entry in list */
	end;
	if last = "0"b then pastep -> aste.infp = rel (new_astep);
	else ptr (sstp, last) -> aste.infl = rel (new_astep);



/* Now update the parent pointers of all inferior entries ( if it's a directory) */

	relp = old_astep -> aste.infp;
	do while (relp);				/* loop until the end of the list */
	     temptr = ptr (sstp, relp);
	     temptr -> aste.par_astep = rel (new_astep);	/* put in new parent pointer */
	     relp = temptr -> aste.infl;		/* get the next entry */
	end;



	call search_ast$hash_out (old_astep);
	call search_ast$hash_in (new_astep);

	call put_aste (old_astep);			/* Return old ASTE in the free pool */

%include make_sstnt_entry;

	call lock$unlock_ast;
un:	if lsw then call lock$dir_unlock (dp);		/* unlock the directory */

update:
	a_mcptr -> mc.errcode = code;
	call usage_values (pw2, time2);		/* finish metering */
	sst$cpu_bf_time = sst$cpu_bf_time + time2 - time1;
	sst$total_bf_pf = sst$total_bf_pf + pw2 - pw1;
	sst$total_bf = sst$total_bf + 1;
	pds$bounds_faults = pds$bounds_faults + 1;
	call page$enter_data (segno, boundfault_end);
	return;

ill_op_code: entry (a_mcptr);


	a_mcptr -> mc.errcode = 1;
	return;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   boundfault: on the root

   S:	$term

   T:	$run

   M:	A boundfault on the root directory has been encountered.
   $err

   A:	$inform


   Message:
   boundfault: activating into father XXX|YYY

   S:	$crash

   T:	$run

   M:	While activating a segment,
   the parent directory for the segment became deactivated.
   $err

   A:	$recover


   END MESSAGE DOCUMENTATION */

     end boundfault;




		    deactivate.pl1                  11/11/89  1101.2rew 11/11/89  0808.4       43515



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/*
			deactivate (astep, code)
			deactivate$for_delete (astep, code)



FUNCTION -

The procedure "deactivate" deactivates the segment whose ASTE is pointed  to  by
the  input argument "astep".  If the deactivation is successful, it returns with
code=0; if the deactivation fails, it returns with code=0, or ehs=1.

The procedure "deactivate" does not concern itself with the AST lock. It assumes
there is no race condition.  It is the responsibility of the caller to make sure
there is no race condition. The initializer  or  shutdown  of  course  may  call
deactivate  without  locking  the AST. For normal processes, however, the caller
must make sure the AST is locked before the call  is  issued,  and  it  will  be
unlocked upon return as soon as it is safe to do so.

The  ASTE  is  left  in  the  circular list associated with the size of the page
table, at the first position, so that it will be found right away should an ASTE
of this size be needed.

The ASTE is removed from the uid hash table.

All items of the ASTE are zeroed except fp, bp, ptsi and marker. All  PTW's  are
initialized with a page not in core flag and a coded null disk address.

deactivate$for_delete does not update the VTOCE

MODIFICATIONS -

10/13/82  J. Bongiovanni, to check number of pages in core after cleanup
09/17/82  J. Bongiovanni, for deactivate$for_delete
03/21/81	W. Olin Sibert, for ADP PTWs (or, rather, lack of them in this program)
04/19/81	W. Olin Sibert   - Eliminated maintenance of aste.ic
11/18/80  E. N. Kittlitz   - Modified for new dtu/dtm calculation.
04/10/75	Andre Bensoussan - Modified for the new storage system.

*/



deactivate        : proc  (a_astep, a_code);

dcl  a_astep	ptr,
     a_code	fixed bin (35);



dcl  pastep	ptr,
    (last, relp)	bit (18) aligned,
     code		fixed bin (35),
     for_delete_call 
                    bit (1);



dcl (error_table_$illegal_deactivation, error_table_$deact_in_mem)	fixed bin (35) ext;

dcl sst_seg$ external static;
dcl  sst$deact_count fixed bin (35) external static;
dcl sstp pointer;

dcl
     pc$cleanup		entry (ptr),
     setfaults		entry (ptr, bit(1) aligned),
     update_vtoce$deact	entry (ptr, fixed bin (35)),
     put_aste		entry (ptr),
     search_ast$hash_out	entry (ptr);

dcl (addr, binary, bit, fixed, max, ptr, rel) builtin;

/*  */

          for_delete_call = "0"b;
          goto COMMON;

for_delete:
	entry (a_astep, a_code);

	for_delete_call = "1"b;

COMMON:	

	a_code = 0;				/* zero return code */
	sstp   = addr (sst_seg$);			/* get a pointer to the SST */
	astep  = a_astep;				/* copy arguments */

	if (aste.infp ^= ""b) | aste.ehs | (aste.par_astep = ""b) | fixed (aste.np, 9) > 256 then do;
	     a_code = error_table_$illegal_deactivation;
	     return;
	     end;

	call setfaults (astep, "0"b);			/* set faults in all SDW's */

	call pc$cleanup (astep);			/* cleanup the segment (page control) */
	if aste.np ^= ""b then do;			/* cleanup failed */
	     a_code = error_table_$deact_in_mem;
	     return;
	end;

	if ^for_delete_call then do;
	     call update_vtoce$deact (astep, code);	/* update the vtoc entry */
	     if code ^= 0 then do;
		a_code = code;
		return;
	     end;
	end;
	

	pastep = ptr (sstp, astep -> aste.par_astep);	/* get a pointer to the parent AST entry */

	last = "0"b;				/* delete the entry from the list of inferior entries */
	relp = pastep -> aste.infp;			/* get pointer to inferior chain */
	do while (relp ^= rel(astep));		/* loop until end of list (shouldn't get to end ^= rel(astep)) */
	     last = relp;				/* go to next entry (but save pointer to previous one) */
	     relp = ptr (sstp, relp) -> aste.infl;
	end;
	if last = "0"b then pastep -> aste.infp = astep -> aste.infl;
	     else ptr (sstp, last) -> aste.infl = astep -> aste.infl;

						/* set dtu of parent to smallest reasonable value */
	pastep -> aste.dtu = bit (max (binary (pastep -> aste.dtu, 36),
	     binary (pastep -> aste.dtm, 36), binary (astep -> aste.dtu, 36)), 36);

	call search_ast$hash_out (astep);

	call put_aste (astep);

	sst$deact_count = sst$deact_count + 1; /* meter */

	return;

%page; %include aste;

     end deactivate;




		    deactivate_for_demount.pl1      11/11/89  1101.2r w 11/11/89  0806.0       95652



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


/****^  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.
                                                   END HISTORY COMMENTS */


deactivate_for_demount$shutdown: proc (Code);

/*  deactivate_for_demount

    Program to do a bottom-up tree-walk of the AST and deactivate segments
    prior to volume demounting.

    Entries:

    lv       - deactivates all segments belonging to a specified logical
	     volume, using segment control deactivation.

    shutdown - deactivates all segments by hand and converts deciduous
	     segments into hardcore segments, freeing VTOCEs in the
	     process. This can be called only during system shutdown.
	     Segment control will not function after this is called.

    Written June 1982 by J. Bongiovanni
    Modified September 1982, J. Bongiovanni, to for device inop in shutdown
*/

/*  Parameter  */

	dcl     Code		 fixed bin (35) parameter; /* Return Code */
	dcl     Lvid		 bit (36) aligned;	/* Logical Volume ID */

/*  Automatic  */

	dcl     1 aste_val		 (0:3) aligned,	/* Used to validate aste-ptrs */
		2 begin_addr	 fixed bin (19),	/* Begin of ASTEs this page table size */
		2 end_addr	 fixed bin (19),	/* End of ASTEs this page table size */
		2 modulus		 fixed bin;	/* Size of ASTE + Page Table */
	dcl     astep_stack		 (16) ptr;	/* Stack for tree-walk */
	dcl     code		 fixed bin (35);	/* Error code */
	dcl     lvid		 bit (36) aligned;	/* Logical volume ID */
	dcl     p99		 pic "99";
	dcl     shut		 bit (1) aligned;	/* ON => shutdown called */
	dcl     sstp		 ptr;
	dcl     stack_level		 fixed bin;	/* Current level in stack */

/*  Static  */

	dcl     VALID_MARKER	 bit (6) internal static options (constant) init ("02"b3);

/*  External  */

	dcl     error_table_$inconsistent_sst fixed bin (35) external;
	dcl     error_table_$vtoc_io_err fixed bin (35) external;
	dcl     pvt$esd_state	 fixed bin external;
	dcl     pvt$n_entries	 fixed bin external;
	dcl     sst$		 external;
	dcl     sst$astap		 ptr external;
	dcl     1 sst$level		 (0:3) aligned external,
		2 ausedp		 bit (18) unal,
		2 no_aste		 fixed bin (18) uns unal;
	dcl     sst$pts		 (0:3) fixed bin external;
	dcl     sst$root_astep	 ptr external;

/*  Entry  */

	dcl     deactivate		 entry (ptr, fixed bin (35));
	dcl     lock$lock_ast	 entry;
	dcl     lock$unlock_ast	 entry;
	dcl     pc$cleanup		 entry (ptr);
	dcl     syserr$error_code	 entry options (variable);
	dcl     update_vtoce$deact	 entry (ptr, fixed bin (35));
	dcl     vtoc_man$free_vtoce	 entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));

/* Builtin */

          dcl     addr                   builtin;
	dcl     bin		 builtin;
	dcl     convert		 builtin;
	dcl     hbound		 builtin;
	dcl     mod		 builtin;
	dcl     ptr		 builtin;
	dcl     rel		 builtin;
	dcl     size		 builtin;

/* Condition */

	dcl     any_other		 condition;
%page;
	shut = "1"b;

	if pvt$esd_state ^= 0
	then on any_other goto BAD_SST;

	goto COMMON;

lv:
     entry (Lvid, Code);

	lvid = Lvid;
	shut = "0"b;

COMMON:

	Code = 0;
	pvt_arrayp = addr (pvt$array);

	call lock$lock_ast;

	call INIT_FOR_SST;

	stack_level = 1;
	astep_stack (1) = sst$root_astep;
	call VALIDATE_ASTE (astep_stack (1));
	call PUSH_CHILD (astep_stack (1));

	do while (stack_level > 0);
	     astep = astep_stack (stack_level);
	     call POP_PUSH_BROTHER (astep);
	     call CHECK_DEACTIVATE (astep);
	end;

UNLOCK_RETURN:

	call lock$unlock_ast;

	return;


BAD_SST:
	Code = error_table_$inconsistent_sst;
	call lock$unlock_ast;
	return;

%page;
/*  Internal Procedure to check whether this ASTE should be deactivated,
    and to do it.
*/

CHECK_DEACTIVATE:
     proc (Astep);

	dcl     Astep		 ptr;

	dcl     1 Aste		 aligned like aste based (Astep);

	if Aste.uid = ""b then return;
	pvtep = addr (pvt_array (Aste.pvtx));

	if shut then do;				/* Called for shutdown */
	          if pvte.device_inoperative then return;

		Aste.fmchanged = Aste.fmchanged | Aste.fmchanged1;
		Aste.ddnp = "0"b;
		if Aste.hc_sdw			/* Deciduous segment */
		then call REVERT_DECIDUOUS (Astep);	/* Change to hardcore segment */
		else call DEACTIVATE_FOR_SHUTDOWN (Astep);
	     end;
	else do;					/* Called for Logical Volume */
		if pvte.lvid = lvid then do;
			Aste.fmchanged = Aste.fmchanged | Aste.fmchanged1;
			Aste.ddnp = "0"b;
			call deactivate (Astep, code);
			if code ^= 0
			then do;
				Code = code;
				goto UNLOCK_RETURN;
			     end;
		     end;
	     end;


     end CHECK_DEACTIVATE;
%page;
/* Internal Procedure to deactivate by hand for shutdown. The segment
   is updated to disk (pages and VTOCE), but ASTE threads are left as-is.
*/
DEACTIVATE_FOR_SHUTDOWN:
     proc (Astep);

	dcl     Astep		 ptr;

	dcl     1 Aste		 aligned like aste based (Astep);

	if ^Aste.ehs then call pc$cleanup (Astep);

	call update_vtoce$deact (Astep, code);
	if code ^= 0
	then if code ^= error_table_$vtoc_io_err
	     then do;
		     Code = code;
		     goto UNLOCK_RETURN;
		end;

	Aste.uid = ""b;

     end DEACTIVATE_FOR_SHUTDOWN;


%page;
/* Internal Procedure to advance to the brother of the supplied ASTE.
   If the brother exists, descendants are pushed onto the stack, as
   far as possible. If no brother exists, the stack is popped by one.

   This procedure is the brains of the bottum-up-left-right tree-walk
*/

POP_PUSH_BROTHER:
     proc (Astep);

	dcl     Astep		 ptr;

	dcl     bastep		 ptr;
	dcl     castep		 ptr;
	dcl     pastep		 ptr;

	dcl     1 Aste		 aligned like aste based (Astep);
	dcl     1 baste		 aligned like aste based (bastep);
	dcl     1 caste		 aligned like aste based (castep);
	dcl     1 paste		 aligned like aste based (pastep);


	castep = Astep;
	pastep = ptr (sstp, caste.par_astep);

	if caste.infl = ""b
	then stack_level = stack_level - 1;
	else do;
		bastep = ptr (sstp, caste.infl);
		call VALIDATE_ASTE (bastep);
		call VALIDATE_PARENT_CHILD (pastep, bastep);
		astep_stack (stack_level) = bastep;
		call PUSH_CHILD (bastep);
	     end;

     end POP_PUSH_BROTHER;
%page;
/*  Internal Procedure to push as many descendants of the supplied ASTE
    as possible onto the stack. Only the first descendant is examined at each level.
*/

PUSH_CHILD:
     proc (Astep);

	dcl     Astep		 ptr;

	dcl     castep		 ptr;
	dcl     pastep		 ptr;


	dcl     1 caste		 aligned like aste based (castep);
	dcl     1 paste		 aligned like aste based (pastep);

	pastep = Astep;

	do while (paste.infp ^= ""b);
	     castep = ptr (sstp, paste.infp);
	     call VALIDATE_ASTE (castep);
	     call VALIDATE_PARENT_CHILD (pastep, castep);
	     stack_level = stack_level + 1;
	     if stack_level > hbound (astep_stack, 1)
	     then goto BAD_SST;
	     astep_stack (stack_level) = castep;
	     pastep = castep;
	end;

     end PUSH_CHILD;
%page;
/* Internal Procedure to convert a deciduous segment to a hardcore segment
   and free its VTOCE.
*/

REVERT_DECIDUOUS:
     proc (Astep);

	dcl     Astep		 ptr;

	dcl     last		 bit (18) aligned;
	dcl     pastep		 ptr;
	dcl     relp		 bit (18) aligned;
	dcl     vtocx		 fixed bin;

	dcl     1 Aste		 aligned like aste based (Astep);
	dcl     1 paste		 aligned like aste based (pastep);

/* Unthread the ASTE */

	pastep = ptr (sstp, Aste.par_astep);
	last = ""b;
	relp = paste.infp;

	do while (relp ^= rel (Astep));
	     last = relp;
	     relp = ptr (sstp, relp) -> aste.infl;
	end;

	if last = ""b
	then paste.infp = Aste.infl;
	else ptr (sstp, last) -> aste.infl = Aste.infl;

/* Free the VTOCE */

	if Aste.pvtx > 0 & Aste.vtocx >= 0 then do;
		vtocx = Aste.vtocx;
		Aste.vtocx = -1;
		pvtep = addr (pvt_array (aste.pvtx));
		call vtoc_man$free_vtoce ((pvte.pvid), (Aste.pvtx), vtocx, code);
		if code ^= 0
		then call syserr$error_code (LOG, "deactivate_for_demount: Error freeing vtocx ^o on ^a_^a for ^w",
			vtocx, pvte.devname, convert (p99, pvte.logical_area_number));
	     end;

     end REVERT_DECIDUOUS;


%page;
/*  Internal Procedure to validate an ASTE */

VALIDATE_ASTE:
     proc (Astep);

	dcl     Astep		 ptr;

	dcl     aste_addr		 fixed bin (19);
	dcl     pts		 fixed bin;

	dcl     1 Aste		 aligned like aste based (Astep);

	if Aste.marker ^= VALID_MARKER
	then goto BAD_SST;

	if Aste.uid = ""b & ^shut
	then goto BAD_SST;

	if bin (Aste.msl, 9) > 256
	     | bin (Aste.csl, 9) > 256
	     | bin (Aste.records, 9) > 256
	then goto BAD_SST;

	if Aste.pvtx <= 0
	     | Aste.pvtx > pvt$n_entries
	then goto BAD_SST;

	pts = bin (Aste.ptsi, 2);
	aste_addr = bin (rel (Astep));
	if aste_addr < aste_val (pts).begin_addr
	     | aste_addr >= aste_val (pts).end_addr
	then goto BAD_SST;
	if mod (aste_addr - aste_val (pts).begin_addr, aste_val (pts).modulus) ^= 0
	then goto BAD_SST;

     end VALIDATE_ASTE;

%page;
/*  Internal Procedure to validate that two ASTEs are related as
    parent/child.
*/

VALIDATE_PARENT_CHILD:
     proc (Pastep, Castep);

	dcl     Pastep		 ptr;
	dcl     Castep		 ptr;

	dcl     1 Caste		 aligned like aste based (Castep);


	if Caste.par_astep ^= rel (Pastep)
	then goto BAD_SST;


     end VALIDATE_PARENT_CHILD;

%page;
/*  Internal Procedure to initialize  */

INIT_FOR_SST:
     proc;

	dcl     array_addr		 fixed bin (19);
	dcl     pts		 fixed bin;

	sstp = addr (sst$);

	array_addr = bin (rel (sst$astap));
	do pts = 0 to 3;
	     aste_val (pts).begin_addr = array_addr;
	     aste_val (pts).end_addr = array_addr + bin (sst$level (pts).no_aste) * (size (aste) + sst$pts (pts));
	     aste_val (pts).modulus = size (aste) + sst$pts (pts);
	     array_addr = aste_val (pts).end_addr;
	end;

     end INIT_FOR_SST;
%page;
%include aste;
%page;
%include pvte;
%page;
%include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

Message:
deactivate_for_demount: Error freeing vtocx OOOO on dskX_NN for UID. ERRORMESSAGE.

S:     $log

T:     During system shutdown.

M:     The VTOCE for a deciduous segment could not be freed for the
reason indicated. The VTOCE will be freed by the next volume salvage
or by delete_old_pdds.

A:     $ignore

END MESSAGE DOCUMENTATION */

     end deactivate_for_demount$shutdown;




		    flush_ast_pool.pl1              11/11/89  1101.2rew 11/11/89  0808.5       16263



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


flush_ast_pool:
     procedure (a_ptsi);

/* Entry to hedge the AST against fatal crash. */

dcl a_ptsi fixed bin;

dcl fastep ptr;
dcl first bit (1) aligned;
dcl ptsi fixed bin;

dcl lock$lock_ast entry;
dcl lock$unlock_ast entry;
dcl update_vtoce entry (ptr);

dcl (addr, hbound, lbound, pointer, ptr) builtin;
     

/* * * * * * * * * * FLUSH_AST_POOL * * * * * * * * * */

	ptsi = a_ptsi;				/* copy magic to stack. */

	sstp = addr (sst_seg$);
	if (ptsi < lbound (sst.ausedp, 1)) | (ptsi > hbound (sst.ausedp, 1)) then return;

	call lock$lock_ast;				/* pull the shades */

	fastep = ptr (sstp, sst.ausedp (ptsi));
	first = "1"b;				/* until x3j1 gives in on until... */
	do astep = fastep repeat (pointer (astep, aste.fp)) while ((astep ^= fastep) | first);
						/* Scan whole loop. */
	     first = "0"b;

	     aste.deact_error = "0"b;			/* retry bad I/O's */

	     if aste.usedf & aste.fmchanged & ^aste.per_process then do;
		call update_vtoce (astep);
		sst.hedge_updatevs = sst.hedge_updatevs + 1;
		end;
	end;

	call lock$unlock_ast;
	return;
%page;
%include aste;
%include sst;

     end flush_ast_pool;




		    get_aste.pl1                    11/11/89  1101.2rew 11/11/89  0807.4      164916



/****^  ***********************************************************
        *                                                         *
        * 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_aste:
     procedure (csl) returns (ptr);

dcl csl fixed bin (17) parameter;

/*
   astep = get_aste (csl)
   astep = get_aste$synchronized (csl);

   FUNCTION -

   The procedure "get_aste" returns a pointer to  a  free  ASTE  whose  page  table
   length  is  equal to or greater than the input argument "csl". If it cannot find
   such an ASTE, it returns a null pointer.

   "get_aste" does not concern itself with the AST lock. It  assumes  there  is  no
   race  condition.  It is the responsibility of the caller to issue the call after
   the AST has been locked and to unlock it upon return, as soon as it is  safe  to
   do  so.  Of  course,  the  initializer  or  shutdown may call "get_aste" without
   locking the AST since they know they are alone.

   The ASTE is threaded in the circular list, at the end.

   All items of the ASTE are zero with the exception of fb and bp which thread  the
   ASTE  in  the  circular list, and ptsi and marker which are engraved in the ASTE
   forever.

   All PTW's are initialized with a page not in core flag and  with  a  coded  null
   device address.

   IMPLEMENTATION -

   First,  the  argument "csl" is used to determine what is the appropriate size of
   the page table. Then the circular list associated with the  determined  size  is
   scanned,  starting  from  the ASTE which happens to be pointed to by the current
   pointer associated with this list.

   If there is a free ASTE at the head of the list, it will be selected.
   Otherwise, the list is searched for an ASTE which is not entry-held,
   has no inferiors, no pages in memory, and aste.init not set.  ASTE's
   which are rejected have their file maps updated if aste.fmchanged = "1"b.

   If no ASTE's are found above, a much more careful search is done.
   The estimated cost of deactivating each segment is computed by computing
   a 'cost' equal to the sum of pages used, pages modified, and 1 for the
   VTOCE I/O.  The cost for a directory also includes the sum of the costs
   of its inferiors.  The segment with the lowest cost will be selected.

   The selected segment is deactivated with the "deactivate" routine.
   If this segment is a directory with active inferiors, all inferiors
   are also deactivated (in a bottom-up manner, thereby adhering to the
   dictum that all ancestor segments of an active segment must be active).

   No matter if the selected ASTE was free or if it has been deactivated, it is now
   threaded in the list, at the FIRST position. It is  put  at  the  last  position
   merely by moving the current position forward by 1 position.

   Synchronized segments are special-cased. If the per-pool limit on these
   is exceeded, only synchronized segments are considered for deactivation.

   MODIFICATIONS -

   04/08/75 Totally rewritten by Andre Bensoussan for the new storage system.
   06/76 by D.Vinograd to skip ast entries in use by the volume dumper
   03/23/77 by Greenberg for get_aste$flush_ast_pool
   10/07/80 by C. Hornig for new replacement algorithm
   03/21/81 W. Olin Sibert, for ADP PTWs
   04/19/81 by W. Olin Sibert, to get rid of aste.ic
   05/31/81 by J. Bongiovanni to return null ptr on invalid csl
   10/25/82 by J. Bongiovanni for synchronized segments
*/

dcl N_PROTECTED_ASTES fixed bin static options (constant) init (4);

dcl (fastep, lastep, mp_astep) ptr;
dcl aste_count fixed bin;
dcl (cost_total, best_cost) fixed bin;
dcl pts fixed bin;
dcl code fixed bin (35);
dcl ptsi fixed bin (3);
dcl ptp pointer;
dcl synchronized_call bit (1) aligned;
dcl synchronized_only bit (1) aligned;

dcl error_table_$deact_in_mem fixed bin (35) external;
dcl pds$process_group_id char (32) external;
dcl sys_info$system_type fixed bin external static;

dcl deactivate entry (ptr, fixed bin (35));
dcl hc_dm_util$check_activate entry (fixed bin (3), fixed bin (35));
dcl hc_dm_util$activate entry (fixed bin (3));
dcl syserr entry options (variable);
dcl syserr$error_code entry options (variable);
dcl update_vtoce entry (ptr);

dcl (addr, addrel, binary, hbound, lbound, null, pointer, rel) builtin;

%page;
/* * * * * * * * * * GET_ASTE * * * * * * * * */

          synchronized_call = "0"b;
          goto common;

synchronized:
	entry (csl) returns (ptr);

	synchronized_call = "1"b;

common:	
	sstp = addr (sst_seg$);			/* get a pointer to the SST */

	do ptsi = hbound (sst.pts, 1) by -1 to lbound (sst.pts, 1) + 1 while (csl <= sst.pts (ptsi - 1));
	end;					/* search for the correct index */

	pts = sst.pts (ptsi);			/* save real size of the page table array */

	if csl > pts then do;			/* invalid csl				*/
	     call syserr (0, "get_aste: Invalid csl ^d", csl);
	     return (null());
	end;


	sst.aneedsize (ptsi) = sst.aneedsize (ptsi) + 1;	/* meter */

	if sst.ausedp (ptsi) = ""b then goto err_out;	/* none on the list */

	synchronized_only = "0"b;
	if synchronized_call then do;
	     sst.synch_activations = sst.synch_activations + 1;
	     call hc_dm_util$check_activate (ptsi, code);
	     if code ^= 0 then synchronized_only = "1"b;
	end;

/*   First, check the beginning of the aste list for a free aste.				
     During deactivation, put_aste threads the newly-freed aste				
     to the beginning of the list								
											*/
	

	fastep, lastep, astep = pointer (sstp, sst.ausedp (ptsi));
				

	if ^aste.usedf & ^synchronized_only then do;
	     sst.stepsa = sst.stepsa + 1;
	     sst.asteps (ptsi) = sst.asteps (ptsi) + 1;
return_aste:
	     sst.ausedp (ptsi) = aste.fp;		/* Move current ptr forward by 1 position */
	     if synchronized_call
		then call hc_dm_util$activate (ptsi);
	     return (astep);			/* Return astep - ASTE is now last in list */
	     end;

/*   Next, protect a number of aste's from being deactivated during this
     this call to get_aste.  The number of protected aste's is given
     by the constant N_PROTECTED_ASTES; the aste's protected are those
     in the list immediately preceding the current position (and hence,
     the protected aste's are those activated most recently).  The purpose
     of this protection is to prevent "ping-ponging" of aste's, a phenomenon
     wherein the system hangs on a single instruction (e.g., a multi-word EIS
     instruction referencing multiple segments alternately taking segment
     faults on two segments, where the segment fault of one causes
     deactivation of the other segment).							*/

	do aste_count = 1 to N_PROTECTED_ASTES;		/* walk back to protect */
	     astep = pointer (astep, aste.bp);		/* recently used ASTE's */
	     if ^aste.usedf & ^synchronized_only then goto return_aste;
	     if astep = fastep then goto small_ast;	/* ridiculous */
	end;
small_ast:
	lastep = astep;

/*   This is the main loop of aste allocation.  The entire list is walked
     (except for aste's which have been protected above) until one of the
     following happens:

          1. an aste is found which can be deactivated (entry-hold-switch,
             dumper-in-use, ddnp, and deact_error all off), is not in
             "grace" lap (the first lap after activation), has no active
             inferiors, and no pages in memory.

          2. the end of the list is reached.

     With reasonable number of aste's in the pools (set via the SST card),
     and normal system behavior, an aste should almost always be found
     in this loop										*/
	

	do astep = fastep repeat (pointer (astep, aste.fp)) while (aste.fp ^= rel (lastep));
	     if ^aste.usedf & ^synchronized_only then goto return_aste;  /* aste free -allocate it			*/
	     

	     sst.stepsa = sst.stepsa + 1;		/* count total steps			*/
	     sst.asteps (ptsi) = sst.asteps (ptsi) + 1;	/* count steps for this size */

	     if aste.dius then do;			/* volume dumper is using it */
		sst.askipdius = sst.askipdius + 1;
		goto skip;
		end;

	     if aste.ehs | aste.ddnp | aste.deact_error then do;
						/* Check for ehs = entry_hold, or ddnp
						   without that, which = being prewithdrawn. */
		sst.askipsehs = sst.askipsehs + 1;
		go to skip;
		end;

	     if aste.init then do;			/* check for grace lap flag */
		aste.init = "0"b;			/* turn off flag */
		sst.askipsinit = sst.askipsinit + 1;
		go to skip;
		end;

	     if (aste.np ^= ""b) | (aste.infp ^= ""b) then do; /* check for no inferiors, no pages in memory*/
		sst.askipslevel = sst.askipslevel + 1;
		goto skip;
		end;

	     if synchronized_only & ^aste.synchronized then do;	/* check for synch seg restrictions */
		sst.synch_skips = sst.synch_skips + 1;
		goto skip;
	     end;

	     sst.ausedp (ptsi) = rel (astep);
	     call my_deactivate (astep, code);
	     if code = 0 then goto return_aste;

skip:
	     if aste.fmchanged & ^aste.per_process then do;
						/* check for AST trickle */
		call update_vtoce (astep);		/* update the vtoc entry */
		sst.updates = sst.updates + 1;
		end;
	end;
%page;
/*   This is the tough search.  At this point we are willing to do a lot
     more work to find the right aste to deactivate.  We assume that this
     search is rarely needed, and so we are not concerned with the overhead
     involved.  

     In this search, the entire aste list is walked (again, excepting aste's
     which are protected for this call to get_aste), and a cost is computed
     for deactivating each aste which can be deactivated.  Since we are in
     desparate straights, we are willing to deactivate inferiors (if necessary).
     However, the restrictions of entry-hold switch, dumper-in-use, ddnp,
     and deact_error still apply; further, an aste cannot be deactivated if
     any of these conditions prevent an inferior from being deactivated.
     After a walk of the entire list, the aste with the lowest cost is
     deactivated (following a bottom-up deactivation of all of its inferiors).

     Synchronized segments are special-cased if the per-pool limit on these
     is exceeded. The first such segment which can be deactivated is deactivated.
     This logic is a hedge against flooding the system with de-facto entry-held
     segments. It is expected to be executed rarely.
*/

deact_error:
	best_cost = 1f16b;
	mp_astep = null ();
	do astep = fastep repeat (pointer (astep, aste.fp)) while (aste.fp ^= rel (lastep));
	     cost_total = 0;
	     if ^synchronized_only then do;		/* Normal case */
		call check (astep, code);		/* calculate the cost */
		if code ^= 0 then goto ddir_loop;
		call walk_ast (check, code);		/* check the inferior hierarchy */
		if code ^= 0 then goto ddir_loop;
		
		if cost_total < best_cost then do;
		     best_cost = cost_total;
		     mp_astep = astep;
		end;
	     end;
	     else do;				/* Synchronized only */
		call check (astep, code);
		if code ^= 0 then goto ddir_loop;
		sst.ausedp (ptsi) = rel (astep);
		call my_deactivate (astep, code);
		if code = 0 then goto return_aste;
	     end;
ddir_loop:
	end;

	if mp_astep = null () then do;		/* didn't find anything */
err_out:
	     if ^synchronized_only then
		call syserr (0, "get_aste: No removable ^dk AST entries.", pts);
	     else call syserr (4, "get_aste: No removable ^dk synchronized AST entries.", pts);
	     return (null ());
	     end;

	astep = mp_astep;
	call walk_ast (my_deactivate, code);		/* deactivate all inferiors */
	if code ^= 0 then goto deact_error;

	sst.ausedp (ptsi) = rel (astep);
	call my_deactivate (astep, code);
	if code ^= 0 then goto deact_error;

	sst.asearches = sst.asearches + 1;
	sst.acost = sst.acost + best_cost;

	goto return_aste;

/* * * * * * * * * * WALK_AST * * * * * * * * * */

walk_ast:
     procedure (Proc, Code);
dcl Proc variable entry (ptr, fixed bin (35)) parameter;
dcl Code fixed bin (35) parameter;
dcl inf_astep ptr;
dcl next_astep ptr;
dcl brother bit (1) aligned;

/* This procedure walks the tree of active inferiors of an active directory,
   calling the supplied procedure on each branch.  The branches are processed
   bottom-up. */

	Code = 0;
	inf_astep = astep;
find_son:						/* walk to the bottom of the subtree */
	do while (inf_astep -> aste.infp ^= ""b);
	     inf_astep = pointer (inf_astep, inf_astep -> aste.infp);
	end;
process_aste:
	if inf_astep = astep then return;		/* we have walked the whole tree */
	if inf_astep -> aste.infl ^= ""b then do;	/* next do his brother */
	     next_astep = pointer (inf_astep, inf_astep -> aste.infl);
	     brother = "1"b;	
	     end;
	else do;
	     next_astep = pointer (inf_astep, inf_astep -> aste.par_astep);
	     brother = "0"b;
	     end;
	call Proc (inf_astep, Code);			/* process the branch */
	if Code ^= 0 then return;
	inf_astep = next_astep;
	if brother then goto find_son;
	else goto process_aste;
     end walk_ast;

%page;

/* * * * * * * * * * CHECK * * * * * * * * * * */

check:
     procedure (Astep, Code);
dcl Astep ptr parameter;
dcl Code fixed bin (35) parameter;

dcl pn fixed bin;

/* check makes sure that a directory can be deactivated safely 
   It also increments the cost function.  At the same time, it checks
   whether this aste (an inferior to the one being considered for
   deactivation) is in the same aste pool as the aste being considered.
   If it is, a non-zero code is returned, since we know that there is
   an aste in the pool with lower cost than the one being considered currently
   (namely, this one).									*/
     

	if (Astep -> aste.ehs) | (Astep -> aste.ddnp) | (Astep -> aste.dius) | (Astep -> aste.deact_error)
	then goto cant_do_it;
	if synchronized_only & ^(Astep -> aste.synchronized)
	then goto cant_do_it;
	if (binary (Astep -> aste.ptsi) = ptsi) & (astep ^= Astep) then do;
cant_do_it:
	     Code = -1;
	     return;
	     end;

	Code = 0;
	ptp = addrel (Astep, sst.astsize);		/* Start with page zero */
	cost_total = cost_total + 1;			/* Costs one for the ASTE itself */

	do pn = 1 to pts;
	     cost_total = cost_total + ptw_cost (ptp);
	     ptp = addrel (ptp, 1);
	     end;

	if cost_total > best_cost then Code = -1;	/* aste being considered cannot win		*/

     end check;
%page;

/* * * * * * * * * * PTW_COST * * * * * * * * * */

ptw_cost: proc (Ptwp) returns (fixed bin);

/* This procedure returns the "cost" of flushing one PTW. If the PTW
   has not been used or modified, the cost is zero. If it has been either
   used or modified, the cost is one. If it has been both, the cost is two.
   */

dcl  Ptwp pointer parameter;

dcl  used bit (1) aligned;
dcl  mod bit (1) aligned;


	if sys_info$system_type = ADP_SYSTEM then
	     used = (Ptwp -> adp_ptw.phu) | (Ptwp -> adp_ptw.phu1);
	else used = (Ptwp -> l68_ptw.phu) | (Ptwp -> l68_ptw.phu1);

	if sys_info$system_type = ADP_SYSTEM then
	     mod = (Ptwp -> adp_ptw.phm) | (Ptwp -> adp_ptw.phm1);
	else mod = (Ptwp -> l68_ptw.phm) | (Ptwp -> l68_ptw.phm1);

	if (used & mod) then return (2);
	else if (used | mod) then return (1);
	else return (0);

	end ptw_cost;


%page;

/* * * * * * * * * * MY_DEACTIVATE * * * * * * * * * * */

/* Internal procedure to deactivate an aste.
   If an error of any sort occurs here, a message is printed on the console,
   and the flag aste.deact_error is set so that this aste will be skipped
   in the aste replacement search.  This flag is reset by flush_ast_pool.				*/
     

my_deactivate:
     procedure (Astep, Code);
dcl Astep ptr parameter;
dcl Code fixed bin (35) parameter;

	call deactivate (Astep, Code);
	if Code ^= 0 then 
	     if ^(Astep -> aste.synchronized) | (Code ^= error_table_$deact_in_mem) then do;
	     Astep -> aste.deact_error = "1"b;
	     call syserr$error_code (3, Code,
		"get_aste: Error deactivating ^w (VTOCE ^o on pvt ^o) to free ^dK ASTE for ^a.", Astep -> aste.uid,
		Astep -> aste.vtocx, Astep -> aste.pvtx, pts, pds$process_group_id);
	     end;
     end my_deactivate;

%page; %include sst;
%page; %include aste;
%page; %include system_types;
%page; %include "ptw.l68";
%page; %include "ptw.adp";

/*  */

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   get_aste: no removable XXXk ast entries

   S: $info

   T: $run

   M: An AST entry was needed for a segment of size XXX k, but no free
   entries of that size were present, and no segments occupying such
   entries could be deactivated. This could be symptomatic of a
   logic problem, but may also indicate a grossly mistuned AST.

   A: 
   Substantially increase the number of AST entries of this size as
   given on the SST CONFIG card. If the problem persists, contact the
   system programming staff.

   Message:
   get_aste: no removable XXXk synchronized AST entries

   S: $log

   T: $run

   M: An AST entry was needed for a synchronized segment of size XXX k, and
   the per-ASTE-pool limit on synchronized segments was reached. No synchronized
   segments in that pool could be deactivated.

   A: Contact the system programming staff.

   Message:
   get_aste: Invalid csl x

   S:     $log

   T:     $run

   M:     get_aste was called to activate a segment with x pages,
which is larger than the maximum segment size.  This is indicative
of hardware or software failure (a typical problem is an invalid
VTOCE).

   A:     If the problem persists, contact the system programming staff.


   Message:
   get_aste: Error deactivating UUUU (vtoc V of pvt PV) to free XXXk ASTE for USERNAME.

   S: $log

   T: $run

   M: The system encountered an error deactivating an AST entry which was
   selected for deactivation by the AST replacement algorithm.  The AST
   on which the error was encountered will be flagged to be ingored by
   further passes of the algorithm; this flag will be reset during the next
   run of flush_ast_pool.

   A: If the problem persists, contact the system programming staff.

   END MESSAGE DOCUMENTATION */

     end get_aste;




		    hc_exponent_control.pl1         11/11/89  1101.2r w 11/11/89  0808.5       72927



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



/* hc_exponent_control

   ring zero program to get/set the pds variables that control
   the fim's action on overflow and underflow and use of
   hexadecimal floating point exponent.

*/

/* format: style4 */
hc_exponent_control:
     proc;

	return;					/* never called here */

/* Coded February 80 Benson I. Margulies */
/* Modified February 83 E. N. Kittlitz. hexfp */
/* Modified March 83 E. N. Kittlitz (age 28) make hexfp use 2 bits */
/* Modified June 83 E. N. Kittlitz (still, but not for long) use pmut$load_mode_reg instead of ring_alarm */
/* Modified 831120 E. N. Kittlitz for hex exponent fault/restart control */
/* Modified Nov 1 84 by M. Sharpe to control access to HFP mechanism using an access control segment */

dcl  a_code fixed bin (35) aligned parameter;
dcl  a_max_value bit (72) aligned parameter;
dcl  a_new_hfp_sw bit (2) aligned parameter;
dcl  a_old_hfp_sw bit (2) aligned parameter;
dcl  a_restart_overflow bit (1) aligned parameter;
dcl  a_restart_underflow bit (1) aligned parameter;

dcl  control_bit_index fixed bin;
dcl  hfp_raw_mode bit (36) aligned automatic;
dcl  max_value bit (72) aligned;
dcl  new_hfp_sw bit (2) aligned;
dcl  restart_overflow bit (1) aligned;
dcl  restart_underflow bit (1) aligned;
dcl  val fixed bin (17);

dcl  substr builtin;

dcl  pds$exp_undfl_rest bit (2) aligned external static;
dcl  pds$exp_ovfl_rest bit (2) aligned external static;
dcl  pds$eovfl_value bit (72) aligned external static;
dcl  pds$hex_eovfl_value bit (72) aligned external static;
dcl  pds$initial_ring fixed bin (3) aligned external static;
dcl  pds$hfp_exponent_enabled bit (1) aligned external static;
dcl  sys_info$hfp_exponent_available bit (1) aligned external static;

dcl  error_table_$action_not_performed fixed bin (35) aligned external static;

dcl  acs_dir char (14) internal static options (constant) init (">sc1>admin_acs");
dcl  acs_seg char (15) internal static options (constant) init ("Fortran_hfp.acs");

dcl  level$get returns (fixed bin (17));
dcl  pmut$load_mode_reg entry;
dcl  status_$get_user_raw_mode entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35));
%page;

/**** *************************************************************************
      *   Usage:						        *
      *   						        *
      *   declare hc_exponent_control$exponent_control_get		        *
      *    entry (bit (1) aligned, bit (1) aligned, bit (72) aligned);        *
      *   ditto:  hc_exponent_control$hex_exponent_control_get	        *
      *   						        *
      *   call hc_exponent_control$exponent_control_get (restart_underflow,   *
      *      restart_overflow, overflow_value);			        *
      *   						        *
      *   declare hc_exponent_control$exponent_control_set		        *
      *    entry (bit (1) aligned, bit (1) aligned, bit (72) aligned,	        *
      *           fixed bin (35) aligned);			        *
      *   ditto: hc_exponent_control$hex_exponent_control_set	        *
      *   						        *
      *   call hc_exponent_control$exponent_control_set (restart_underflow,   *
      *	restart_overflow, overflow_value, code);		        *
      *   						        *
      *							        *
      *   All arguments are Output for get and Input for set.	        *
      *   						        *
      *   restart_overflow	"1"b to make the fim restart underflows with    *
      *			a zero result, "0"b to fault.		        *
      *   						        *
      *   restart_overflow	"1"b to make the fim restart overflows with     *
      *   			a defined result, "0"b to fault.      *
      *   						        *
      *   overflow_value	value to use for result of restarted overflow   *
      *   			if overflows are to be restarted.     *
      *							        *
      *   code		standard status code.		        *
      *							        *
      ************************************************************************* */

%page;

exponent_control_get:
     entry (a_restart_underflow, a_restart_overflow, a_max_value);

	control_bit_index = 1;
	a_max_value = pds$eovfl_value;
	go to ecg_join;

hex_exponent_control_get:
     entry (a_restart_underflow, a_restart_overflow, a_max_value);

	control_bit_index = 2;
	a_max_value = pds$hex_eovfl_value;

ecg_join: a_restart_underflow = substr (pds$exp_undfl_rest, control_bit_index, 1);
	a_restart_overflow = substr (pds$exp_ovfl_rest, control_bit_index, 1);
	return;

exponent_control_set:
     entry (a_restart_underflow, a_restart_overflow, a_max_value, a_code);

	control_bit_index = 1;
	go to ecs_join;

hex_exponent_control_set:
     entry (a_restart_underflow, a_restart_overflow, a_max_value, a_code);

	control_bit_index = 2;

ecs_join: val = level$get ();				/* get validation level */
	if val > pds$initial_ring then do;
	     a_code = error_table_$action_not_performed;
	     return;
	end;

	a_code = 0;
	restart_overflow = a_restart_overflow;
	restart_underflow = a_restart_underflow;
	max_value = a_max_value;

/* **********************************************************
   *   That copy may seem superfluous, but if someday	*
   *   anybody else wants to actually do something with 	*
   *   these values other than just copying them		*
   *   directly into the pds then this assures that they	*
   *   wont accidently introduce a 2 reference security 	*
   *   problem.					*
   ******************************************************** */

	substr (pds$exp_undfl_rest, control_bit_index, 1) = restart_underflow;
	substr (pds$exp_ovfl_rest, control_bit_index, 1) = restart_overflow;
	if control_bit_index = 1 then pds$eovfl_value = max_value;
	else pds$hex_eovfl_value = max_value;
	return;
%page;
/* Per-process control of use of hexadecimal exponent floating point.

   Interpretation of switch values:

   "10"b	-> disable hex exponent
   "11"b     -> enable hex exponent

   All other values ("00"b, "01"b) provide a handy method for determining the
   current value of the switch, or for setting a_code to a known non-zero value.
*/

set_hexfp_control: entry (a_new_hfp_sw, a_old_hfp_sw, a_code);

	new_hfp_sw = a_new_hfp_sw;			/* copy input arg */
	a_old_hfp_sw = "1"b || pds$hfp_exponent_enabled;	/* whip this out right away */
	val = level$get ();				/* get validation level */
	if val > pds$initial_ring |			/* got the oomph? */
	     substr (new_hfp_sw, 1, 1) ^= "1"b then do;	/* got the style? */
	     a_code = error_table_$action_not_performed;	/* sorry, kid. */
	     return;
	end;
	if substr (new_hfp_sw, 2, 1) = pds$hfp_exponent_enabled then do; /* no change */
	     a_code = 0;				/* hardcoresse oblige */
	     return;
	end;
	if substr (new_hfp_sw, 2, 1) = "1"b then do;	/* wants to turn it on */
	     if ^sys_info$hfp_exponent_available then do; /* smart boy wanted */
		a_code = error_table_$action_not_performed;
		return;
	     end;
	     call status_$get_user_raw_mode (acs_dir, acs_seg, "", hfp_raw_mode, a_code);
	     if a_code ^= 0
		then do;
		a_code = error_table_$action_not_performed;
		return;
	     end;

	     if (hfp_raw_mode & RW_ACCESS) = RW_ACCESS	/* has access to acs segment */
		then pds$hfp_exponent_enabled = "1"b;
	     else do;
		a_code = error_table_$action_not_performed;
		return;
	     end;
	end;

	else pds$hfp_exponent_enabled = ""b;		/* turn it off */


	a_code = 0;				/* no objections */
	call pmut$load_mode_reg;			/* zap - last of that exponent base */
	return;


%page;	%include access_mode_values;

     end;




		    limit_covert_channel.pl1        11/11/89  1101.2r   11/11/89  0806.0       51138



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
limit_covert_channel: proc (event_count);

/* Procedure to limit/audit uses of covert channels in ring 0.
The idea is that some primitive detected the potential use of a covert
channel that sent <event_count> events (bits).  This will be added to
pds$covert_event_count.  If the process hits a defined limit of events,
we determine the bandwidth of the transmission associated with the
events we have seen.  If this exceeds certain limits, the process will
be delayed, and possibly audited for the event.
Written by Keith Loepere in Januray 1985. 
*/

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

/* Arguments */

dcl  event_count			fixed bin parameter;

/* Constants */

dcl  BIG_fb_35_value		fixed bin (35) init (011111111111111111111111111111111111b) static options (constant);
dcl  ME				char (20) init ("limit_covert_channel") static options (constant);
dcl  Tics_per_sec			fixed bin (20) init (1000000) static options (constant);

/* Variables */

dcl  delay_time			fixed bin (71);
dcl  desired_event_count		fixed bin;
dcl  elapsed_time			fixed bin (71);
dcl  limit			bit (1) aligned;
dcl  my_audit_event_flags		bit (36) aligned;
dcl  new_event_count		fixed bin;
dcl  old_event_count		fixed bin;
dcl  time_per_bit			fixed bin (35);

/* Entries */

dcl  access_audit_$log_general	entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, char (*), fixed bin (35), ptr, fixed bin (21)) options (variable);
dcl  pxss$pause			entry (fixed bin (71));

/* External */

dcl  access_operations_$excessive_seg_state_chg bit (36) aligned ext;
dcl  pds$covert_event_count		fixed bin ext;
dcl  pds$first_covert_event_time	fixed bin (71) ext;
dcl  sst$audit_seg_state_change_bw	fixed bin ext;
dcl  sst$audit_seg_state_chg		fixed bin (35) ext;
dcl  sst$delayed_seg_state_chg	fixed bin (35) ext;
dcl  sst$max_seg_state_change_bw	fixed bin ext;
dcl  sst$seg_state_change_limit	fixed bin ext;
dcl  sst$seg_state_chg_delay		fixed bin (71) ext;

/* Misc */

dcl  (addr, clock, divide, null, stacq)	builtin;
%page;

/* We start by setting pds$covert_event_count to its correct value.  In
principle, this should be done under the PTL, since page control can
increment this value if we should take the wrong page fault.  However,
we can set this without locking the PTL as follows.  We determine what the
value should be and try to stacq it.  If we fail, page control must have
done its thing.  We then retry.  Admitedly, we can end up with page control
being invoked between when we set pds$covert_event_count and when we set
pds$first_covert_event_time, but, if we were to need to advance 
pds$first_covert_event_time, it follows that we returned pds$covert_event_count
to such a small value that it is unlikely that page control could find enough
events to need to care about pds$first_covert_channel_time until we can set
it. */

SET_count:
	limit = "0"b;
	old_event_count = pds$covert_event_count;
	desired_event_count, new_event_count = old_event_count + event_count;
	if desired_event_count >= 0 then do;		/* enough to determine bandwidth over */
	     limit = "1"b;
	     new_event_count = new_event_count - sst$seg_state_change_limit; /* counter is an upward counter to 0 */
	end;
	if ^set_event_count () then go to SET_count;	/* try setting new event count */

	if ^limit then return;			/* not yet hit number of events over which we determine bandwidth */

/* determine bandwidth of channel - this code parallels that in page_fault */

	elapsed_time = clock () - pds$first_covert_event_time;
	if elapsed_time > BIG_fb_35_value then go to set_time; /* bailout to avoid messy precision later */
	time_per_bit = divide (fixed (elapsed_time, 35), desired_event_count + sst$seg_state_change_limit, 35);

	if time_per_bit * sst$audit_seg_state_change_bw < Tics_per_sec then do; /* if time_per_bit < allowed time_per_bit */
	     sst$audit_seg_state_chg = sst$audit_seg_state_chg + 1;
	     my_audit_event_flags = "0"b;
	     addr (my_audit_event_flags) -> audit_event_flags.grant = "1"b;
	     addr (my_audit_event_flags) -> audit_event_flags.cc_10_100 = "1"b;
	     call access_audit_$log_general (ME, 0, my_audit_event_flags, access_operations_$excessive_seg_state_chg, "", 0, null, 0);
	end;

	if time_per_bit * sst$max_seg_state_change_bw < Tics_per_sec then do; /* if time_per_bit < allowed time_per_bit */
	     sst$delayed_seg_state_chg = sst$delayed_seg_state_chg + 1;
	     delay_time = (divide (Tics_per_sec, sst$max_seg_state_change_bw, 35) - time_per_bit) * (desired_event_count + sst$seg_state_change_limit);
	     sst$seg_state_chg_delay = delay_time + sst$seg_state_chg_delay;
	     delay_time = delay_time + clock ();
	     do while (clock () < delay_time);
		call pxss$pause (delay_time);
	     end;
	end;

set_time: pds$first_covert_event_time = clock ();
	return;
%page;
set_event_count: proc () returns (bit (1) aligned);	/* try to store new event_count */

dcl  new_value			bit (36) aligned based (addr (new_event_count));
dcl  old_value			bit (36) aligned based (addr (old_event_count));
dcl  word				bit (36) aligned based (addr (pds$covert_event_count));

	return (stacq (word, new_value, old_value));
     end;
%page; %include access_audit_eventflags;
     end;




		    lock.pl1                        11/11/89  1101.2rew 11/11/89  0805.5      312606



/****^  ***********************************************************
        *                                                         *
        * 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(87-03-31,Fawcett), approve(87-04-23,MCR7672),
     audit(87-04-23,Farley), install(87-04-28,MR12.1-1028):
     Corrected dir_unlock_given_uid to use "ind".  Put the mylock check in
     LOCK_FAST into the stac do loop to possibly avoid a missed cache write
     notify on lock.pid.  Added VALIDATE_CACHE  internal proc to insure that
     the  cache and memory contents of lock_count and highset_in_use are the
     same and detect any differences.
                                                   END HISTORY COMMENTS */


/* format: style3 */

lock:
     procedure;

/* format: off */

/* *	LOCK - ring zero primitive for shared data base locking.
   *
   *	This procedure supplies a number of entry points for manipulating
   *	locks.  Its coding is dependent on the read-alter-rewrite ability
   *	provided by the STAC and STACQ instructions.
   *
   *	The following entry points are available for setting a lock:
   *
   *	  lock$try -
   *
   *	    declare lock$try external entry (ptr, fixed bin(35), fixed bin(35), fixed bin(1));
   *	    call lock$try (lock_ptr, event, code, failsw);
   *
   *	  lock$wait -
   *
   *	    declare lock$wait external entry (ptr, fixed bin(35), fixed bin(35));
   *	    call lock$wait (lock_ptr, event, code);
   *
   *	  lock$dir_wait -
   *
   *	    declare lock$dir_wait external entry (ptr, bit(36) aligned, fixed bin(35));
   *	    call lock$dir_wait (dp, typelock,  code);
   *
   *	  lock$dir_try -
   *
   *	    declare lock$dir_try external entry (ptr, bit(36) aligned, fixed bin(35), fixed bin(1));
   *	    call lock$dir_try (dp, typelock, code, failsw);
   *
   *	Where -
   *	  lock_ptr	     is a pointer to the lock to be set. (Input)
   *	  dp	     is a pointer to the directory whose lock is to be set. (Input)
   *	  typelock     = "0"b if locked for read, = "1"b if locked for write. (Input)
   *	  code	     is a standard error code. (Output)
   *	  event	     is the event to be waited for if the lock cannot be set. (Input)
   *	  failsw	     = 0 if lock was set, = 1 if unable to set lock. (Output)
   *
   *        lock$dir_lock_(read write) -
   *           declare lock$dir_lock_(write read) entry (ptr, fixed bin (35));
   *           call lock$dir_lock_(write read) (dp, code);
   *
   *          These entries crash on mylock, and trust dir.uid, and salvage
   *          the directory under certain circumstances. They do wait for the lock.
   *
   *           lock$dir_lock_salvage -
   *
   *             declare lock$dir_lock_salvage entry (ptr, bit (36) aligned,
   *                 fixed bin (35));
   *             call lock$dir_lock_salvage (dp, uid, code);
   *
   *           This SIDE-DOOR for the salvager :
   *	     1) derives the UID for locking from the kst, not dir.uid.
   *           2) returns mylock rather than crashing
   *           3) takes a write lock.
   *           4) returns the UID used for locking
   *
   *
   *	The following entry points are available for unlocking a lock:
   *
   *        lock$dir_unlock_given_uid -
   *
   *	    declare lock$dir_unlock_given_uid
   *                external entry (bit (36) aligned);
   *	    call lock$dir_unlock_given_uid (dir_uid);
   *
   *        This entrypoint is for use when the contents of the directory
   *         are untrustworthy.  Primarily for the salvager.
   *
   *        lock$dir_unlock -
   *
   *        declare lock$dir_unlock entry (pointer);
   *         call lock$dir_unlock (dp);
   *
   *        This is the ordinary dir-unlocker.

   *
   *	  lock$unlock -
   *
   *	    declare lock$unlock external entry (ptr, fixed bin(35));
   *	    call lock$unlock (lock_ptr, event);
   *
   *	Where -
   *	  lock_ptr	     is a pointer to the lock to be unlocked. (Input)
   *	  dp	     is a pointer to the directory to be unlocked. (Input)
   *	  event	     is the event to be signalled after resetting the lock. (Input)
   *
   *
   *	Modifications:
   *	20 Apr 1975, Andre Bensoussan: Rewritten for the new storage system.
   *	23 Sep 1975, Andre Bensoussan: Move call to caller() from internal proc to beginning of each entry point.
   *	24 Sep 1975, Andre Bensoussan: dir.modify is no longer reset to 0 by unlock_dir.
   *	   Also the entry lock$modify_dir has been eliminated.
   *	   Added new entries for lock_ast and unlock_ast.
   *	25 Feb 1976, RE Mullen: Added ast lock metering code.
   *	13 Jul 1978, B. Greenberg: Changed not to DIRW per-process dirs, and clock and stacq bifs.
   *	13 Feb 1980, M. Grady: fixed race condition with lock_dir and on_line_salvager.
   *	10 Aug 1981, W. Olin Sibert: changed lock_dir to validate UID in dir header vs. UID in KSTE,
   *	   changes for external static SST, and, *sigh*, format_pl1'd it.
   *      21 Nov 1981, J. Bongiovanni for ast lock metering
          Dec 81/Jan 82, Benson I. Margulies, multiple reader dir locks.
   *      2/82 BIM for salvager dir sidedoors.
   *	7 August 1982, J. Bongiovanni, don't stash AST locks in pds$lock_array,
   *	         meter AST locking conditionally
   *	Modified 830111 BIM to improve interactions of locking and salvaging.
   *	13 January 1983, J. Bongiovanni, to fix some races and add a trap
   *      Modified 830118 BIM to try again to find the race.
   *      Modified 830817 BIM to use salvage_entry not salvage_sw.
   *      Modified 831107 BIM to make array of dir locks quick to reference.
   *      Modified 831110 BIM to revert to heap strategy for dir locks.
   *	Modified 841102 KPL to fix dirw and to improve its efficiency.
   */


/* format: on */

dcl	prds$processor_tag	ext fixed bin (3);
dcl	absadr		entry (ptr, fixed bin (35)) returns (fixed bin (26));
dcl	CPU_NAMES		char (8) aligned internal static options (constant) init ("abcdefgh");
dcl	a_lock_ptr	pointer parameter;		/* Arguments - pointer to lock */
dcl	a_dp		pointer parameter;		/* pointer to directory */
dcl	a_ind		bit (36) aligned parameter;	/* wait event for lock */
dcl	a_typelock	bit (36) aligned parameter;	/* = "0"b if read lock, = "1"b if write lock */
dcl	a_code		fixed bin (35) parameter;	/* standard error code */
dcl	a_failsw		fixed bin (1) parameter;	/* = 1 if try lock failed */
dcl	a_dir_uid		bit (36) aligned;		/* returned to salvager */

dcl	per_process_flag	bit (1);
dcl	must_salvage	bit (1) aligned;
dcl	ind		bit (36) aligned;		/* wait event for lock */
dcl	caller_ptr	pointer;			/* pointer to where we were called from (+1) */
dcl	dir_uid		bit (36) aligned;		/* global var set by LOCK_DIR_SALVAGE */
dcl	code		fixed bin (35);		/* code set by internal procedure LOCK */
dcl	failsw		fixed bin (1);
dcl	(time_in, time_out) fixed bin (52);		/* temporaries for ast lock metering */

dcl	seg_fault_error	condition;

dcl	error_table_$mylock fixed bin (35) external static;
dcl	error_table_$dir_damage
			fixed bin (35) external static;
dcl	error_table_$notadir
			fixed bin (35) ext static;

dcl	sst$ast_locked_at_time
			fixed bin (71) external static;
dcl	sst$ast_locked_total_time
			fixed bin (71) external static;
dcl	sst$ast_locking_count
			fixed bin (35) external static;
dcl	sst$ast_lock_wait_time
			fixed bin (71) external static;
dcl	sst$astl		bit (36) aligned external static;
dcl	sst$dirlock_writebehind
			fixed bin external static;
dcl	sst$lock_waits	fixed bin (35) external static;
dcl	sst$meter_ast_locking
			fixed bin external static;
dcl	tc_data$lock_error_severity
			fixed bin external static;

dcl	pds$block_lock_count
			fixed bin external static;	/* count of locks set to this process */
dcl	pds$processid	bit (36) aligned external static;
dcl	tc_data$system_shutdown
			fixed bin external static;	/* for determining whether to force the lock */

dcl	caller		entry returns (pointer);	/* returns a pointer to our caller */
dcl	get_kstep		entry (fixed bin, pointer, fixed bin (35));
dcl	meter_ast_lock$lock entry;
dcl	meter_ast_lock$unlock
			entry;
dcl	on_line_salvager	entry (pointer, fixed bin (35));
dcl	pxss$addevent	entry (bit (36) aligned);
dcl	pxss$delevent	entry (bit (36) aligned);
dcl	pxss$notify	entry (bit (36) aligned);
dcl	pxss$wait		entry;
dcl	syserr		entry options (variable);
dcl	update_vtoce	entry (pointer);

dcl	(addr, baseno, binary, clock, hbound, max, null, segno, stac, stacq, substr, unspec)
			builtin;


try:
     entry (a_lock_ptr, a_ind, a_code, a_failsw);

	caller_ptr = caller ();
	call LOCK (a_lock_ptr, a_ind, a_code, a_failsw, 0 /* waitsw */);
	return;

wait:
     entry (a_lock_ptr, a_ind, a_code);

	caller_ptr = caller ();
	call LOCK (a_lock_ptr, a_ind, a_code, failsw, 1 /* waitsw */);
	return;

unlock:
     entry (a_lock_ptr, a_ind);

	caller_ptr = caller ();
	call UNLOCK (a_lock_ptr, a_ind);
	return;




lock_fast:
     entry (a_lock_ptr);
	caller_ptr = caller ();
	call LOCK_FAST (a_lock_ptr);
	return;

unlock_fast:
     entry (a_lock_ptr);
	caller_ptr = caller ();
	call UNLOCK_FAST (a_lock_ptr);
	return;


lock_ast:
     entry;
	caller_ptr = caller ();
	time_in = clock ();
	call LOCK_FAST (addr (sst$astl));
	if sst$meter_ast_locking ^= 0
	then call meter_ast_lock$lock;
	time_out = clock ();
	sst$ast_lock_wait_time = sst$ast_lock_wait_time + time_out - time_in;
	sst$ast_locked_at_time = time_out;
	sst$ast_locking_count = sst$ast_locking_count + 1;
	return;


unlock_ast:
     entry;
	caller_ptr = caller ();
	sst$ast_locked_total_time = sst$ast_locked_total_time - sst$ast_locked_at_time + clock ();
	if sst$meter_ast_locking ^= 0
	then call meter_ast_lock$unlock;
	call UNLOCK_FAST (addr (sst$astl));
	return;

%page;

dir_wait:
     entry (a_dp, a_typelock, a_code);

	caller_ptr = caller ();
	call LOCK_DIR (a_dp, a_typelock, a_code, failsw, 1 /* waitsw */);

	return;

dir_try:
     entry (a_dp, a_typelock, a_code, a_failsw);

	caller_ptr = caller ();
	call LOCK_DIR (a_dp, a_typelock, a_code, a_failsw, 0 /* waitsw */);
	return;

dir_unlock:
     entry (a_dp);

	caller_ptr = caller ();
	ind = a_dp -> dir.uid;
	call UNLOCK_DIR (a_dp, ind);
	return;

dir_unlock_given_uid:
     entry (a_dir_uid);

	caller_ptr = caller ();
	ind = a_dir_uid;
	call UNLOCK_DIR_NOCHECK (null, ind);
	return;


dir_lock_read:
     entry (a_dp, a_code);

	caller_ptr = caller ();
	call LOCK_DIR (a_dp, (36)"0"b, a_code, failsw, 1 /* waitsw */);
	if a_code = error_table_$mylock
	then call syserr (CRASH, "lock: dir_lock_read mylock err. dp =^p", a_dp);
	return;

dir_lock_write:
     entry (a_dp, a_code);

	caller_ptr = caller ();
	call LOCK_DIR (a_dp, (36)"1"b, a_code, failsw, 1 /* waitsw */);
	if a_code = error_table_$mylock
	then call syserr (CRASH, "lock: dir_lock_write mylock err. dp =^p", a_dp);
	return;

dir_lock_salvage:
     entry (a_dp, a_dir_uid, a_code);

	caller_ptr = caller ();
	dir_uid = ""b;
	call LOCK_DIR_SALVAGE (a_dp, (36)"1"b, a_code, failsw, 1 /* waitsw */);
						/* Always locks for write */
	a_dir_uid = dir_uid;
	return;

%page;

LOCK:
     procedure (lock_ptr, ind, code, failsw, waitsw);

dcl	lock_ptr		ptr,
	ind		bit (36) aligned,
	code		fixed bin (35),
	failsw		fixed bin (1),
	waitsw		fixed bin (1);

dcl	lwd		bit (36) aligned based (lock_ptr);

	code = 0;
	failsw = 0;

	if tc_data$system_shutdown ^= 0
	then return;

	if lwd = pds$processid
	then do;
		code = error_table_$mylock;
		goto POST;
	     end;

	pds$block_lock_count = pds$block_lock_count + 1;

	do while (^stac (lock_ptr, pds$processid));
	     if waitsw = 0
	     then do;
		     failsw = 1;
		     pds$block_lock_count = pds$block_lock_count - 1;
		     goto POST;
		end;

	     call pxss$addevent (ind);

	     if lwd = "0"b
	     then call pxss$delevent (ind);
	     else do;
		     call pxss$wait;
		     sst$lock_waits = sst$lock_waits + 1;
		end;
	end;

POST:
	return;

     end LOCK;

%page;

UNLOCK:
     procedure (lock_ptr, ind);

dcl	lock_ptr		ptr,
	lwd		bit (36) aligned based (lock_ptr),
	ind		bit (36) aligned;



	code = 0;
	failsw = 0;

	if tc_data$system_shutdown ^= 0
	then return;				/* system shutdown ? */


	if pds$block_lock_count <= 0
	then do;
		call syserr (tc_data$lock_error_severity, "lock: pds$block_lock_count <= 0. caller = ^p.", caller ());
		pds$block_lock_count = 0;
	     end;

	if ^stacq (lwd, "000000000000"b3, pds$processid)
	then do;
		call syserr (tc_data$lock_error_severity, "lock: lock ^p not equal to processid. caller = ^p",
		     addr (lwd), caller ());
		goto FORGET_RETURN;
	     end;

	if lwd = pds$processid			/* Always crash if the hardware craps */
	then call syserr (CRASH, "lock: stacq hardware failure on ^p", lock_ptr);
	call pxss$notify (ind);			/* tell the world */

FORGET_RETURN:
	pds$block_lock_count = pds$block_lock_count - 1;

	return;

     end UNLOCK;

%page;

LOCK_FAST:
     proc (lock_ptr);


%include hc_lock;
/* the ptr in here becomes a parameter */

	if tc_data$system_shutdown ^= 0
	then return;

	do while (^stac (addr (lock.pid), pds$processid));
	     if lock.pid = pds$processid
	     then call syserr (CRASH, "lock: lock_fast mylock err ^p", lock_ptr);
	     lock.notify_sw = "1"b;
	     call pxss$addevent (lock.event);
	     if (lock.pid ^= "0"b & lock.notify_sw = "1"b)
	     then call pxss$wait;
	     else call pxss$delevent (lock.event);
	end;

	pds$block_lock_count = pds$block_lock_count + 1;
	return;

     end LOCK_FAST;

%page;

UNLOCK_FAST:
     proc (lock_ptr);

%include hc_lock;
/* the ptr in here becomes the parameter */


	if tc_data$system_shutdown ^= 0
	then return;

	if ^stacq (lock.pid, "000000000000"b3, pds$processid)
	then do;
		call syserr (tc_data$lock_error_severity,
		     "lock: unlock_fast lock ^p not locked to process. caller = ^p.", lock_ptr, caller ());
		return;
	     end;
	if lock.pid = pds$processid
	then call syserr (CRASH, "lock: stacq hardware failure on ^p", lock_ptr);

	if lock.notify_sw
	then do;
		lock.notify_sw = "0"b;
		call pxss$notify (lock.event);
	     end;
	pds$block_lock_count = pds$block_lock_count - 1;
	return;

     end UNLOCK_FAST;

%page;

LOCK_DIR:
     procedure (dirp, typelock, code, failsw, waitsw);

dcl	dirp		ptr;
dcl	typelock		bit (36) aligned;
dcl	code		fixed bin (35);
dcl	failsw		fixed bin (1);
dcl	waitsw		fixed bin (1);

dcl	get_kstep_code	fixed bin (35);
dcl	salvage_entry	bit (1) aligned;
dcl	severity		fixed bin;
dcl	uid_to_lock	bit (36) aligned;
dcl	dir_lockx		fixed bin;

	salvage_entry = "0"b;
	go to LOCK_START;

LOCK_DIR_SALVAGE:
     entry (dirp, typelock, code, failsw, waitsw);

	salvage_entry = "1"b;

LOCK_START:
	code = 0;
	failsw = 0;

	if tc_data$system_shutdown ^= 0
	then return;

	dir_lock_segp = addr (dir_lock_seg$);
	dir_lock_all_locksp = dir_lock_seg.header.locks_ptr;
	dir_lock_all_readersp = dir_lock_seg.header.readers_ptr;

	call get_kstep (segno (dirp), kstep, get_kstep_code);
						/* The code is nonzero for fake dirs -- */
						/* happens if dirp is a hardcore segment (stack_0) */
	if salvage_entry
	then do;
		if get_kstep_code ^= 0		/* needed for salvaging */
		then do;
			code = get_kstep_code;
			return;
		     end;
		if ^kste.dirsw
		then do;				/* Not a dir? */
			code = error_table_$notadir;
			return;
		     end;
		dir_uid = kste.uid;
	     end;

RELOCK:
	if salvage_entry
	then uid_to_lock = dir_uid;			/* The REAL uid, rather than what was recorded inside the dir */
	else uid_to_lock = dirp -> dir.uid;		/* let a seg_fault happen here */


/****
Here, we make sure that the UID in the directory matches the UID in the
kste, which, perforce, must have been derived from the branch at some time in
the past.  This check is skipped, however, if we find that the "directory" is
actually in a non-directory segment, since the supervisor occasionally
constructs imitation directory headers in automatic storage just so it can
lock with the right UID.  If the UID's fail to match, then the dir is 
salvaged. If we are called from the salvager, though, we skip all this.
*****/

	if ^salvage_entry
	then do;
		must_salvage = "0"b;
		if (dirp -> dir.uid = ""b)		/* Cannot be correct */
		then must_salvage = "1"b;
		else if (get_kstep_code = 0)
		then /* means segno is valid, and hence kstep is valid */
		     if kste.dirsw
		     then /* only check directories */
			if (dirp -> dir.uid ^= kste.uid)
			then must_salvage = "1"b;

		if must_salvage			/* Flunked the test */
		then do;				/* Neither the dir not dir_lock_seg is locked
here */
			call LOCK_FOR_SALVAGE_AND_SALVAGE (dirp, code);
						/* they will be locked and unlocked here. */
			if code = 0 & dirp -> dir.uid ^= ""b
			then go to RELOCK;		/* Dir is still valid */
			code = error_table_$dir_damage;
						/* dir went west */
			return;
		     end;				/** salvage case */
	     end;

/************************ LOCK DIR LOCK SEG *********************************/


	call LOCK_FAST (dir_lock_segp);

	dir_lockx = FIND_OR_MAKE_DIR_LOCK (uid_to_lock);
	dir_lockp = addr (dir_lock_all_dir_locks (dir_lockx));

	call VALIDATE_CACHE (addr (dir_lock.lock_count)); /* ensure cache is correct */

	if dir_lock.lock_count > 0
	then do;					/** Write Lock Locked */
		if dir_lock.write_locker ^= pds$processid
						/* Not Us */
		then go to LOCK_NOT_AVAILABLE;	/* common to read vs. write and write vs. write. */
		else go to MYLOCK_RETURN;
	     end;
	else do;					/* Read or no lock */
		dir_read_lockers_ptr = addr (dir_lock_all_readers (dir_lockx, 1));
		if THIS_PROCESS_IS_A_READER (dir_lockp, dir_read_lockers_ptr)
						/* some kind of mylock */
		then do;				/* we do not know a recovery mechanism for this one. */
			if typelock ^= ""b		/* We want write */
			then do;
				severity = tc_data$lock_error_severity;
				if severity ^= CRASH
				then severity = TERMINATE_PROCESS;

				call syserr (severity,
				     "lock: LOCK_DIR: write lock call with read lock held. dp = ^p, uid = ^w.",
				     dirp, uid_to_lock);
			     end;			/* Control never passes here */
			else go to MYLOCK_RETURN;	/* simple read mylock */
		     end;

		if /* tree */ typelock ^= ""b		/* want write ? */
		then if dir_lock.lock_count ^= 0	/* locked for read */
		     then goto LOCK_NOT_AVAILABLE;	/* wait for it */
		     else call LOCK_FOR_WRITE (dir_lockp);
		else call ADD_THIS_PROCESS_AS_READER (dir_lockp, dir_read_lockers_ptr);
						/* no, want read */
	     end;

/******* UNLOCK DIR LOCK SEG *********************************************/



UNLOCK_DIR_LOCK_SEG_RETURN:
	call UNLOCK_FAST (dir_lock_segp);

	if ^salvage_entry
	then if dirp -> dir.modify
	     then if code = 0
		then do;
			call dir_unlock (dirp);
			call LOCK_FOR_SALVAGE_AND_SALVAGE (dirp, code);
			if code = 0
			then go to RELOCK;
		     end;
	return;

/****** The following paths return to UNLOCK_DIR_LOCK_SEG_RETURN *****/


MYLOCK_RETURN:
	code = error_table_$mylock;
	go to UNLOCK_DIR_LOCK_SEG_RETURN;


LOCK_NOT_AVAILABLE:
	if waitsw = 0
	then do;
		failsw = 1;
		go to UNLOCK_DIR_LOCK_SEG_RETURN;
	     end;

/********** Waiting is required, wait. */

	call pxss$addevent (uid_to_lock);
	dir_lock.notify_sw = "1"b;
	call UNLOCK_FAST (dir_lock_segp);
	call pxss$wait;				/* since we set notify under the lock, there is no race. */
	sst$lock_waits = sst$lock_waits + 1;
	goto LOCK_START;				/* Anything can happen, so revalidate */


THIS_PROCESS_IS_A_READER:
     procedure (a_dir_lockp, a_dir_readersp) returns (bit (1) aligned);

declare	a_dir_lockp	pointer;
declare	a_dir_readersp	pointer;
declare	l_dir_readersp	pointer;
declare	l_dir_readers	(dir_lock_seg.header.max_readers) bit (36) aligned based (l_dir_readersp);
declare	rx		fixed bin;		/* ReaderIndex */


	if a_dir_lockp -> dir_lock.lock_count = 0
	then return ("0"b);
	l_dir_readersp = a_dir_readersp;
	do rx = 1 to dir_lock_seg.header.max_readers;
	     if l_dir_readers (rx) = pds$processid
	     then return ("1"b);
	end;
	return ("0"b);
     end THIS_PROCESS_IS_A_READER;


FIND_OR_MAKE_DIR_LOCK:
     procedure (a_UID) returns (fixed bin);

declare	a_UID		bit (36) aligned;
declare	UID		bit (36) aligned;
declare	dx		fixed bin;
declare	first_free_dx	fixed bin;
declare	l_dir_lockp	pointer;
declare	1 l_dir_lock	aligned like dir_lock based (l_dir_lockp);
declare	l_dir_readersp	pointer;
declare	find_only		bit (1) aligned;

	find_only = "0"b;
	go to Join;

FIND_DIR_LOCK:
     entry (a_UID) returns (fixed bin);

	find_only = "1"b;

Join:
	UID = a_UID;
	first_free_dx = 0;
	dir_lock_seg.header.meters.find_calls = dir_lock_seg.header.find_calls + 1;

	call VALIDATE_CACHE (addr (dir_lock_seg.header.highest_in_use));
						/* ensure cache is correct */
	do dx = 1 to dir_lock_seg.header.highest_in_use;
	     if dir_lock_all_dir_locks (dx).uid = UID
	     then go to FOUND_ENTRY;
	     else if dir_lock_all_dir_locks (dx).uid = (36)"0"b & first_free_dx = 0
	     then first_free_dx = dx;
	end;

	dir_lock_seg.header.meters.find_failures = dir_lock_seg.header.meters.find_failures + 1;
	if find_only
	then return (-1);


	if first_free_dx = 0
	then do;
		if dir_lock_seg.header.highest_in_use = dir_lock_seg.header.n_dir_locks
		then call syserr (CRASH, "lock: LOCK_DIR: dir_lock_seg full.");
		dir_lock_seg.header.highest_in_use, first_free_dx = dir_lock_seg.header.highest_in_use + 1;
		dir_lock_seg.header.meters.max_in_use = max (dir_lock_seg.header.meters.max_in_use, first_free_dx);
	     end;

	l_dir_lockp = addr (dir_lock_all_dir_locks (first_free_dx));
	unspec (l_dir_lock) = ""b;
	l_dir_readersp = addr (dir_lock_seg.readers (first_free_dx, 1));
	l_dir_readersp -> dir_read_lockers (*) = ""b;

	l_dir_lock.uid = a_UID;
	return (first_free_dx);

FOUND_ENTRY:
	l_dir_lockp = addr (dir_lock_all_dir_locks (dx));
	return (dx);
     end FIND_OR_MAKE_DIR_LOCK;

LOCK_FOR_WRITE:
     procedure (a_dir_lockp);

declare	a_dir_lockp	pointer;
declare	l_dir_lockp	pointer;
declare	1 l_dir_lock	aligned like dir_lock based (l_dir_lockp);
declare	rx		fixed bin;

	l_dir_lockp = a_dir_lockp;
	l_dir_lock.write_locker = pds$processid;
	l_dir_lock.lock_count = 1;
	l_dir_lock.notify_sw = "0"b;
	l_dir_lock.salvage_sw = salvage_entry;		/* GLOBAL */
	pds$block_lock_count = pds$block_lock_count + 1;
	return;

ADD_THIS_PROCESS_AS_READER:
     entry (a_dir_lockp, a_dir_readersp);

declare	a_dir_readersp	pointer;
declare	l_dir_readersp	pointer;
declare	l_dir_readers	(dir_lock_seg.header.max_readers) bit (36) aligned based (l_dir_readersp);

	l_dir_lockp = a_dir_lockp;
	l_dir_readersp = a_dir_readersp;
	do rx = 1 to hbound (l_dir_readers, 1) while (l_dir_readers (rx) ^= ""b);
	end;
	if rx > hbound (l_dir_readers, 1)
	then call syserr (CRASH, "lock: LOCK_DIR: Too many readers.");

	call VALIDATE_CACHE (addr (l_dir_lock.lock_count));
						/* ensure cache is correct */
	l_dir_lock.lock_count = l_dir_lock.lock_count - 1;
	l_dir_readers (rx) = pds$processid;
	pds$block_lock_count = pds$block_lock_count + 1;
	return;

UNLOCK_THIS_DIR:
     entry (a_dir_lockx, a_uid);			/* Checks for screwups */

declare	a_dir_lockx	fixed bin;
declare	a_uid		bit (36) aligned;

	l_dir_lockp = addr (dir_lock_all_dir_locks (a_dir_lockx));
	l_dir_readersp = addr (dir_lock_all_readers (a_dir_lockx, 1));
	if l_dir_lock.uid ^= a_uid
	then do;
		call syserr (tc_data$lock_error_severity, "lock: UNLOCK_DIR: UID Mismatch.");
		return;
	     end;

	call VALIDATE_CACHE (addr (l_dir_lock.lock_count));
						/* ensure cache is correct */
	if l_dir_lock.lock_count = 0
	then do;
		call syserr (tc_data$lock_error_severity, "lock: UNLOCK_DIR: lock count 0.");
		return;
	     end;
	else if l_dir_lock.lock_count < 0
	then do;
		do rx = 1 to hbound (l_dir_readers, 1) while (l_dir_readers (rx) ^= pds$processid);
		end;
		if rx > hbound (l_dir_readers, 1)
		then do;
			call syserr (tc_data$lock_error_severity,
			     "lock: UNLOCK_DIR: lock not read locked to process.");
			return;
		     end;
		l_dir_lock.lock_count = l_dir_lock.lock_count + 1;
		l_dir_readers (rx) = ""b;
		if l_dir_lock.notify_sw
		then if l_dir_lock.lock_count = 0
		     then do;
			     l_dir_lock.notify_sw = "0"b;
			     call pxss$notify (l_dir_lock.uid);
			end;
	     end;
	else if l_dir_lock.lock_count > 0
	then do;
		if l_dir_lock.write_locker ^= pds$processid
		then do;
			call syserr (tc_data$lock_error_severity,
			     "lock: UNLOCK_DIR: lock not write locked to process.");
			return;
		     end;
		l_dir_lock.lock_count = 0;
		l_dir_lock.write_locker = ""b;
		if l_dir_lock.notify_sw
		then do;
			l_dir_lock.notify_sw = "0"b;
			call pxss$notify (l_dir_lock.uid);
		     end;
	     end;
	pds$block_lock_count = pds$block_lock_count - 1;
	if (l_dir_lock.lock_count = 0) & (l_dir_lock.uid ^= (36)"1"b)
						/* leave the root at a nice low slot */
	then do;
		unspec (l_dir_lock) = ""b;

		call VALIDATE_CACHE (addr (dir_lock_seg.header.highest_in_use));
						/* ensure cache is correct */
		if a_dir_lockx = dir_lock_seg.header.highest_in_use
		then dir_lock_seg.header.highest_in_use = max (0, dir_lock_seg.header.highest_in_use - 1);
						/* last one out please close the light */
	     end;

	return;
     end LOCK_FOR_WRITE;

LOCK_FOR_SALVAGE_AND_SALVAGE:
     procedure (dir_ptr, code);
declare	dir_ptr		pointer;
declare	correct_uid	bit (36) aligned;
declare	code		fixed bin (35);

	code = 0;
	call dir_lock_salvage (dir_ptr, correct_uid, code);
	if code ^= 0
	then return;

	call on_line_salvager (dir_ptr, code);
	call dir_unlock_given_uid (correct_uid);

	return;
     end LOCK_FOR_SALVAGE_AND_SALVAGE;

%page;

UNLOCK_DIR:
     entry (dirp, a_uid);

dcl	a_uid		bit (36) aligned;

dcl	uid_to_unlock	bit (36) aligned;
dcl	nocheck_entry	bit (1);

dcl	get_ptrs_$given_segno
			entry (fixed bin) returns (ptr);
dcl	pc_wired$write_wait_uid
			entry (ptr, fixed bin, fixed bin, bit (36) aligned);


	nocheck_entry = "0"b;
	go to UNLOCK_START;

UNLOCK_DIR_NOCHECK:
     entry (dirp, a_uid);

	nocheck_entry = "1"b;

UNLOCK_START:
	uid_to_unlock = a_uid;
	if tc_data$system_shutdown ^= 0
	then return;

	dir_lock_segp = addr (dir_lock_seg$);
	dir_lock_all_locksp = dir_lock_seg.header.locks_ptr;
	dir_lock_all_readersp = dir_lock_seg.header.readers_ptr;

	per_process_flag = "0"b;

	if dirp ^= null & ^nocheck_entry
	then begin;

		on seg_fault_error go to DIR_GONE;

		if dirp -> dir.modify
		then call syserr (JUST_LOG, "lock: unlock_dir with dir.modify - uid = ^w - callerp = ^p", ind,
			caller ());
		per_process_flag = dirp -> dir.per_process_sw;
						/* Save for unlocking */
	     end;

DIR_GONE:
	call LOCK_FAST (dir_lock_segp);

	dir_lockx = FIND_DIR_LOCK (uid_to_unlock);

	if dir_lockx = -1
	then call TRY_TO_FIND_A_BETTER_UID;		/* This can change dir_lockx */
						/* and uid_to_unlock */
	if dir_lockx = -1
	then do;
		call syserr (tc_data$lock_error_severity, "lock: UNLOCK_DIR: dir ^w not locked. caller = ^p.", ind,
		     caller ());
		go to UNLOCK_SIDE_RETURN;
	     end;

	call PERHAPS_WRITE_BEHIND (dir_lockx);

	call UNLOCK_THIS_DIR (dir_lockx, uid_to_unlock);

UNLOCK_SIDE_RETURN:
	call UNLOCK_FAST (dir_lock_segp);
	return;




TRY_TO_FIND_A_BETTER_UID:
     procedure;

	if dirp = null ()
	then return;

	call get_kstep (binary (baseno (dirp)), kstep, get_kstep_code);
	if ^(get_kstep_code = 0 & kste.dirsw & kste.uid ^= uid_to_unlock)
	then return;

	uid_to_unlock = kste.uid;
	dir_lockx = FIND_DIR_LOCK (uid_to_unlock);

	call VALIDATE_CACHE (addr (dir_lock_all_dir_locks (dir_lockx).lock_count));
						/* ensure cache is correct */
	if dir_lock_all_dir_locks (dir_lockx).lock_count = 0
	then do;
		dir_lockx = -1;
		return;
	     end;

	call syserr (JUST_LOG, "lock: UNLOCK_DIR: dir ^w unlock called with bad uid, caller = ^p", ind, caller ());
     end TRY_TO_FIND_A_BETTER_UID;


PERHAPS_WRITE_BEHIND:
     procedure (dirx);

declare	dirx		fixed bin;

	if dirp = null ()
	then return;

	if sst$astl = pds$processid
	then call syserr (CRASH, "lock: AST lock set at dir unlock time.");

	if sst$dirlock_writebehind = 0 | per_process_flag
	then return;

	call VALIDATE_CACHE (addr (dir_lock_all_dir_locks (dirx).lock_count));
						/* ensure cache is correct */
	if dir_lock_all_dir_locks (dirx).lock_count < 0
	then return;

	astep = get_ptrs_$given_segno (segno (dirp));
	if astep ^= null
	then do;					/* Writebehind time. */
		call UNLOCK_FAST (dir_lock_segp);	/* force write not under dir_lock_seg lock */

		call pc_wired$write_wait_uid (astep, 0, -1, uid_to_unlock);
		if aste.fmchanged
		then do;				/* Cant be OFF fraudulently */
			call lock_ast;
			if aste.uid = uid_to_unlock
			then call update_vtoce (astep);
			call unlock_ast;
		     end;

		call LOCK_FAST (dir_lock_segp);	/* UNLOCK_THIS_DIR will make sure that dir_lockx still describes uid_to_unlock */
	     end;

     end PERHAPS_WRITE_BEHIND;
     end LOCK_DIR;

VALIDATE_CACHE:
     proc (word_ptr);
dcl	word		based (word_ptr) bit (36) aligned;
dcl	word_ptr		ptr;

	if ^stacq (word, word, word)			/* ensure cache is correct */
	then call syserr (ANNOUNCE, "lock: VALIDATE_CACHE: FAILED running on cpu ^a, memory address ^8o (oct)",
		substr (CPU_NAMES, (prds$processor_tag + 1), 1), absadr (word_ptr, (0)));

     end VALIDATE_CACHE;

/* format: off */
%page; %include hc_lock;
%page; %include dir_lock_seg_;
%page; %include aste;
%page; %include kst;
%page; %include dir_header;
%page; %include syserr_constants;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   lock: dir_lock_read mylock err. dp =PTR

   S: $crash

   T: $run

   M: An attempt to lock a directory for reading found the directory 
   already locked to this process.  This indicates a supervisor 
   programming error.

   A: $reboot

   Message:
   lock: dir_lock_write mylock err. dp =PTR

   S: $crash

   T: $run

   M: An attempt to lock a directory for writing found the directory
   already locked to this process.  This indicates a supervisor 
   programming error.

   A: $reboot

   Message:
   lock: pds$block_lock_count <= 0. caller = PTR

   S: $lock_severity

   T: $run

   M: An attempt to unlock a lock found that the process was holding no 
   locks.  This indicates a supervisor programming error.

   A: $reboot

   Message:
   lock: lock PTR not equal to processid. caller = PTR

   S: $lock_severity

   T: $run

   M: An attempt was made to unlock a lock found not to be held by this
   process.  This indicates a supervisor programming error.

   A: $reboot

   Message:
   lock: stacq hardware failure on PTR

   S: $crash

   T: $run

   M: The hardware failed to unlock the specified lock using a stacq 
   instruction.

   A: Fix the hardware.

   Message:
   lock: lock_fast mylock err PTR

   S: $crash

   T: $run

   M: An attempt to lock a fast lock found the lock already locked to
   the requesting process.  This indicates a supervisor programming 
   error.

   A: $reboot

   Message:
   lock: unlock_fast lock PTR not locked to process. caller = PTR

   S: $lock_severity

   T: $run

   M: An attempt to unlock a fast lock found that the lock was not held
   by the requesting process.  This indicates a supervisor 
   programming error.

   A: $reboot

   Message:
   lock: LOCK_DIR: write lock call with read lock held. dp = PTR, uid = UID.

   S: $term

   T: $run

   M: A request was made to lock a directory for writing when the process
   already possessed a read lock on that directory.  This indicates a 
   supervisor programming error.

   A: $reboot

   Message:
   lock: LOCK_DIR: dir_lock_seg full.

   S: $crash

   T: $run

   M: The segment used to record all locked directories overflowed.
   This may be a hardware problem.

   A: $reboot

   Message:
   lock: LOCK_DIR: Too many readers.

   S: $crash

   T: $run

   M: Too many processes attempted to request a read lock on a given 
   directory.  This may indicate a hardware problem.

   A: $reboot

   Message:
   lock: UNLOCK_DIR: UID Mismatch.

   S: $lock_severity

   T: $run

   M: When attempting to unlock a directory, the UID for the directory
   found in the dir_lock_seg entry did not match that of the directory.

   A: $reboot

   Message:
   lock: UNLOCK_DIR: lock count 0.

   S: $lock_severity

   T: $run

   M: An attempt to unlock a directory found the dir_lock_seg entry for
   the directory not listing the directory as locked.

   A: $reboot

   Message:
   lock: UNLOCK_DIR: lock not read locked to process.

   S: $lock_severity

   T: $run

   M: A request to unlock a directory locked for reading found that the
   requesting process was not holding the directory locked.

   A: $reboot

   Message:
   lock: UNLOCK_DIR: lock not write locked to process.

   S: $lock_severity

   T: $run

   M: A request to unlock a directory that was found to be locked for
   writing was not locked to this process.

   A: $reboot

   Message:
   lock: unlock_dir with dir.modify - uid = UID - callerp = PTR

   S: $log

   T: $run

   M: A directory being unlocked appears to have been undergoing
   a modification sequence that has not completed.

   A: The next reference to the directory will force a directory salvage.

   Message:
   lock: UNLOCK_DIR: dir DIR_LOCK_IND not locked. caller = PTR.

   S: $lock_severity

   T: $run

   M: A request to unlock a directory found that the dir_lock_seg entry
   does not show that the directory was locked.


  A: $reboot

   Message:
   lock: UNLOCK_DIR: dir DIR_LOCK_IND unlock called with bad uid, caller = PTR

   S: $log

   T: $run

   M: A request to unlock a directory found that the UID of the directory 
   does not match the UID at the time the directory was locked.  However,
   the UID does match that in the KST.  This normally indicates that 
   the directory was salvaged during the time that it was locked.

   Message:
   lock: AST lock set at dir unlock time.

   S: $crash

   T: $run

   M: The AST was found locked to this process at directory unlock time.
   This indicates a supervisor programming error.

   A: $reboot

   Message:
   lock: VALIDATE_CACHE: FAILED running on cpu N, memory address OOOOOOOO (oct).

   S: $info

   T: $run

   M:  This is most likely a cache write notify problem with the 8/70m
   processor "CPU N", or the System Control Unit containing the "memory
   address OOOOOOOO." 

   A: $contact_sa

   END MESSAGE DOCUMENTATION */

     end lock;




		    meter_ast_lock.alm              11/11/89  1101.2rew 11/11/89  0808.5       35370



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************
	name	meter_ast_lock
	entry	lock
	entry	unlock

""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"	meter_ast_lock
"
"	Routine to meter number of AST locks and time locked by
"	caller.  This data is maintained in ast_lock_meter_seg.
"	This routine is intended to be called only by lock, and
"	the data it collects is charged against the caller of
"	lock (i.e., the owner of the stack frame immediately 
"	preceding that of lock)
"
"	After locking the AST,
"		call	meter_ast_lock$lock
"
"	Before unlocking the AST,
"		call	meter_ast_lock$unlock
"
"	Note that ast_lock_meter_seg is protected by the AST lock.
"
"	Register Conventions:
"		ap -> stack frame of caller of lock
"		ab -> ast_lock_meter_seg
"		bp -> ast_lock_meters.meters
"
"	Written November 1981 by J. Bongiovanni
"
""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
lock:
	eppap	sp|stack_frame.prev_sp,*	ap -> frame of caller of lock
	epaq	ap|stack_frame.return_ptr,*	AQ = return point in caller
	ars	18			convert to packed pointer
	lls	18			in Areg
	eppab	ast_lock_meter_seg$
	eppbp	ab|ast_lock_meters.meters
	ldq	ab|ast_lock_meters.n_entries	number currently in table
	qls	3+18			x (size of entry) in QU

find_caller_loop:
	eaq	-lock_meters_size,qu	decrement to next entry
	tmoz	caller_not_found		none left
	cmpa	bp|lock_meters.caller,qu	match on caller
	tnz	find_caller_loop		no
find_caller_join:
	stq	ab|ast_lock_meters.last_locker	save (protected by AST lock)

	inhibit	on	<+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+>
	rccl	sys_info$clock_,*		current time
	staq	ab|ast_lock_meters.last_lock_time	save
	sbaq	pds$cpu_time		total CPU time
	sbaq	pds$virtual_delta		virtual CPU time
	staq	ab|ast_lock_meters.last_lock_vcpu
	lda	pds$page_waits		page faults
	sta	ab|ast_lock_meters.last_lock_pf

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

caller_not_found:				" create entry for caller
	ldq	ab|ast_lock_meters.n_entries	highest so far
	cmpq	ab|ast_lock_meters.max_n_entries  any room
	tmi	insert_caller		yes
	ldq	0,du			overflows to index 0
	tra	find_caller_join

insert_caller:
	qls	18+3			index x size in QU
	aos	ab|ast_lock_meters.n_entries	bump next
	sta	bp|lock_meters.caller,qu	save text pointer
	tra	find_caller_join

"
unlock:
	eppab	ast_lock_meter_seg$
	ldq	ab|ast_lock_meters.last_locker	offset to entry in QU
	tpl	unlock_meter		valid
	aos	ab|ast_lock_meters.invalid	no--meter and exit
	short_return			

unlock_meter:
	eppbp	ab|ast_lock_meters.meters
	eax0	0,qu			x0 = rel offset of entry

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

	rccl	sys_info$clock_,*		current time
	sbaq	ab|ast_lock_meters.last_lock_time	time locked
	adaq	bp|lock_meters.time_locked,0	update entry
	staq	bp|lock_meters.time_locked,0	..
	rccl	sys_info$clock_,*		current time
	sbaq	pds$cpu_time		total CPU time
	sbaq	pds$virtual_delta		virtual CPU time
	sbaq	ab|ast_lock_meters.last_lock_vcpu	vcpu time locked
	adaq	bp|lock_meters.vcpu_locked,0
	staq	bp|lock_meters.vcpu_locked,0
	lda	pds$page_waits		page faults
	sba	ab|ast_lock_meters.last_lock_pf
	asa	bp|lock_meters.pf_locked,0	
	aos	bp|lock_meters.n_calls,0

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

	short_return

"
	include 	ast_lock_meters
"
	include 	stack_frame

	end




		    mountedp.pl1                    11/11/89  1101.2rew 11/11/89  0808.5       12312



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


mountedp: proc (a_lvid) returns (fixed bin (35));

/*

   Written 03/11/76 by R. Bratt to answer the question: is my process
   able to use a given logical volume

*/

dcl  a_lvid bit (36) aligned;
dcl  lvid bit (36) aligned,
     code fixed bin (35);
dcl  logical_volume_manager$lvtep entry (bit (36) aligned, ptr, fixed bin (35)),
     private_logical_volume$lvx entry (bit (36) aligned, fixed bin (8), fixed bin (35));

	lvid = a_lvid;
	call logical_volume_manager$lvtep (lvid, lvtep, code);
	if code ^= 0 then return (code);
	if lvtep -> lvte.public then return (0);
	call private_logical_volume$lvx (lvid, (0), code);
	return (code);

/*  */

%include lvt;

     end mountedp;




		    outward_call_handler.pl1        11/11/89  1101.2r w 11/11/89  0808.5       59724



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* OUTWARD_CALL_HANDLER - Handle Calls to Outer Rings.
   Modified 6/79 by Mike Grady for stack 0 sharing
   modified 11/5/76 by M. Weaver for stack header extension
   9/12/72 - Noel I. Morris			*/

outward_call_handler: proc (mc_ptr);

dcl  mc_ptr ptr;					/* pointer to machine conditions */

dcl (caller_ringno,					/* ring in which fault occurred */
     called_ringno) fixed bin (3),			/* target ring of call */
     called_segno fixed bin (15),			/* target procedure of call */
     r fixed bin (3),				/* ring number */
     i fixed bin,					/* iteration variable */
     ap ptr;					/* pointer to argument list */

dcl 1 arglist_header based (ap) aligned,		/* argument list header */
    2 arg_count fixed bin (17) unal,
    2 code fixed bin (17) unal,
    2 desc_count fixed bin (17) unal,
    2 pad fixed bin (17) unal;

dcl  dseg$ ext;					/* descriptor segment */

dcl (pds$highest_ring,				/* highest permissable ring for process */
     pds$initial_ring) fixed bin (3) ext,		/* initial non-hardcore ring for process */
     pds$ips_mask (0:7) bit (36) aligned ext,		/* IPS mask for each ring */
     pds$first_call fixed bin ext,			/* non-zero until first call from Ring 0 */
     pds$validation_level fixed bin (3) ext,		/* user vaildation level */
     pds$stacks (0:7) ptr ext,			/* pointers to stacks for each ring */
     active_all_rings_data$stack_base_segno fixed bin (18) ext; /* segno of base of array of 8 stacks */

dcl (addr,
     addrel,
     baseptr,
     bit,
     min,
     null,
     ptr,
     size,
     substr) builtin;


	% include mc;

	% include sdw;

	% include its;

	% include stack_header;
	% include lot;

	% include stack_frame;


/*  */

/* Examine the machine conditions to determine the calling and target ring numbers.
   The highest ring in which this process may run is found in pds$highest_ring.
   The target ring number may not exceed this value.  An inner ring procedure
   is not permitted to pass any arguments to an outer ring.  (The outer ring
   procedure would not be able to reference such arguments anyway.)		*/

	mcp = mc_ptr;				/* Copy pointer to machine conditions. */
	scup = addr (mcp -> mc.scu (0));		/* Generate pointer to SCU information. */

	sdwp = addr (dseg$);			/* Generate pointer to descriptor segment. */

	caller_ringno = fixed (scup -> scu.ppr.prr, 3);	/* Get ring in which fault occurred. */
	called_segno = fixed (scup -> scu.tpr.tsr, 15);	/* Get target procedure of call. */
	called_ringno = fixed (sdwp -> sdwa (called_segno).r1, 3);
						/* Get target ring number from SDW. */
	if called_ringno > pds$highest_ring then	/* Don't allow calls too far out. */
	     go to error_8;

	if caller_ringno = 0 then do;			/* Call out from ring 0 */

/* A process may make only one outward call from Ring 0 during its existence.
   The target ring number of this call must be no less than the value
   contained in pds$initial_ring.  The stack history contained in the Ring 0
   stack will automatically be "forgotten" when the FIM returns to the outer ring.	*/

	     if pds$first_call = 0 then		/* If this is not the first call from Ring 0 ... */
		go to error_1;			/* ... don't allow another. */
	     pds$first_call = 0;			/* Indicate first call from Ring 0 is being accomplished. */
	     called_ringno = max (called_ringno, pds$initial_ring);
						/* Don't allow call inside initial ring. */
	end;
	else do;

	     ap = mcp -> mc.prs (apx);		/* Get pointer to argument list. */
	     if ap -> arglist_header.arg_count ^= 0 then	/* Don't allow any arguments to be passed out. */
		go to error_8;

/* The caller ring's stack, as well as the stacks belonging to all
   intermediate rings, must be reset.  No ring lower than the target ring
   will contain any stack history.					*/

	     do r = caller_ringno to called_ringno;	/* Fudge all intermediate stacks. */
		sb = pds$stacks (r);		/* Get pointer to this ring's stack. */
		if sb ^= null then			/* If stack exists for ring ... */
		     sb -> stack_header.stack_end_ptr = sb -> stack_header.stack_begin_ptr;
						/* Reset stack. */
	     end;
	end;

/* Now modify the machine conditions.  Set sp and sb to the target
   ring's stack.  Set the ring number to the target ring.  Make
   a dummy argument list containing no arguments, and set ap to point
   to it.  Finally, return to the FIM.					*/

	sb = baseptr (active_all_rings_data$stack_base_segno + called_ringno); /* Compute pointer to target ring's stack. */
	mcp -> mc.prs (spx) = null;			/* Set null pointer in sp ... */
	mcp -> mc.prs (sbx) = sb;			/* ... and correct sb in machine conditions. */

	scup -> scu.tpr.trr,
	     scup -> scu.ppr.prr = bit (called_ringno, 3); /* Change ring number in machine conditions. */

	substr (scup -> scu.even_inst, 19, 10),		/* Modify both even and odd instructions to be ... */
	     substr (scup -> scu. odd_inst, 19, 10)	/* ... TRA (710(0)).  The CALL instruction would cause ... */
	     = "1110010000"b;			/* ... SB segno to be loaded into SP segno. */

	pds$validation_level = called_ringno;		/* Set the validation level to called ring. */

	ap = ptr (sb, size (stack_header));		/* Make a dummy arglist in stack (after header) */
	ap -> arglist_header.arg_count, ap -> arglist_header.desc_count, ap -> arglist_header.pad = 0;
	ap -> arglist_header.code = 4;		/* Make a null argument list. */

	mcp -> mc.prs (apx) = ap;			/* Set ap in machine conditions. */

	do i = 0 to 7;				/* Set the ring number in all pointer registers. */
	     addr (mcp -> mc.prs (i)) -> its.ringno = bit (called_ringno, 3);
	end;					/* PR's may not point to an inner ring. */

	do i = 0 to called_ringno - 1;		/* mask IPS signals in all lower rings */
	     pds$ips_mask (i) = (36)"0"b;		/* set masks to zero */
	end;

	return;					/* And return to caller. */


/* Error returns. */

error_1:
	mcp -> mc.errcode = 1;			/* Return error code. */
	return;

error_8:
	mcp -> mc.errcode = 8;
	return;




     end outward_call_handler;




		    private_logical_volume.pl1      11/11/89  1101.2rew 11/11/89  0808.5       32877



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


private_logical_volume: proc ();

/*

   Written Janurary 1976 by R. Bratt

   Last modified:

   private_logical_volume maintains a per-process list of those LVs  to which a process is
   connected. The connect entry point enters a LV in this list.  The disconnect entry point
   removes an entry from this list. To prevent a process from using a LV after it disconnects  from
   it, the disconnect entry point setfaults all segments in the process' address space which reside
   upon the LV it is disconnecting.  Naturally seg_fault must not reconnect a sdw unless
   the appropriate LV is mounted for the process. The lvt entry point is used by ring zero
   to determine whether the process has the LV mounted.

*/

dcl  a_lvid bit (36) aligned,
     a_code fixed bin (35),
     a_lvx fixed bin (8);

dcl  lvid bit (36) aligned,
     kstex fixed bin (17),
     lvx fixed bin (8);

dcl (error_table_$nrmkst, error_table_$logical_volume_not_connected,
     error_table_$logical_volume_is_connected) ext fixed bin (35);

dcl  setfaults$disconnect entry (fixed bin (17));

/*  */

connect:	entry (a_lvid, a_code);
	lvid = a_lvid;
	a_code = 0;
	kst.lv (find_hole (lvid)) = lvid;
	kst.lvs = kst.lvs + 1;
	return;

lvx:	entry (a_lvid, a_lvx, a_code);
	a_lvx = 0;
	a_code = 0;
	a_lvx = find ((a_lvid));
	return;

disconnect: entry (a_lvid, a_code);
	lvid = a_lvid;
	a_code = 0;
	lvx = find (lvid);
						/* kung-fu segments connected to LV */
	do kstex = kst.lowseg to kst.highseg;
	     kstep = addr (kst.kst_entry (kstex));
	     if ^kste.dirsw
	     then if kste.infcount = lvx
		then do;
		     call setfaults$disconnect ((kste.segno)); /*  fault him */
		     kste.infcount = 0;		/* mark as no longer connected to private  LV */
		end;
	end;
	kst.lv (lvx) = "0"b;
	kst.lvs = kst.lvs - 1;
	return;

/*  */

find_hole: proc (lvid /* , kstp */) returns (fixed bin (8));
dcl  lvid bit (36) aligned,
     lvx fixed bin (8),
     lvs fixed bin (8),
     hashx fixed bin (8),
     holex fixed bin (8),
     find bit (1) aligned init ("1"b);

	     find = "0"b;

find:	     entry (lvid /* , kstp */) returns (fixed bin (8));
	     kstp = pds$kstp;
	     holex = 0;
	     lvs = kst.lvs;
	     hashx = mod (bin (bin (lvid), 35), dimension (kst.lv, 1));
	     do lvx = hashx to dimension (kst.lv, 1),
		     1 to hashx while (lvs > 0);
		if kst.lv (lvx) ^= "0"b
		then do;
		     if kst.lv (lvx) = lvid
		     then if find
			then return (lvx);
			else call abort (error_table_$logical_volume_is_connected);
		     lvs = lvs - 1;
		end;
		else if holex = 0 then holex = lvx;
	     end;
	     if find
	     then call abort (error_table_$logical_volume_not_connected);
	     else if holex ^= 0
	     then return (holex);
	     else call abort (error_table_$nrmkst);
	end find_hole;

abort:	proc (code);
dcl  code fixed bin (35);
	     a_code = code;
	     go to return_to_caller;
	end abort;

return_to_caller:
	return;

/*  */

% include kst;

     end private_logical_volume;




		    put_aste.pl1                    11/11/89  1101.2rew 11/11/89  0808.5       33426



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/*
			put_aste (astep)




FUNCTION -

The procedure "put_aste" frees  the  ASTE  pointed  to  by  the  input  argument
"astep".  No matter if the ASTE was in the circular list or not, "put_aste" will
put it in the list associated with the size of its  page  table,  at  the  first
position.

It  does  not  concern  itself  with  the  AST lock. It assumes there is no race
condition. It is the responsibility of the caller to make sure no race condition
exists. If called by the initializer or  shutdown,  it  may  be  called  without
locking  the AST. In normal cases, however, the caller must make sure the AST is
locked before issuing the call and it will be unlocked upon return as soon as it
is safe to do so.

All items of the ASTE are zeroed except fp, bp, ptsi and marker. All  PTW's  are
initialized with a page not core flag and a coded null disk address.



MODIFICATIONS -

04/17/75	A. Bensoussan - Modified for the new storage system.
03/21/81	W. Olin Sibert, for ADP PTW formats
04/17/81	WOS -- remove ptw.os trap, convert for ptw_util_
11/01/82  J. Bongiovanni, for synchronized segments
84-01-16  BIM to zero aste counters.

*/


put_aste: procedure (a_astep);


dcl  a_astep	ptr;
dcl (i, pts)	fixed bin(17);
dcl  ptsi		fixed bin (3);
dcl  ptp		ptr;
dcl  pt		(1: pts) bit (36) aligned based;

dcl  hc_dm_util$deactivate    entry (fixed bin (3));
dcl  ptw_util_$make_null	entry (pointer, bit (22) aligned);
dcl  thread$cin		entry (ptr, bit (18) unal);
dcl  thread$out		entry (ptr, bit (18) unal);

dcl (addr, addwordno, fixed, rel) builtin;



	sstp = addr (sst_seg$);			/* get pointers */
	astep = a_astep;				/* copy argument */

	ptsi = fixed (astep -> aste.ptsi, 2);		/* get page table size index */
	pts = sstp -> sst.pts (ptsi);			/* get page table size */


          if aste.synchronized
	     then call hc_dm_util$deactivate (ptsi);

	if sst.ausedp(ptsi) ^= rel(astep) then		/* If ASTE not first in list, make it first */
	     do;
	     if aste.fp ^= "0"b then 			/* If ASTE is in the list, take it out */
		call thread$out (astep, sst.ausedp(ptsi));
	     call thread$cin (astep, sst.ausedp(ptsi));	/* Put ASTE at the end of the list */
	     sst.ausedp (ptsi) = rel (astep);		/* Move current ptr to ASTE to make it first */
	     end;

	aste.pvtx = 0;				/* Set pvtx to zero (unvalid pvtx) to prevent emergency
						  shutdown from updatig the vtoce with wrong addresses */

	aste.np, aste.csl, aste.records = ""b;		/* counters are irrelevant */

/* There used to be a trap here which inspected ptw.os for each PTW, crashing if it was
   found on, but this trap has outlived its usefulness. */

	ptp = addwordno (astep, sst.astsize);		/* Start with page zero */

	do i = 1 to pts;				/* Write coded null addresses in all PTW's */
	     call ptw_util_$make_null (addr (ptp -> pt (i)) , put_aste_null_addr);
	end;

	astep -> aste_part.two = "0"b;		/* Zero the ASTE except fb, bp, ptsi and marker */

	return;

%page; %include sst;
%page; %include aste;
%page; %include null_addresses;

	end put_aste;




		    search_ast.alm                  11/11/89  1101.2r w 11/11/89  0807.4       35811



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

"
"	search_ast.alm	-fast AST searcher
"	Jan. 19, 1976 by Bernard Greenberg
"	Modified December 1981 by J. Bongiovanni for new hash table
"	Modified May 1983 by E. N. Kittlitz for check entry.
"
"""	search_ast entry
"	astep = search_ast (uid);
"
"	astep = null if UID not active.
"
"
"""	check entry
"	astep = search_ast$check (uid, pvid, vtocx, code);
"
"	if astep ^= null, code is 0
"	if astep = null then
"		if code = 0, segment is just not active
"		else uid was matched by search, but pvid or vtocx of aste
"			did not match supplied pvid/vtocx.

	name	search_ast
	entry	search_ast,check,hash_in,hash_out

search_ast:			"astep = search_ast (uid);
	eax1	4
	tra	search_ast_join

check:				"astep = search_ast (uid, pvid, vtocx, code);
	eax1	10
	stz	ap|8,*		zero code

search_ast_join:
	lda	ap|2,*		get uid
	tsx0	search		look it up
	tra	search_ast_fails	not there
	cmpx1	=4,du		search_ast entry?
	tze	search_ast_succeeds sure enough
	lda	bp|aste.vtocx	double-check the aste
	ana	=o777777,dl	just vtocx...
	cmpa	ap|6,*		compare with desired vtocx
	tnz	search_ast_fails_check oh dear, fooled by scrambled uid
	ldq	bp|aste.pvtx_word	and now triple-check
	qrl	aste.pvtx_shift	ASTE PVTX in QL
	anq	aste.pvtx_mask,dl	nice and tidy
	mpy	pvte_size,dl	index into array
	lda	pvt$array+pvte.pvid-pvte_size,ql pvt is (1:n). get pvid
	cmpa	ap|4,*		compare with pvid supplied
	tnz	search_ast_fails_check tricky fellow

search_ast_succeeds:
	spribp	ap|0,x1*		found astep
	short_return

search_ast_fails:
	eppbp	null,*		not found
	spribp	ap|0,x1*		
	short_return

search_ast_fails_check:
	lda	error_table_$vtoce_connection_fail
	sta	ap|8,*		return code
	eppbp	null,*		null return value
	spribp	ap|0,x1*
	tra	alm_syserr_caller$search_ast_double_uid " returns to our caller


hash_in:		"call search_ast$hash_in (astep), uid having been set.

	eppbp	ap|2,*
	eppbp	bp|0,*		arg is ptr
	lda	bp|aste.uid
	tsx0	search		look it up
	tra	*+2		not found
	tra	err		found, this is wrong
	ldx2	lb|0,3		get current list head
	sarbp	lb|0,3		set new guy
	stx2	bp|aste.ht_fp	splice in
	short_return


hash_out:		"call search_ast$hash_out (astep), uid having been set

	eppbp	ap|2,*
	eppbp	bp|0,*
	lda	bp|aste.uid
	tsx0	search
	tra	err		must be found
	ldx2	bp|aste.ht_fp	save next ptr
	eax4	0,4		were we first?
	tze	were_first
	stx2	bb|aste.ht_fp,4	thread last to next, not first
	eax4	0
	stx4	bp|aste.ht_fp	clear thread
	short_return

were_first:
	stx4	bp|aste.ht_fp	clear thread
	stx2	lb|0,3		thread out
	short_return


"
"	search -internal procedure to do actual search
"	Called with uid in A, returns to call + 1 if not found
"	Returns to call + 2 if found, bp and x6 point to ASTE,
"	x4 is 0 if first, otherwise x4 -> previous. bb -> sst
"	lb -> AST hash table, x3 -> slot in table

search:	eppbb	sst$
	epplb	sst$ast_ht_ptr
	epplb	lb|0,*		lb -> AST hash table
	eaq	0,al
	qrl	18
	anq	sst$ast_ht_uid_mask
	eax3	0,ql		get hash index in x3
	eax4	0		set first time sw

	ldx6	lb|0,3		start at head
	tze	0,0		if 0, nothing in list
lp:	cmpa	bb|aste.uid,6	is this the one?
	tze	found		yes
	eax4	0,6		save prev ptr
	ldx6	bb|aste.ht_fp,6	move up
	tnz	lp		if stuff, loop
	tra	0,0		no stuff, not found
found:	eppbp	bb|0,6
	tra	1,0

err:	call	alm_syserr_caller$search_ast_hash_error,(null_argl)
	tra	err

	even
null:	its	-1,1
null_argl:zero	0,0
	zero	0,0

	include	aste

	include	pvte

	end




		    seg_fault.pl1                   11/11/89  1101.2r   11/11/89  0808.5      189684



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

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

seg_fault: proc (a_mcptr);


/****^  HISTORY COMMENTS:
  1) change(86-08-09,GDixon), approve(86-08-09,MCR7388),
     audit(86-09-02,Farley), install(86-09-08,MR12.0-1150):
     Document restrictions placed upon future callers of
     seg_fault$makeknown_activate.
                                                   END HISTORY COMMENTS */

/*
    1/85 by Keith Loepere to audit logical volume full conditions.
   10/84 by Keith Loepere to move access computations into dc_find, also to
         avoid dir unlocking/locking during makeknown_activates.
   07/84 by Keith Loepere for the new dc_find.
   09/83 by E. N. Kittlitz to ignore per-process 256K switch for dirs.
   02/83 by E. N. Kittlitz for 256K segments.
   02/82 by J. Bongiovanni to eliminate use of FSDCT.
   01/82 by Benson I. Margulies, to give initializer segbusteds.
   08/81 by W. Olin Sibert, for use of validate_entryp by makeknown_activate,
     to fix confusion caused by (you guessed it) the directory rebuild salvager.
   07/81 by J. Bongiovanni for seg_fault call metering
   04/81 by W. Olin Sibert, for ADP SDWs
   02/81 by E. N. Kittlitz for makeknown_activate entry
   04/77 by THVV for damaged switch and messages
   09/76 by R. Bratt to meter per-process seg_faults
   05/76 by Greenberg for signalling out_of_bounds for 0 max length seg
   03/76 by R. Bratt for gtpd, initiated mode, and user deactivate
   03/76 by R. Bratt to fix kst access setting bug
   02/76 by R. Bratt for private LV stuff
   04/75 by E. Stone to put access info in kst
   04/75 by Andre Bensoussan for the new storage system
   04/75 by R. Bratt for new kst (merge by tvv)
   07/74 by Kobziar to check for security out-of-service
   04/74 by Greenberg for 2 cpu cache
   04/74 by Greenberg for full entry bound mechanism
   02/74 by Greenberg for 6180 cache
   12/73 by Kobziar to set bound only on basis of max_length (drop "a" bit requirement to grow page)
   10/73 by Steve Webber to add KLUDGE for hardcore gate entry bounds.
   08/73 by R.B.Snyder to put in check for illegal segfaults.


   seg_fault: Handles all missing segment faults in the system. The segment
   must alreay have a KST entry and seg_fault will as necessary do the following:
   1. Create an AST entry.
   2. Compute the access for the SDW.
   3. Compute the bounds field for the SDW.
   4. Create the trailer for the segment.

   USAGE: call seg_fault(mc_ptr);

   1. machine_conditions_ptr pointer		an ITS pointer to the machine conditions
   in which the missing segment fault occured.


   makeknown_activate: Called by makeknown_ to activate and connect directories
   rather than deferring this until first reference (as is the case with
   non-directory segments).  This allows activation errors such as
   connection failure to be indicated by status code, causing a
   makeknown_ failure, rather than eventually causing a crawlout due
   to segment fault error.

   Currently makeknown_ is the only caller of this entrypoint.  Should other
   procedures need to call it in the future, they must meet the following
   requirements:
   
      The caller must have called sum$getbranch or sum$getbranch_root_my to 
      obtain a pointer to the directory entry corresponding to the segment
      (identified by a_kstep) to be activated.  This will lock the directory
      and validate that a_kstep->kste.entryp properly points to the directory
      entry for the segment.  The directory must remain locked until seg_fault
      returns, since seg_fault used kste.entryp.  If the directory were
      unlocked, another processor could move or delete the directory entry out
      from under seg_fault.

   USAGE: call seg_fault$makeknown_activate (a_kstep, a_code);

   1. a_kstep pointer to KST entry (input)
   2. a_code status error code (output)
   */

/* Parameters */

dcl  a_code			fixed bin (35) parameter;
dcl  a_kstep			pointer parameter;
dcl  a_mcptr			pointer parameter;

/* Variables */

dcl  activated_sw			bit (1) aligned;
dcl  audit_eventflags		bit (36) aligned;
dcl  branch_entrypt_bound		bit (14);
dcl  branch_entrypt_sw		bit (1);
dcl  code				fixed bin (35);
dcl  esw				fixed bin;
dcl  lsw				bit (1) aligned;
dcl  lvx				fixed bin (8);
dcl  mode				bit (36) aligned;
dcl  offset			fixed bin (18);
dcl  1 orig_sdwi			aligned like sdw_info automatic;
dcl  pts				fixed bin;
dcl  pw1				fixed bin (17);
dcl  pw2				fixed bin (17);
dcl  ringno			fixed bin;
dcl  sdw_address			fixed bin (26);
dcl  sdw_valid			bit (1) aligned;
dcl  1 sdwi			aligned like sdw_info automatic;
dcl  segno			fixed bin (17);
dcl  segptr			pointer;
dcl  time1			fixed bin (71);
dcl  time2			fixed bin (71);
dcl  tsdw				fixed bin (71);

/* External */

dcl  access_operations_$log_vol_full	bit (36) aligned external static;
dcl  active_all_rings_data$stack_base_segno fixed bin (18) external static;
dcl  dseg$			(0:4095) fixed bin (71) external static;
dcl  error_table_$big_seg		fixed bin (35) external static;
dcl  error_table_$boundviol		fixed bin (35) external static;
dcl  error_table_$log_vol_full	fixed bin (35) external static;
dcl  error_table_$mylock		fixed bin (35) external static;
dcl  error_table_$oosw		fixed bin (35) external static;
dcl  error_table_$seg_busted		fixed bin (35) external static;
dcl  error_table_$seg_deleted		fixed bin (35) external static;
dcl  pds$access_authorization		bit (72) aligned ext;
dcl  pds$dstep			bit (18) external static;
dcl  pds$segment_faults		fixed bin (35) external static;
dcl  pds$stacks			(0:7) ptr external static;
dcl  pvt$root_lvid			bit (36) aligned external static;
dcl  sst$cpu_sf_time		fixed bin (71) external static;
dcl  sst$makeknown_activations	fixed bin (35) external static;
dcl  sst$pts			(0:3) fixed bin external static;
dcl  sst$root_astep			pointer external static;
dcl  sst$tfreep			pointer external static;
dcl  sst$total_sf_pf		fixed bin (35) external static;
dcl  sst$total_sf			fixed bin (35) external static;
dcl  sst$seg_fault_calls		fixed bin (35) external static;
dcl  sys_info$seg_size_256K		fixed bin (19) external static;

/* Entries */

dcl  access_audit_$log_general	entry (char (*), fixed bin, bit (36) aligned, bit (36) aligned, char (*), fixed bin (35), ptr, fixed bin (18), char (*));
dcl  activate$activate_long		entry (ptr, bit (1) aligned, fixed bin (35)) returns (ptr);
dcl  get_kstep			entry (fixed bin (17), ptr, fixed bin (35));
dcl  get_ptrs_$given_astep		entry (pointer) returns (fixed bin (71));
dcl  level$get			entry () returns (fixed bin);
dcl  lock$dir_unlock		entry (pointer);
dcl  lock$lock_ast			entry;
dcl  lock$unlock_ast		entry;
dcl  logical_volume_manager$lvtep	entry (bit (36) aligned, ptr, fixed bin (35));
dcl  makestack			entry (fixed bin);
dcl  page$enter_data		entry (fixed bin (17), fixed bin);
dcl  private_logical_volume$lvx	entry (bit (36) aligned, fixed bin (8), fixed bin (35));
dcl  sdw_util_$construct		entry (pointer, pointer);
dcl  sdw_util_$dissect		entry (pointer, pointer);
dcl  sdw_util_$get_address		entry (pointer, fixed bin (26));
dcl  sdw_util_$get_valid		entry (pointer, bit (1) aligned);
dcl  segment_mover			entry (fixed bin (18), ptr, ptr, fixed bin, fixed bin (35));
dcl  setfaults$cache		entry (pointer, bit (1) aligned);
dcl  sum$getbranch_root_my		entry (pointer, bit (36) aligned, pointer, fixed bin (35));
dcl  syserr			entry options (variable);
dcl  thread$lin			entry (pointer, bit (18)); /* Requires bit (18) unal in upper halfword only */
dcl  usage_values			entry (fixed bin (17), fixed bin (71));

/* Constants */

dcl  FAULT			fixed bin static internal options (constant) init (0);
dcl  MAKEKNOWN			fixed bin static internal options (constant) init (1);

/* Miscelaneous */

dcl  (addr, baseptr, bin, binary, bit, min, null, ptr, rel, string, substr) builtin;
%page;

/* set initial pointer values */

	call usage_values (pw1, time1);		/* start metering of seg faults */
	esw = FAULT;
	code = 0;
	kstp = pds$kstp;
	mcp = a_mcptr;
	scup = addr (mc.scu (0));
	mc.errcode = 0;
	ringno = bin (scu.ppr.prr, 3);


/* NOW FIND OUT THE SEGMENT NUMBER OF THE FAULTING SEGMENT - IF THE RESTART BIT IN THE SCU
   DATA IS "ON", THE FAULTING SDW IS FOR THE PROCEDURE SEGMENT AND HENCE PSR SHOULD BE USED -
   OTHERWISE, TSR SHOULD BE USED */

	if scu.cu.if then segno = bin (scu.ppr.psr, 15);
	else segno = bin (scu.tpr.tsr, 15);

	call sdw_util_$get_valid (addr (dseg$ (segno)), sdw_valid);
	if sdw_valid then do;			/* Fault is a fraud */
	     call syserr (0, "seg_fault: illegal segfault on cpu ^a",
		substr ("ABCDEFGH", bin (scu.cpu_no, 3) + 1, 1)); /* log it and maybe crash */
	     return;				/* rcu the data and try again */
	end;

	call page$enter_data (segno, (seg_fault_start));	/* enter start of seg_fault in trace */

	offset = bin (scu.ca, 18);			/* get computed address */


/* CHECK FOR FAULT ON STACK SEGMENT */

	if segno >= active_all_rings_data$stack_base_segno then
	     if segno <= active_all_rings_data$stack_base_segno + 7 then
		if pds$stacks (segno - active_all_rings_data$stack_base_segno) = null then do;
		     call makestack (segno - active_all_rings_data$stack_base_segno); /* Will cause recursive segfault on stack */
		     go to finish;
		end;


/* GET KST ENTRY POINTER */

	segptr = baseptr (segno);			/* make a seg pointer */
	call get_kstep (segno, kstep, code);
	if code ^= 0 then go to err;

/* GET THE ASTE POINTER - IF IT IS THE ROOT, IT IS ALWAYS ACTIVE AND ITS ASTE POINTER IS IN THE SST -
   IF IT IS NOT THE ROOT, ONE HAS TO FIND THE BRANCH, LOCK THE PARENT AND GET AN ASTE FOR THE SEGMENT IF IT
   DOES NOT HAVE ONE ALREADY. */


COMMON:
	if kste.uid = (36)"1"b then do;		/* is this the root */

/* ROOT */

	     lsw = "0"b;				/* we won't lock the parent */
	     call lock$lock_ast;
	     if code ^= 0 then go to err;
	     astep = sst$root_astep;			/* this is easy */
	end;

/* NOT THE ROOT */

	else do;
	     if esw = MAKEKNOWN then lsw = "0"b;	/* guaranteed to be a locked directory */

	     else do;				/* normal seg_fault */

/* sum must be called here, not in dc_find.  This is because sum may take a
(recursive) seg_fault on the parent directory.  dc_find has too big a stack
frame to allow it to come into play in these recursive seg_fault occurences. */

		lsw = "0"b;
		call sum$getbranch_root_my (segptr, "0"b, ep, code);
		if code = 0 then lsw = "1"b;
		else if code = error_table_$mylock then code = 0;
		else if code = error_table_$seg_deleted then do;
		     dp, ep = null;
		     go to seg_audit;
		end;
		else go to err;
		dp = ptr (ep, 0);

/* Parent is guaranteed to be in service if we got this far.
   Make sure the entry is still in service. */

		if entry.security_oosw then
		     if ^addr (pds$access_authorization) -> aim_template.privileges.soos then do;
			code = error_table_$oosw;
			go to err1;
		     end;

		if ^entry.dirsw then do;		/* compute access (dirs are special cased later) */
seg_audit:	     call dc_find$seg_fault (kstep, ep, code);
		     if code ^= 0 then go to err1;
		end;
	     end;

	     if ^kste.dirsw then do;

/* COPY FROM BRANCH THOSE ITEMS THAT WILL BE NEEDED AFTER AST IS LOCKED
   SO THAT DIRECTORIES ARE NEVER REFERENCED WHILE THE AST IS LOCKED */

		branch_entrypt_bound = entry.entrypt_bound;
		branch_entrypt_sw = entry.entrypt_sw;

	     end;

/* MAKE SURE ITS LOGICALLY MOUNTED FOR THIS PROCESS (NOT NECESSARILY PHYSICALLY MOUNTED)
   TO AVOID PAGE FAULTS ON DIR HEADER AND LVT SEVERAL TESTS ARE MADE WHERE ONE WOULD DO */

	     if ^kste.dirsw then			/* not a dir which would be on RLV and hence public */
		if kste.infcount = 0 then		/* not marked as privately mounted */
		     if (entry.sons_lvid ^= pvt$root_lvid) |
			entry.master_dir then do;	/* cant prove its on RLV and hence public */
						/* oh well, time for the definitive test */
			call logical_volume_manager$lvtep (dir.sons_lvid, lvtep, code);
			if code ^= 0 then goto err1;	/* sorry, no such LV */
			if ^lvte.public then do;	/* LV not public so check for private mount */
			     call private_logical_volume$lvx (dir.sons_lvid, lvx, code);
			     if code ^= 0 then goto err1; /* sorry, not privately mounted */
			     kste.infcount = lvx;	/* remember that it was privately mounted */
			end;
		     end;

	     astep = activate$activate_long (ep, activated_sw, code); /* Returns with AST locked if OK */
	     if code ^= 0 then go to err1;

	     if esw = MAKEKNOWN then			/* meter ? */
		if activated_sw then
		     sst$makeknown_activations = sst$makeknown_activations + 1;
	end;

/* ARE THERE PAGE_CONTROL INDUCED EXCEPTION CONDITIONS ON SEGMENT ? */

	if aste.damaged & ^kste.dirsw then do;
	     code = error_table_$seg_busted;
	     go to err0;
	end;

/* IS THERE A PER-PROCESS SIZE LIMITATION (256K) ? */

	if ^kst.allow_256K_connect & ^kste.dirsw then	/* dir should never be 256K, but don't enforce it here */
	     if bin (aste.msl, 9) * 1024 >= sys_info$seg_size_256K then do;
		code = error_table_$big_seg;
		go to err0;
	     end;

/* MAKE SURE THE REFERENCE IS NOT OUT OF BOUNDS */

	if offset >= bin (aste.msl, 9) * 1024 then do;	/* NEVER for MAKENOWN, remember */
	     code = error_table_$boundviol;
	     mc.resignal = "1"b;			/* New signal code */
	     mc.fcode = bit (bin (out_of_bounds_sct_index, 17), 17);
	     go to err0;
	end;


/* SEE IF SEG MUST BE MOVED TO ANOTHER PV. CALL SEG MOVER IF SO.  
   If this is MAKEKNOWN entry, then makeknown_ will either (horrors) get
   a segment_mover error, or the process will just take a typical seg_fault */

	if aste.pack_ovfl then do;			/* Out of PV */
	     call segment_mover (offset, astep, ep, segno, code);
	     if code = error_table_$log_vol_full then do;
		audit_eventflags = "0"b;
		addr (audit_eventflags) -> audit_event_flags.cc_1_10 = "1"b;
		call access_audit_$log_general ("seg_fault", level$get (), audit_eventflags, access_operations_$log_vol_full, "", code, null, 0, "");
	     end;
	     go to err1;				/* He unlocked the AST. Signal or retry */
						/* as code is or is not 0 */
	end;



/* DOES THE PROCESS ALREADY HAVE A TRAILER FOR THIS SEGMENT */

MAKE_TRAILER:
	pts = sst$pts (bin (aste.ptsi, 3));		/* get page table size actually awarded */

	call sdw_util_$get_address (addr (dseg$ (segno)), sdw_address);
	if sdw_address = 0 then do;			/* Add a trailer if not connected */
	     if rel (sst$tfreep) = ""b then
		call syserr (1, "seg_fault: trailer storage area exhausted");

	     strp = sst$tfreep;			/* Get pointer to first free trailer */
	     if str.fp = "0"b then call syserr (1, "seg_fault: trailer list trap"); /* TRAP */
	     sst$tfreep = ptr (strp, str.fp);		/* (setq tfreep (cdr tfreep)) */
	     str.segno = bit (bin (segno, 18), 18);	/* Fill in the new trailer */
	     str.dstep = pds$dstep;			/* ditto */
	     str.fp, str.bp = "0"b;			/* ditto */
	     call thread$lin (strp, aste.strp);		/* Thread the new trailer in */

	     aste.gtus = aste.gtus & kste.tus;
	     aste.gtms = aste.gtms & kste.tms;
	     aste.explicit_deact_ok = aste.explicit_deact_ok & kste.explicit_deact_ok;
	end;


/* PREPARE A COPY OF THE SDW FOR THIS SEGMENT */

	tsdw = get_ptrs_$given_astep (astep);		/* get sdw for this astep */
	call sdw_util_$dissect (addr (tsdw), addr (sdwi));/* and prepare to modify it appropriately */

	if kste.dirsw then do;

/* DIR */

	     string (sdwi.access) = "1010"b;		/* access in ring 0 RW with rb of 0,0,0 */
	     sdwi.cache = "0"b;			/* directories not allowed in cache due to
						   use of abs-segs at deactivation time */
	end;

/* SEG */

	else do;
	     call sdw_util_$dissect (addr (dseg$ (segno)), addr (orig_sdwi)); /* Get info from the current SDW */
						/* This is where access & rings are stored betweentimes */

/* COMPUTE ACCESS FIELD */

	     string (sdwi.access) = string (orig_sdwi.access);
	     mode = substr (string (orig_sdwi.access), 1, 3);
	     string (sdwi.rings) = string (orig_sdwi.rings);
	     if branch_entrypt_sw then		/* Set the entry bound */
		sdwi.gate_entry_bound = binary (branch_entrypt_bound) + 1;
						/* sdw_info is # of entrypoints, not max offset */

/* COMPUTE ENCACHEABILITY OF SEGMENT - ASTEP IS VALID SINCE AST IS LOCKED */

	     sdwi.cache = "1"b;			/* assume encacheability at first */
						/* This will be ignored on the ADP */
	     if aste.any_access_on then		/* if there is either one SDW or only
						   read-permit SDW's */
		if substr (mode, 3, 1) |		/* and we are adding write access */
		     aste.write_access_on then do;	/* or there is 1 write SDW */
						/* We mut take seg out of cache */
		     call setfaults$cache (astep, "0"b);/* hit cache bits */
		     sdwi.cache = "0"b;		/* we will not encache either */
		     aste.any_access_on = "0"b;	/* inhibit further checks */
		end;
		else ;				/* adding 1 more read-only SDW */
						/* any_access_on is off -
						   could already be out of cache */
	     else if aste.write_access_on then		/* is out of cache */
		sdwi.cache = "0"b;
	     else aste.any_access_on = "1"b;

	     aste.write_access_on = aste.write_access_on | substr (mode, 3, 1);
						/* indicate write access on */
	end;

	sdwi.size = min (pts, bin (aste.msl, 9)) * 1024;	/* set bound */

/* STORE THE COPY OF THE SDW IN THE REAL SDW - UNLOCK THE AST - UNLOCK THE PARENT IF REQUIRED */

	call sdw_util_$construct (addr (dseg$ (segno)), addr (sdwi)); /* Put the SDW back */

err0:	call lock$unlock_ast;

err1:	if lsw then call lock$dir_unlock (dp);		/* Unlock the directory */

err:

	call usage_values (pw2, time2);		/* get final value for seg fault metering */
	sst$cpu_sf_time = sst$cpu_sf_time + time2 - time1;
	sst$total_sf_pf = sst$total_sf_pf + pw2 - pw1;
	sst$total_sf = sst$total_sf + 1;
	pds$segment_faults = pds$segment_faults + 1;
	if esw = MAKEKNOWN then do;
	     sst$seg_fault_calls = sst$seg_fault_calls + 1;
	     a_code = code;
	     return;
	end;

	mc.errcode = code;

finish:	call page$enter_data (segno, (seg_fault_end));	/* enter finish of seg_fault in trace */
	return;
%page;
makeknown_activate: entry (a_kstep, a_code);

	call usage_values (pw1, time1);
	esw = MAKEKNOWN;				/* our humble beginnings */
	kstp = pds$kstp;
	code = 0;
	mcp = null;				/* trap bad reference */
	scup = null;				/* ... */
	ringno = 0;				/* why not ? */
	offset = -1;				/* lower than lowest max seg length */
	kstep = a_kstep;				/* do quick what takes normal entry sooo long */
	ep = kste.entryp;
	dp = ptr (ep, 0);
	segno = kste.segno;
	segptr = baseptr (segno);
	go to COMMON;
%page; %include access_audit_eventflags;
%page; %include aim_template;
%page; %include aste;
%page; %include dc_find_dcls;
%page; %include dir_entry;
%page; %include dir_header;
%page; %include kst;
%page; %include lvt;
%page; %include mc;
%page; %include sdw_info;
%page; %include static_handlers;
%page; %include str;
%page; %include trace_types;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   seg_fault: illegal segfault on cpu X

   S:	$info

   T:	$run

   M:	The SCU data
   stored by processor X
   indicates that
   a segment fault has occurred
   but the SDW indicated by the SCU data
   has no directed fault indicator.
   $err
   The system attempts to retry the faulting instruction.

   A:	Inform field engineering personnel.
   If this message persists, attempt to delete the CPU.


   Message:
   seg_fault: trailer storage area exhausted

   S:	$crash

   T:	$run

   M:	There are no more free entries available in the system trailer
   segment, str_seg. This may be indicative of software- or hardware-induced
   damage to the SST or str_seg, or may be indicative of a number of
   logged-in processes which is vastly too large. A more likely cause is
   insufficiently large str_seg. The size of the str_seg can be changed
   by the TBLS STR card in the config deck.
   $err
   $crashes

   A:	$recover
   It may be necessary to increase the size of the str_seg by the TBLS STR
   card in the config deck.
   Be sure to get a dump.


   Message:
   seg_fault: trailer list trap

   S:	$crash

   T:	$run

   M:	An attempt was made to
   set sst$tfreep to zero.
   The supervisor checks for this
   situation and crashes here
   when one entry remains in the trailer segment
   in order to trap an elusive bug
   which used to cause "trailer storage area exhausted" crashes
   when the trailer segment was not full.
   $err
   $crashes

   A:	$recover
   Be sure to get a dump.

   END MESSAGE DOCUMENTATION */

     end seg_fault;




		    segment_mover.pl1               10/23/92  1027.6rew 10/23/92  1025.1      252549



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1992   *
        *                                                         *
        * 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(88-03-28,Parisek), approve(88-05-27,MCR7907),
     audit(88-06-02,Fawcett), install(88-09-27,MR12.2-1122):
     Free the pvtx and pvid binding (done by get_pvtx$hold_pvtx to keep other
     processes from allocating the potential target pv during VTOCE move) when
     that target pv is found to be full, thus making it unusable for the VTOCE
     move. (phx20920).
  2) change(92-09-11,Zimmerman), approve(92-09-11,MCR8259), audit(92-09-22,Vu),
     install(92-10-23,MR12.5-1040):
     Change to include names of sub_volumes in error messages.
                                                   END HISTORY COMMENTS */


/* format: style2,indcomtxt */
segment_mover:
     proc (a_refaddr, a_astep, a_ep, a_segno, a_code);

/**** This procedure is invoked from the segment fault handler when the latter finds
      a flag (aste.pack_ovfl) on in an ASTE to which a process is trying to connect.
      This flag is turned on when the page fault handler finds that no page of the
      segment's Physical Volume of residence is availble for allocation.

      Segment_mover tries to allocate a vtoce for the segment on some
      other physical volume of the logical volume. The PVT is scanned once,
      via a coroutine with create_vtoce$createv_for_segmove. The target
      physical volume must have at least as many free records as the current requirement
      of the segment, plus the one extra sought. If no allocation can be made, segment_mover
      returns the logical volume full error code.

      In the case of a demand segment move (hphcs_ call to move a segment),
      optimization of physical volume selection is allowed for create_vtoce.
      This optimization will place segments on devices with the most space,
      over a sufficiently large number of segment creations.

      segment_mover relies upon page_control detected out-of-physical-volume
      conditions on the target physical volume. If the segment fault handler
      notices a fault on the illegal low segment number, an error is signalled, which
      is caught by a condition handler in this program, and interpreted appropriately.

      The basic strategy is to move all pages into memory, wired,
      and then change the record addresses. For synchronized segments,
      it is neccessary to guarantee that no held pages exist, since
      the disk records for held pages would have to be preserved and
      their contents moved. Thus, for synchronized segments,
      pc force writes the journal pages, and then can use the usual
      strategy.

      Designed and coded by Bernard Greenberg, 9-10/75

      Last modified:

      02/19/76 by Richard Bratt to change coroutine coordination with create_vtoce
      05/76    by BSG for demounter, hphcs_ seg mover
      06/76	by D. Vinograd to copy volume dump info to new aste and to set volume dump bit map for old vtoce.
      12/1/78 by BSG for +-1 bugs in pc calls and special-case of 1 PV LV
      10/03/79 by J. A. Bush to copy terminal quota attributes out of old vtoce, into new one
      03/10/80 by Mike Grady to code around a compiler bug
      04/08/80 by Mike Grady to fix a bug in releasing of held pvtx's.
      03/20/81, W. Olin Sibert, to change for ADP PTW formats
      03/22/81, WOS, to only complain about illegal deactivations in segment fault case (not hphcs_)
      04/19/81, W. Olin Sibert, to stop maintaining aste.ic
      02/28/82, J. Bongiovanni, to eliminate obsolete vtoce.infqcnt, rework pvte refs,
      add demand_segmove entry and optimization of PV allocation
      08/18/82, J. Bongiovanni, for new pc$list_deposited_add and
      pc$deposit_list calling sequences
      10/26/82, J. Bongiovanni, for fm_damaged and synchronized segments
      831211, E. N. Kittlitz, for EHS moves, demand moves within a PV.
      84-01-03 BIM to finish the above.
      84-07-01 BIM to unthread one aste from get_aste before getting
      the other. Otherwise, you can get the same aste twice.
      1984-10-15 BIM to release pvtx's on failure.
      1984-12-18 BIM: to zero special SDW for synch segment (it has no trailer,
      so cannot be left around), and to sum$dirmod.
      1985-04-01, BIM: only rethread the ASTE once on failure.
*/

	dcl     a_astep		 ptr;		/* for efficiency */
	dcl     a_code		 fixed bin (35);	/* return error code */
	dcl     a_ep		 ptr;
	dcl     a_refaddr		 fixed bin (18);	/* referenced address, <0 if hphcs_ */
	dcl     a_segno		 fixed bin;	/* arg segno of reference */

	dcl     aste_uid		 bit (36) aligned;
	dcl     aste_tqsw		 (0:1) bit (1) aligned;
	dcl     cleanup_must_zero_sdw	 bit (1) aligned;
	dcl     code		 fixed bin (35);	/* temp var for that */
	dcl     corout_pvtx		 fixed bin;	/* control point for create_vtoce$createv_for_segmove */

	dcl     demand_segmove	 bit (1);
	dcl     depolist		 (0:255) bit (36) aligned;
						/* deposit array */
	dcl     dlp		 ptr;
	dcl     move_astep		 ptr;		/* Target ASTE if ehs segmove */
	dcl     held_pvtx		 bit (1);		/* flag, on if we held new pvtx */
	dcl     ignore		 fixed bin (35);	/* what it says */
	dcl     mod_status		 bit (1);		/* old seg fms status */
	dcl     n_nulled_pages	 fixed bin;
	dcl     new_pts		 fixed bin;
	dcl     new_ptsi		 fixed bin;
	dcl     new_pvid		 bit (36) aligned;
	dcl     new_pvtx		 fixed bin;
	dcl     new_vtocx		 fixed bin;
	dcl     old_nqsw		 bit (1);		/* setting of no quota sw */
	dcl     old_pts		 fixed bin;	/* old seg page table size */
	dcl     old_ptsi		 fixed bin;	/* old seg page table size index */
	dcl     old_pvid		 bit (36) aligned;
	dcl     old_pvtx		 fixed bin;
	dcl     old_vtocx		 fixed bin;
	dcl     optimizing		 bit (1) aligned;
	dcl     pageno_list		 (256) fixed bin;	/* Page number list */
	dcl     pvid		 bit (36);	/* New pvid, to go in branch when ready */
	dcl     pw1		 fixed bin;
	dcl     pw2		 fixed bin;
	dcl     qtype		 fixed bin;	/* seg/dir quota index */
	dcl     recs_needed		 fixed bin;	/* Target vol must have this many */
	dcl     ref_addr		 fixed bin (18);	/* address of fault */
	dcl     refpage		 fixed bin;	/* page of fault */
	dcl     same_pvtx		 bit (1);		/* flag, on new PVTX is same as old */
	dcl     segno		 fixed bin;	/* temp for segno of reference */
	dcl     size_needed		 fixed bin;	/* Size of new aste */
	dcl     skip_pvtx		 fixed bin;	/* pvtx for cv to skip */
	dcl     temp_ename		 char (32);
	dcl     time1		 fixed bin (71);
	dcl     time2		 fixed bin (71);
	dcl     tsdw		 fixed bin (71) aligned;
						/* Temp SDW stash */

	dcl     1 aq_cell		 like quota_cell aligned;
						/* auto copy of quota cell */
	dcl     1 atq_info		 like tq_info aligned;
						/* auto copy of tq_info */

	dcl     MAGIC_NPAGES	 fixed bin static init (10);
						/* if more than this many pages are nulled (found zero by PC), we will deposit them and retry the fault. */

	dcl     create_vtoce$createv_for_segmove
				 entry (ptr, bit (36), fixed bin, fixed bin (35), fixed bin, fixed bin, fixed bin,
				 ptr, bit (1) aligned);
	dcl     dbm_man$set_incr	 entry (fixed bin, fixed bin, fixed bin (35));
	dcl     get_aste		 entry (fixed bin) returns (ptr);
	dcl     get_ptrs_$given_astep	 entry (ptr) returns (fixed bin (71) aligned);
	dcl     get_pvtx$hold_pvtx	 entry (bit (36) aligned, fixed bin, fixed bin (35));
	dcl     get_pvtx$release_pvtx	 entry (bit (36) aligned, fixed bin);
	dcl     lock$lock_ast	 ext entry;
	dcl     lock$unlock_ast	 ext entry;
	dcl     logical_volume_manager$lvtep
				 entry (bit (36) aligned, ptr, fixed bin (35));
	dcl     pc$deposit_list	 entry (fixed bin, fixed bin, ptr, fixed bin, ptr);
	dcl     pc$list_deposited_add	 entry (ptr, fixed bin, fixed bin, fixed bin, ptr, ptr);
	dcl     pc$segmove		 entry (ptr, ptr, ptr, fixed bin, fixed bin, fixed bin, ptr, ptr, fixed bin (35));
	dcl     pds$process_group_id	 ext char (32) aligned;
	dcl     pmut$swap_sdw	 entry (ptr, ptr);
	dcl     put_aste		 entry (ptr);
	dcl     setfaults		 entry (ptr, bit (1) aligned);
	dcl     sum$dirmod		 entry (pointer);

	dcl     syserr		 entry options (variable);
	dcl     syserr$error_code	 entry options (variable);
	dcl     (
	        search_ast$hash_in,
	        search_ast$hash_out
	        )			 entry (pointer);
	dcl     thread$cin		 entry (ptr, bit (18));
	dcl     thread$out		 entry (ptr, bit (18));
	dcl     usage_values	 entry (fixed bin (17), fixed bin (71));
	dcl     vtoc_attributes$get_quota
				 entry (bit (36) aligned, bit (36) aligned, fixed bin, ptr, fixed bin,
				 fixed bin (35));
	dcl     vtoc_man$await_vtoce	 entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));
	dcl     vtoc_man$free_vtoce	 entry (bit (36) aligned, fixed bin, fixed bin, fixed bin (35));

	dcl     sys_info$page_size	 fixed bin external static;
	dcl     error_table_$log_vol_full
				 fixed bin (35) ext static;
	dcl     error_table_$illegal_deactivation
				 fixed bin (35) external;
						/* Sent if illegal seg for move */

	dcl     (addr, baseptr, divide, fixed, null, setwordno, unspec, wordno)
				 builtin;

%page;

/**** Entry conditions:

      DIRECTORY WRITE LOCKED
      AST LOCKED

*/

	demand_segmove = "0"b;			/* Called from seg_fault */
	ref_addr = a_refaddr;
	goto COMMON;

demand_segmove:
     entry (a_astep, a_ep, a_segno, a_code);

	demand_segmove = "1"b;			/* Called via hphcs_ */
	ref_addr = -1;

COMMON:
	call usage_values (pw1, time1);		/* Meter */
	code = 0;
	segno = a_segno;
	ep = a_ep;
	astep = null ();				/* temporary use only */
	move_astep = a_astep;			/* Current astep */

	dlp = addr (depolist);			/* in general, use automatic table for deposits */
	pvt_arrayp = addr (pvt$array);		/* for disk names and pvids */
	sstp = addr (sst_seg$);

	if move_astep -> aste.hc_sdw | move_astep -> aste.hc | move_astep -> aste.par_astep = "0"b
	then do;
		a_code = error_table_$illegal_deactivation;
						/* Only complain for seg-fault invocation, not hphcs_ */
		if ^demand_segmove
		then /* theory is that these will go away next bootload, anyway */
		     call syserr (LOG, "segment_mover: critical segment out of disk on ^a, segno/astep = ^o ^o",
			diskname ((move_astep -> aste.pvtx)), segno, wordno (move_astep));
		call lock$unlock_ast;
		return;				/* leave pack_ovfl bit on */
	     end;

/**** Don't attempt non-demand segmoves on single PV case.
      In the demand case, someone may have changed the sons_lvid to force a cross-LV move.
      If we happen to take an oopv after this sons_lvid has changed but before a demand
      move on the segment, we will move it within the old LV first. Oh well. */

	call logical_volume_manager$lvtep ((pvt_array (move_astep -> aste.pvtx).lvid), lvtep, code);
	if code = 0 & ^demand_segmove
	then if move_astep -> aste.pvtx = lvte.pvtex & pvt_array (move_astep -> aste.pvtx).brother_pvtx = 0
	     then do;
		     call lock$unlock_ast;
		     a_code = error_table_$log_vol_full;
		     return;
		end;

	/*** For synchronized segs, we must prevent any new held pages.
	     to do this, we must prevent any other process from modifying
	     a page of this segment. To do that, we cut its trailer with setfaults.
	     Once the trailer is cut, the segment is inaccessable until we release
	     the directory lock. */


	if move_astep -> aste.synchronized
	then do;
		call setfaults (move_astep, "0"b);	/* revoke all sdws */
		tsdw = get_ptrs_$given_astep (move_astep);
						/* but regenerate ours */
		call pmut$swap_sdw (baseptr (segno), addr (tsdw));
						/* back to normal */
		cleanup_must_zero_sdw = "1"b;		/* an SDW without a trailer is not permissible */
	     end;
	else cleanup_must_zero_sdw = "0"b;

	/*** Now we thread the segment out. Strictly speaking, only ^ehs
	     segments need this. However, we can race with other processes
	     on the ehs bit. It is simpler to always thread out.

	     The segment is threaded out to prevent deactivation. Deactivation,
	     while unlikely, would break the strategy. */

	call thread$out (move_astep, sst.ausedp (fixed (move_astep -> aste.ptsi, 2)));
	call search_ast$hash_out (move_astep);		/* we have to rethread on new vtocx */

/* Get modified/not modified status of old segment, and needed pages. */

	old_ptsi = fixed (move_astep -> aste.ptsi, 9);
	old_pts = sst.pts (old_ptsi);
	old_vtocx = move_astep -> aste.vtocx;
	old_pvtx = move_astep -> aste.pvtx;
	old_pvid = pvt_array (old_pvtx).pvid;

	call get_pvtx$hold_pvtx (old_pvid, old_pvtx, code);
	if code ^= 0
	then call syserr (CRASH, "segment_mover: get_pvtx(^o) fails under ast lock", old_pvtx);
	held_pvtx = "0"b;				/* Didn't grab second pvtx yet */

	mod_status = move_astep -> aste.fms;

	n_nulled_pages = 0;
	if ^move_astep -> aste.ddnp & ^(move_astep -> aste.fm_damaged & (sst.checksum_filemap ^= 0))
	then do;
		call pc$list_deposited_add (move_astep, 0, old_pts - 1, n_nulled_pages, dlp, addr (pageno_list));
						/* He means those nulled's */
		if n_nulled_pages > 0 & ^demand_segmove
		then do;
			call vtoc_man$await_vtoce (old_pvid, old_pvtx, old_vtocx, code);
						/* Wait out before deposit */
			if code ^= 0
			then go to retake_fault;
			call pc$deposit_list (fixed (move_astep -> aste.pvtx, 17), n_nulled_pages, dlp, old_vtocx,
			     addr (pageno_list));	/* Free the addresses */
			if n_nulled_pages > MAGIC_NPAGES & ^demand_segmove
			then do;			/* Avoid this hack for sweep_pv */
retake_fault:
				call thread$cin (move_astep, sst.ausedp (fixed (move_astep -> aste.ptsi, 2)));
				call search_ast$hash_in (move_astep);
				call cleanup_dseg_and_meter;
				if move_astep -> aste.uid = aste_uid
				then move_astep -> aste.pack_ovfl = "0"b;
				call release_pvtxs; /* wallow in his own soup */
				call lock$unlock_ast;
				a_code = code;	/* success or failure, depending ... */
				return;
			     end;
		     end;
	     end;

	recs_needed = n_nulled_pages + fixed (move_astep -> aste.records, 9);
						/* Assume he will regen those pages */
	refpage = divide (ref_addr, sys_info$page_size, 18, 0);
	size_needed = old_pts;			/* Cannot be oob, seg_fault would have caught it */
	aste_uid = move_astep -> aste.uid;		/* copy before AST unlock */
	aste_tqsw (*) = move_astep -> aste.tqsw (*);	/* ... */
	old_nqsw = move_astep -> aste.nqsw;		/* Get old nqsw */


	move_astep -> aste.nqsw = "1"b;		/* no quota checking whilst we play */

	new_ptsi, new_pts = -1;


	call lock$unlock_ast;			/* *** AST UNLOCKED *** */

	if aste_tqsw (0) | aste_tqsw (1)
	then do;					/* any terminal quota? */
		unspec (atq_info) = "0"b;		/* initialize structure */
		tq_infop = addr (atq_info);		/* and set ptr */
		qcp = addr (aq_cell);		/* set ptr for vtoc_attributes */
		do qtype = 0 to 1;			/* check for both seg and dir quota */
		     if aste_tqsw (qtype)
		     then do;			/* if terminal quota of this type.. */
			     call vtoc_attributes$get_quota (aste_uid, old_pvid, old_vtocx, qcp, qtype, code);
			     if code ^= 0
			     then /* we lose, log the error */
				call syserr$error_code (LOG, code,
				     "segment_mover: Moving ^[segment^;directory^] quota account from pvtx ^o, vtocx ^o^/",
				     qtype + 1, old_pvtx, old_vtocx);
			     else do;
				     tq_info.trp (qtype) = quota_cell.trp;
						/* copy pertinent info */
				     tq_info.tup (qtype) = quota_cell.tup;
				     tq_info.received (qtype) = quota_cell.received;
				end;
			end;
		end;
	     end;
	else tq_infop = null;			/* no terminal quota */

	temp_ename = addr (ep -> entry.primary_name) -> names.name;
	corout_pvtx = 0;				/* Prime corutine */
	optimizing = demand_segmove;			/* If hphcs_ call, attempt optimization */
	if demand_segmove
	then skip_pvtx = 0;				/* allow use of same pv if cv pleases */
	else skip_pvtx = old_pvtx;			/* if oopv then skip this pv */

next_pv:						/* RESTART POINT */
/**** ASSERT:  aste is thread$out'ed
      aste is search_ast$hash_out'ed
*/
	same_pvtx, held_pvtx = "0"b;
	call create_vtoce$createv_for_segmove (ep, pvid, new_vtocx, code, corout_pvtx, skip_pvtx, recs_needed, tq_infop,
	     optimizing);

/**** + Debug
      call syserr$error_code (ANNOUNCE, code, "sgm: pvid: ^w new_vtocx ^o corout_pvtx ^d skip_pvtx ^d recs_needed ^d ^[optimizing^].",
      pvid, new_vtocx, corout_pvtx, skip_pvtx, recs_needed, optimizing);
*/

	if code ^= 0
	then go to move_fails;
	new_pvtx = corout_pvtx;			/* This is selected place */
	if optimizing
	then do;					/* in case this PV fails, punt further optimization */
		optimizing = "0"b;			/* no more of this stuff */
		corout_pvtx = 0;			/* start from the beginning again */
	     end;
	new_pvid = pvid;				/* alignment */
	if new_pvtx = old_pvtx
	then same_pvtx = "1"b;
	else do;
		call get_pvtx$hold_pvtx (new_pvid, new_pvtx, code);
		if code = 0
		then held_pvtx = "1"b;
		else go to next_pv;
	     end;


	call MOVE_THE_SEGMENT;

	sstp -> sst.good_sgms = sstp -> sst.good_sgms + 1;
	if ^demand_segmove
	then /* Only for seg_fault calls */
	     call syserr (LOG, "segment_mover: Moved ^w(^a) from ^a to ^a for ^a", move_astep -> aste.uid, temp_ename,
		diskname (old_pvtx), diskname (new_pvtx), pds$process_group_id);
	move_astep = null ();
	call release_pvtxs;
	call cleanup_dseg_and_meter;
	a_code = 0;				/* That was easy, wasn't it !? */
	return;

move_fails:					/* Code is set appropriately */
	sstp -> sst.bad_sgms = sstp -> sst.bad_sgms + 1;	/* meter */
	if ^demand_segmove
	then call syserr$error_code (LOG, code, "segment_mover: Failed to seg move ^w(^a) from ^a for ^a",
		move_astep -> aste.uid, temp_ename, diskname (old_pvtx), pds$process_group_id);
	call lock$lock_ast;				/* AST LOCKED */
	call thread$cin (move_astep, sst.ausedp (fixed (move_astep -> aste.ptsi, 2)));
						/* put ASTE back the way we found it. */
	move_astep -> aste.pack_ovfl = "0"b;
	move_astep -> aste.nqsw = old_nqsw;
	call search_ast$hash_in (move_astep);
	call release_pvtxs;
	call lock$unlock_ast;			/* AST UNLOCKED */
	call cleanup_dseg_and_meter;
	a_code = code;
%page;


MOVE_THE_SEGMENT:
     procedure;
	dcl     astes		 (2) pointer;
	dcl     px		 fixed bin;

	code = 0;
	call lock$lock_ast;				/* *** AST LOCKED *** */

	do px = 1, 2;				/* old and new */
	     astep, astes (px) = get_aste (size_needed);
	     if astes (px) = null ()
	     then do;
		     code = error_table_$log_vol_full;	/* lie */
		     go to retake_fault;
		end;

	     call thread$out (astep, sst.ausedp (fixed (astep -> aste.ptsi, 2)));
						/* Thread out on 1 BEFORE getting 2. */
	end;
	astep = null ();

	call lock$unlock_ast;			/* seg is now protected from deactivation */

	astes (1) -> aste.nqsw, astes (1) -> aste.gtms, astes (1) -> aste.gtus = "1"b;
	astes (2) -> aste.nqsw, astes (2) -> aste.gtms, astes (2) -> aste.gtus = "1"b;
	astes (2) -> aste.pvtx = new_pvtx;		/* for pc_check_tables_ */

/**** depolist, n_nulled_pages, pageno_list describe the addresses from
      the old vtoce. */

	n_nulled_pages = 0;
	depolist = ""b;
	pageno_list = 0;
	code = 0;

	call pc$segmove (move_astep, astes (1), astes (2), new_pvtx, new_vtocx, n_nulled_pages, dlp, addr (pageno_list),
	     code);

/**** + Debug
      call syserr$error_code (ANNOUNCE, code, "sgm: new_pvtx ^d new_vtocx ^o n_to_deposit ^d.", new_pvtx, new_vtocx, n_nulled_pages);
*/

	call lock$lock_ast;				/* pc returns unlocked. */
	if code ^= 0
	then do;
		call put_aste (astes (1));
		astes (1) = null;
		call put_aste (astes (2));
		astes (2) = null ();
		call lock$unlock_ast;
		if code = error_table_$log_vol_full	/* try another pv */
		then do;
			call release_pvtxs;		/* free ptvx/pvid binding */
			go to next_pv;
		     end;
		else go to move_fails;		/* fatal error */
	     end;

	call thread$cin (move_astep, sst.ausedp (fixed (move_astep -> aste.ptsi, 2)));
						/* Okay, it goes back into replacement. Since move_fails and next_pv both expect it out, we delay this call to here. */

	move_astep -> aste.pack_ovfl = "0"b;		/* as good as it will ever be */
	move_astep -> aste.nqsw = old_nqsw;
	call search_ast$hash_in (move_astep);

	do astep = astes (1), astes (2);
	     call put_aste (astep);
	end;

	astep, astes (1), astes (2) = null;

	call lock$unlock_ast;			/* *** AST UNLOCKED *** */
	ep -> entry.pvid = pvid;			/* Make directory point right */
	ep -> entry.vtocx = new_vtocx;		/* Both these must complete */
	if ep -> entry.dirsw
	then do;
		dp = baseptr (segno);
		dp -> dir.vtocx = new_vtocx;
		dp -> dir.pvid = pvid;
		call sum$dirmod (dp);
	     end;
	else call sum$dirmod (setwordno (ep, 0));	/* Since this walks up, the above call includes this call */
	call release_old_vtoce;

     end MOVE_THE_SEGMENT;
%page;

cleanup_dseg_and_meter:
     procedure;

	if cleanup_must_zero_sdw
	then do;
		tsdw = 0;
		call pmut$swap_sdw (baseptr (segno), addr (tsdw));
						/* remove our SDW for this */
	     end;
	call usage_values (pw2, time2);		/* meter */
	sstp -> sst.sgm_time = sstp -> sst.sgm_time + time2 - time1;
	sstp -> sst.sgm_pf = sstp -> sst.sgm_pf + pw2 - pw1;

     end cleanup_dseg_and_meter;


diskname:
     proc (pvtx1) returns (char (9));
	dcl     pic99		 pic "99";
	dcl     pvtx1		 fixed bin;

	pvtep = addr (pvt_array (pvtx1));
	pic99 = pvte.logical_area_number;
	if ^pvte.is_sv
	then return (pvte.devname || "_" || pic99);
	else return (pvte.devname || "_" || pic99 || pvte.sv_name);

     end diskname;


release_old_vtoce:
     procedure;
	call dbm_man$set_incr (old_pvtx, old_vtocx, ignore);
	call vtoc_man$free_vtoce (old_pvid, old_pvtx, old_vtocx, code);
	if code = 0
	then call truncator (old_pvid, old_pvtx, old_vtocx);
	else do;
		call syserr$error_code (0, code, "segment_mover: freeing vtocx ^o on old pvtx ^o", old_vtocx,
		     old_pvtx);
		pvt_array (old_pvtx).vol_trouble_count = pvt_array (old_pvtx).vol_trouble_count + 1;
	     end;

     end release_old_vtoce;


release_pvtxs:
     proc;
	call get_pvtx$release_pvtx (old_pvid, old_pvtx);
	if held_pvtx
	then call get_pvtx$release_pvtx (new_pvid, new_pvtx);

     end release_pvtxs;


/**** Procedure to release the records from the old vtoce. */

truncator:
     procedure (a_pvid, a_pvtx, a_vtocx);

	dcl     (a_pvtx, a_vtocx)	 fixed bin;
	dcl     a_pvid		 bit (36) aligned;

	call vtoc_man$await_vtoce (a_pvid, a_pvtx, a_vtocx, code);
						/* make sure the free "took". */
	if code = 0
	then call pc$deposit_list (a_pvtx, n_nulled_pages, dlp, a_vtocx, addr (pageno_list));
	else do;
		call syserr$error_code (0, code, "segment_mover: finishing truncation of pvtx ^o vtocx ^o.", a_pvtx,
		     a_vtocx);
		pvt_array (a_pvtx).vol_trouble_count = pvt_array (a_pvtx).vol_trouble_count + 1;
	     end;

     end truncator;



/* format: off */
%page; %include aste;
%page; %include add_type;
%page; %include dir_entry;
%include dir_header;

%include dir_name;
%page; %include pvte;
%page; %include lvt;
%page; %include sst;
%page; %include tq_info;
%page; %include quota_cell;
%page; %include syserr_constants;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   segment_mover: critical segment out of disk on DRIVENAME, segno/astep = sss/aaa

   S: $info

   T: $run

   M: There are no more free pages on the physical volume where a critical
   segment resides, and an extra page can not be found for that segment.
   Such a critical segment may be a physical buffer segment for a
   peripheral device attached via IOI.
   The user process receives a seg_fault_error signal.

   A: The logical volume containing the pack residing on DRIVENAME
   may be too full, or may need rebalancing with the sweep_pv tool.
   $notify_sa

   Message:
   segment_mover: get_pvtx (PPP) fails under ast lock

   S: $crash

   T: $run

   M: The segment mover found that a physical volume appears to have been
   demounted during the time that the segment mover has had the active segment
   table locked. $err

   A: $recover

   Message:
   segment_mover: unexpected segfault

   S: $crash

   T: $run

   M: A segment fault occured during the cross-pack moving of a segment, but
   this segment fault was not on the segment on which the segment mover was
   expecting one. $err

   A: $recover
   There may be inconsistencies in the physical volumes involved. These can
   be corrected by a physical volume salvage.

   Message:
   segment_mover: freeing vtocx VVV on new pvtx PPP. ERRORMESSAGE

   S: $info

   T: $run

   M: The segment mover encountered an unexpected error in freeing
   the VTOC entry of a segment being moved on a volume to which an abortive
   attempt to move the segment was made.
   This may be a physical device error.

   A: $inform

   Message:
   segment_mover: threading error

   S: $crash

   T: $run

   M: The segment mover encountered bad threads while rethreading the old or new AST entries
   of  a segment involved in a cross-pack segment move.
   $err

   A: $recover

   Message:
   segment_mover: freeing vtocx VVV on old pvtx PPP ERRORMESSAGE

   S: $info

   T: $run

   M: During a cross-pack segment move, the system encountered an unexpected
   error in freeing the VTOC entry of the segment on the old pack
   This may be a physical device error, or
   may be indicative of a logic problem in the supervisor, or main memory or
   CPU problems.

   A: $inform

   Message:
   segment_mover: Moved UUUU(ENTRYNAME) from DRIVENAME1 to DRIVENAME2 for USERNAME

   S: $log

   T: $run

   M: The system has successfully moved a segment from the pack
   on DRIVENAME1 to the pack on DRIVENAME2, on a request for a new page on
   behalf of the user whose process group ID is USERNAME. UUUU is the
   unique ID of the segment, and ENTRYNAME its primary name.

   A: If a large number of these messages occur, the logical volume containing
   the packs specified by the drive names may be nearly full or
   poorly balanced. If these messages persist, contact the system
   administrator.

   Message:
   segment_mover: Failed to seg move UUU(ENTRYNAME) from DRIVENAME1 to DRIVENAME2 for USERNAME

   S: $log

   T: $run

   M: The system could not perform a cross-pack segment move because no pack
   in the logical volume had enough space to hold the segment. UUUU is the
   unique ID of the segment, and ENTRYNAME its primary name.

   A: If this message persists, the logical volume containing the packs
   on the drives noted is near full. In this case, contact the system
   administrator.

   Message:
   segment_mover: finishing truncation of pvtx PPP vtocx VVV

   S: $info

   T: $run

   M: The segment mover encountered an unexpected error in truncating
   either the old copy of a segment being moved cross-packs or in
   a new copy which was aborted for lack of space. This may be a physical
   device error, or may be indicative of a logic problem in the
   supervisor, or may be symptomatic of main memory or CPU problems.

   A: $inform

   Message:
   segment_mover: Moving QUOTA-TYPE quota account from pvtx PPP, vtocx VVV
   ERRORMESSAGE

   S: $log

   T: $run

   M: An error code was returned from the entry vtoc_attributes$get_quota when attempting to
   get terminal quota information from the old vtoce before new vtoce is created. In this case
   the terminal quota attributes for this QUOTA-TYPE  (either segment or directory) quota account
   is lost.

   A: If this occurs, the quota account for the segment that has been moved must be corrected
   manually by the System Administrator or other qualified site personell.


   END MESSAGE DOCUMENTATION */


     end segment_mover;




		    setfaults.pl1                   11/11/89  1101.2rew 11/11/89  0808.5      111177



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* format: style4 */
setfaults: proc (a_astep, a_recalculate_access);

/* Modified by B. Greenberg 4/24/74 for cache and v2pl1 */
/* Rewritten by R. Bratt 2/4/75 to restructure the code, clear associative memories, and add the disconnect entry */
/* Modified by R. Bratt 10/9/75  to adhere to nss locking strategies */
/* Modified by E. Stone 5/75 to retain access in the sdw, ie just to zero the df bits and the address */
/* Modified by D. Vinograd 6/76 to allow setfaulting of hardcore segs - used by the volume dumper */
/* Modified 03/21/81, W. Olin Sibert, for ADP SDW formats */
/* Reorganized, 04/17/81, WOS */
/* Modified 02/15/83, E. N. Kittlitz, added if_256K. */
/* Modified 08/09/83, E. N. Kittlitz, setfaults$if_active added pvid, vtocx args */
/*
   setfaults contains four entry points

   ---> setfaults$setfaults allows a process to disconnect all sdws from an active segment.
   As an optimization, if the setfaults is to cause access recalculation then the connected
   sdws have their fault bits set but they remain on the trailer. The associative memories
   of all processors are cleared. The ast is assumed to be locked.
   USAGE: call setfaults (astep, recalculate_access);

   ---> setfaults$if_active is used to setfaults when given a uid. It searches
   the ast and if the segment is active all connected sdws are faulted. See setfaults$setfaults.
   The ast is presumed to be unlocked.
   USAGE: call setfaults$if_active (uid, pvid, vtocx, recalculate_access);

   ---> setfaults$deltrailer is used to clean up a dead process.
   The ast is presumed to be locked!
   USAGE: call setfaults$deltrailer (astep, segno, dstep);

   ---> setfaults$disconnect is used to disconnect a segment number in the calling
   process from its aste. This code depends on  pmut$swap_sdw to clear this processors'
   sdw associative memory. The ast is assumed to be unlocked.
   USAGE: call setfaults$disconnect (segno);

   ---> setfaults$cache is used to set cache bits in all the sdws connected to an aste.
   The associative memories of all processors are cleared. The ast must be locked.
   USAGE: call setfaults$cache (astep, cache_bit);

   astep ptr --- aste pointer
   segno fixed bin(17) --- segment number to be disconnected
   uid bit (36) aligned --- unique identifier of segment of interest
   dstep fixed bin(17) --- relative descriptor segment aste pointer
   recalculate_access bit(1) aligned ---  set to cause access recalculation
   cache_bit bit(1) aligned --- bit to stuff into sdw cache bit

*/

/**/

dcl  a_astep ptr parameter;
dcl  a_cache_bit bit (1) aligned parameter;
dcl  a_segno fixed bin (17) parameter;
dcl  a_uid bit (36) aligned parameter;
dcl  a_pvid bit (36) aligned parameter;
dcl  a_rdstep fixed bin (17) parameter;
dcl  a_recalculate_access bit (1) aligned parameter;
dcl  a_vtocx fixed bin parameter;

dcl  dstep ptr;
dcl  (segno, rdstep) fixed bin (17);
dcl  uid bit (36) aligned;
dcl  pvid bit (36) aligned;
dcl  vtocx fixed bin;
dcl  cache_bit bit (1) aligned;
dcl  disconnect_any_msl bit (1) aligned;
dcl  sdwp pointer;

dcl  (set_cache_bit, process_all_trailers, recalculate_access) bit (1) init ("0"b);

dcl  pds$dstep bit (18) aligned external static;
dcl  sst$tfreep pointer external static;
dcl  sst$setfaults_acc fixed bin (35) external static;
dcl  sst$setfaults_all fixed bin (35) external static;
dcl  sys_info$system_type fixed bin external static;

dcl  sst_seg$ external static;
dcl  ds_seg$ (0:1023) fixed bin (71) external static;
dcl  dseg$ (0:1023) fixed bin (71) external static;

dcl  get_ptrs_$given_astep entry (ptr) returns (fixed bin (71));
dcl  get_ptrs_$given_segno entry (fixed bin) returns (ptr);
dcl  lock$lock_ast entry ();
dcl  lock$unlock_ast entry ();
dcl  page$cam entry ();
dcl  pmut$swap_sdw entry (ptr, ptr);
dcl  search_ast$check entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (35)) returns (ptr);
dcl  syserr ext entry options (variable);
dcl  thread$out ext entry (ptr, bit (18) aligned);

dcl  (addr, baseno, binary, null, ptr, rel) builtin;

/**/

	astep = a_astep;				/* copy the arguments */
	recalculate_access = a_recalculate_access;
	process_all_trailers = "1"b;
	set_cache_bit = "0"b;

	call process_trailers ();
	call page$cam ();
	return;					/* End of setfaults$setfaults */



setfaults$if_active: entry (a_uid, a_pvid, a_vtocx, a_recalculate_access);

	uid = a_uid;				/* copy these as service to caller */
	pvid = a_pvid;				/* avoid segfaults on directory */
	vtocx = a_vtocx;				/* if that's where formals are */
	recalculate_access = a_recalculate_access;
	process_all_trailers = "1"b;
	set_cache_bit = "0"b;

	call lock$lock_ast ();

	astep = search_ast$check (uid, pvid, vtocx, (0)); /* ignore double-uid error */
	if astep ^= null () then do;
	     call process_trailers ();
	     call page$cam ();
	end;

	call lock$unlock_ast ();
	return;					/* End of setfaults$if_active */


setfaults$cache: entry (a_astep, a_cache_bit);

	astep = a_astep;				/* copy arguments */
	cache_bit = a_cache_bit;			/* AST is locked */

	if sys_info$system_type = ADP_SYSTEM then do;	/* Oh yeah? */
	     call syserr (5, "setfaults: Ignoring setfaults$cache call for aste @ ^o on ADP system", astep);
	     return;
	end;

	recalculate_access = "0"b;
	set_cache_bit = "1"b;
	process_all_trailers = "1"b;

	if astep -> aste.strp = (18)"0"b then		/* should be trailers  */
	     call syserr (1, "setfaults: illegal cache  access trailer.");

	call process_trailers ();
	call page$cam ();
	return;					/* End of setfaults$cache */

/**/

setfaults$deltrailer: entry (a_astep, a_segno, a_rdstep);

	astep = a_astep;				/* copy arguments */
	segno = a_segno;
	rdstep = a_rdstep;

	recalculate_access = "0"b;
	process_all_trailers = "0"b;
	set_cache_bit = "0"b;

	call process_trailers ();
	return;					/* End of setfaults$deltrailer */



setfaults$disconnect: entry (a_segno);

	disconnect_any_msl = "1"b;
	go to disconnect_common;

setfaults$if_256K: entry (a_segno);

	disconnect_any_msl = "0"b;

disconnect_common:
	segno = a_segno;

	recalculate_access = "0"b;
	process_all_trailers = "0"b;
	set_cache_bit = "0"b;

	astep = get_ptrs_$given_segno (segno);		/* Does it seem active? */
	if astep = null () then return;

	rdstep = binary (pds$dstep, 18);

	call lock$lock_ast ();

	astep = get_ptrs_$given_segno (segno);		/* Still active ? */
	if astep ^= null () then
	     if disconnect_any_msl | bin (aste.msl) = 256 then
		call process_trailers ();

	call lock$unlock_ast ();
	return;

/**/

process_trailers: proc ();

dcl  thrtmp bit (18) aligned;				/* temporary for unthreading */
dcl  trp pointer;
dcl  next_trp pointer;

	if astep -> aste.hc then return;

	if ^set_cache_bit & process_all_trailers then do; /* if turning off access for all */
	     if ^astep -> aste.inhibit_cache then do;	/* let cache control know */
		astep -> aste.any_access_on = "0"b;
		astep -> aste.write_access_on = "0"b;
	     end;
	end;

	strp = ptr (sst$tfreep, 0);			/* get a pointer to the trailer segment */

	do trp = ptr (strp, astep -> aste.strp) repeat (next_trp) while (rel (trp));
	     next_trp = ptr (trp, trp -> str.fp);
	     dstep = ptr (addr (sst_seg$), trp -> str.dstep); /* get the DSEG ASTEP for this trailer */

	     if rel (dstep) = (18)"1"b then		/* check for bad trailer entry */
		call syserr (1, "setfaults: deleted trailer.");

	     if ^(dstep -> aste.ehs | (dstep -> aste.bp = "0"b)) then
		call syserr (1, "setfaults: illegal trailer");

	     if process_all_trailers
		| (binary (trp -> str.dstep, 18) = rdstep & binary (trp -> str.segno, 18) = segno)
	     then do;
		segno = binary (trp -> str.segno, 18);	/* get segno of the SDW of interest */

		call flush_this_sdw ();		/* Perform appropriate manipulations */

		if recalculate_access then do;	/* Meter */
		     sst$setfaults_acc = sst$setfaults_acc + 1;
		     sst$setfaults_all = sst$setfaults_all + 1;
		end;

		if (^recalculate_access) & (^set_cache_bit) then do; /* Must actually remove this one */
		     sst$setfaults_all = sst$setfaults_all + 1; /* Meter */

		     thrtmp = astep -> aste.strp;	/* thread this trailer out */
		     call thread$out (trp, thrtmp);	/* and zero its threads */
		     astep -> aste.strp = thrtmp;

		     trp -> str.fp = rel (sst$tfreep);	/* thread entry into free list */
		     sst$tfreep = trp;		/* set new free list pointer */
		     trp -> str.bp = "0"b;		/* for neatness */
		     trp -> str.dstep = "777777"b3;	/* wipe out the old dstep so check_trailer works */
		end;

		if ^process_all_trailers then return;	/* Got the one we wanted */
	     end;
	end;

	if ^process_all_trailers then call syserr (1, "setfaults: Missing trailer.");
						/* Looked everywhere and failed to find it */
	return;
     end process_trailers;

/**/

flush_this_sdw: proc ();

/* This procedure does whatever is appropriate to a single SDW. It sets up the abs_seg
   (we use ds_seg$) for this, modifies the SDW, and cleans it up. It expect dstep and
   segno to be set, to tell it what to do. */

dcl  ds_sdw fixed bin (71);


	ds_sdw = get_ptrs_$given_astep (dstep);		/* set up the address field of the SDW */
	call pmut$swap_sdw (addr (ds_seg$), addr (ds_sdw)); /* store the SDW into the DSEG abs_seg */

	sdwp = addr (ds_seg$ (segno));		/* The SDW in question */

	if sys_info$system_type = ADP_SYSTEM then do;
	     if set_cache_bit then ;			/* Oh yeah? -- ignore it */

	     else if recalculate_access then		/* Just turn it off */
		adp_sdw.valid = "0"b;

	     else do;
		adp_sdw.valid = "0"b;		/* Kill it completely */
		adp_sdw.add = ""b;
	     end;
	end;					/* of ADP SDW modifications */

	else do;
	     l68_sdw.df_no = "00"b;			/* For safety's sake */

	     if set_cache_bit then
		l68_sdw.cache = cache_bit;

	     else if recalculate_access then		/* Just turn it off */
		l68_sdw.valid = "0"b;

	     else do;
		l68_sdw.valid = "0"b;		/* Kill it completely */
		l68_sdw.add = ""b;
	     end;
	end;					/* of L68 SDW modifications */

	dseg$ (binary (baseno (addr (ds_seg$)), 17)) = 0; /* cleanup the abs_seg */

	return;
     end flush_this_sdw;

%page; %include system_types;
%page; %include aste;
%page; %include str;
%page; %include "sdw.l68";
%page; %include "sdw.adp";

/**/

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   setfaults: illegal cache access trailer

   S: $crash

   T: $run

   M: It was found that no record of processes connected to a
   segment (trailers) existed when the encacheability state of a segment
   had to be changed. Such change can only occur if processes are
   connected to the segment. $err

   A: Be sure to get a dump. $recover
   $notify

   Message:
   setfaults: deleted trailer

   S: $crash

   T: $run

   M: A trailer entry (record of a process's connection to a segment)
   for some segment was marked as free. $err


   A: $recover
   $inform

   Message:
   setfaults: illegal trailer

   S: $crash

   T: $run

   M: A trailer  entry (record of a process's connection to a segment)
   for some segment specifies a second segment as the descriptor
   segment for some process connected to that segment, but that second segment
   does not have certain bits on in its AST entry which would be on in the
   AST entry of a descriptor segment.
   $err

   A: $recover
   $inform

   Message:
   setfaults: missing trailer

   S: $crash

   T: $run

   M: Upon terminating a segment, it was found that
   no record of the process's connection to that segment (trailer)
   existed, even though an SDW for that segment appeared in
   the process's descriptor segment (i.e., the process was connected to it).
   $err

   A: $recover
   $notify

   END MESSAGE DOCUMENTATION */

     end setfaults;




		    shutdown_file_system.pl1        11/11/89  1101.2r w 11/11/89  0806.0       73998



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


shutdown_file_system: procedure ();

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

/* Procedure to effect storage system shutdown. The principal goal
   herein is to assign device addresses to all unwritten pages, write them out,
   and update all vtoces of active segments.  We operate on the assumption
   that AST threading is not to be trusted, and some ASTEs may be in the process of
   having their page tables filled.

   For the new Storage System, Bernard Greenberg, 10/20/75
   For demountable volumes, BSG 03/26/76
   For new flags in flagbox, 9/30/76 by Noel I. Morris
   For shutdown with downed drives, BSG 02/26/77
   For shutdown which doesn't give up, W. Olin Sibert, 05/18/81
   For set_procs_required, J. Bongiovanni, October 1981
   To remove Page Multilevel, C. Hornig, December 1981.
   Copied from shutdown, release stack_0's, eliminate FSDCT, J. Bongiovanni, March 1982
   For deactivate_for_demount, J. Bongiovanni, June 1982
   To eliminate RLV parasites, J. Bongioanni, August 1982
   For new ocdcm_$drain_io call... -E. A. Ranzenbach, 830620
   For pmut$bce K. Loepere 8/83
   */



dcl  sst$total_locks_set	        fixed bin external static;
dcl  sst$root_pvtx		        fixed bin external static;
dcl  sst$			        external static;
dcl  pvt$n_entries		        fixed bin external static;
dcl  pvt$root_pvtx		        fixed bin external static;
dcl  pvt$shutdown_state	        fixed bin external static;

dcl  deactivate_for_demount$shutdown  entry (fixed bin (35));
dcl  demount_pv		        entry (fixed bin, fixed bin (35));
dcl  fsout_vol		        entry (fixed bin, fixed bin);
dcl  grab_aste$release_prewithdraw    entry (ptr);
dcl  ocdcm_$drain_io	        entry ();
dcl  pc$flush		        ext entry;
dcl  pmut$bce		        entry;
dcl  syserr		        entry options (variable);
dcl  syserr$error_code	        entry options (variable);


dcl  code			        fixed bin (35);
dcl  drives_inop		        bit (1);
dcl  pvtx			        fixed bin;
dcl  stack_0_x		        fixed bin;

dcl  addr			        builtin;
dcl  ptr			        builtin;
dcl  unspec		        builtin;
%page;
	drives_inop = "0"b;

	pvt_arrayp = addr (pvt$array);

	call fsout_vol (pvt$root_pvtx, 0);		/* Get the fact out */

	call pc$flush;				/* Now get pages for homeless data in core */


/*  Release all stack_0 segments so that demount_pv can deactivate them  */

	sdtp = addr (stack_0_data$);
	sdt.freep = "0"b;

	do stack_0_x = 1 to sdt.num_stacks;
	     sdtep = addr (sdt.stacks (stack_0_x));
	     if sdte.astep ^= "0"b then do;		/* May be retry of shutdown */
		call grab_aste$release_prewithdraw (ptr (addr (sst$), sdte.astep));
		unspec (sdte) = "0"b;
	     end;
	end;

/*  Deactivate all non-hardcore segments, and revert deciduous segments */

	call deactivate_for_demount$shutdown (code);
	if code ^= 0
	then call syserr (ANNOUNCE, "shutdown_file_system: Error deactivating. Quota may be bad.");


/*  Demount all volumes except the rpv */

	do pvtx = 1 to pvt$n_entries;
	     pvtep = addr (pvt_array (pvtx));
	     if pvte.storage_system & pvte.used
	     then pvte.being_demounted = ^pvte.device_inoperative;
						/* Prime demount_pv */
	end;
	do pvtx = 1 to pvt$n_entries;
	     pvtep = addr (pvt_array (pvtx));		/* make_addressable */
	     if ^pvte.rpv & pvte.being_demounted then do; /* RPV will be last */
		call demount_pv (pvtx, code);
		if code ^= 0 then call syserr$error_code (ANNOUNCE, code, "shutdown_file_system: from demount_pv on ^o", pvtx);
	     end;
	     drives_inop = drives_inop | pvte.device_inoperative;
	end;

	if sst$total_locks_set > 0 then do;
	     pvt$shutdown_state = 3;
	     call syserr (ANNOUNCE, "shutdown_file_system: ^d locks set", sst$total_locks_set);
	end;
	else pvt$shutdown_state = 4;

	if drives_inop then do;
	     call syserr (BEEP, "shutdown complete except for devices suspended.");
	     call pc$flush;
	     call ocdcm_$drain_io ();			/* make sure I/O completes...		*/

	     do while ("1"b);
		call pmut$bce;
	     end;
	end;



	if pvt_array (sst$root_pvtx).used then		/* Maybe this is an esd retry */
	     call demount_pv (sst$root_pvtx, (0));	/* No error meaningful */


	fgbxp = addr (flagbox$);			/* Get pointer to the flagbox. */
	fgbx.ssenb = "0"b;				/* Storage system no longer enabled. */
	fgbx.shut = "1"b;				/* Shutdown has been completed. */


	call pc$flush;				/* Drain out log I/O */

	call syserr (ANNOUNCE, "shutdown complete");

	call ocdcm_$drain_io ();			/* quies the console...		*/

	do while ("1"b);
	     call pmut$bce;
	end;

/* That's all, folks. */


%page; %include pvte;
%page; %include flagbox;
%page; %include stack_0_data;
%page; %include syserr_constants;
%page;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   shutdown_file_system: from demount_pv on PVTX ERROR_MESSAGE

   S: $info

   T: System shutdown

   M: A problem was encountered in shutting down the
   disk whose PVT index is PVTX. Most likely, other messages
   identifying the pack, drive, and/or problem have
   preceded this message.

   A: $note
   If other messages have preceded this message, take
   remedial action as necessary. Attempt emergency shutdown after
   readying appropriate disk drives, if this is the problem.

   Message:
   shutdown_file_system: Error deactivating. Quota may be bad.

   S: $info

   T: System shutdown

   M: The attempt to deactivate all segments in the file system by a
   tree-walk of threaded ASTEs failed, likely due to inconsistent
   threading in the SST. The segments will be deactivated by a
   linear walk of the SST. Quota inconsistencies may be introduced by
   this. These can be corrected by a quota salvage of the hierarchy.

   A: At a convenient time, run a quota salvage of the hierarchy.

   Message:
   shutdown_file_system: NN locks set

   S: $info

   T: System shutdown

   M: Not all data base and directory locks were unlocked by
   the system before shutdown started. During emergency shutdown,
   this is to be expected. During normal shutdown,
   this may be symptomatic of software problems.

   A: If this message occurs during normal shutdown, note for
   system programming staff.

   Message:
   shutdown complete except for devices suspended.

   S: $beep

   T: System shutdown

   M: Some disks could not be shut down due to hardware problems.
   Messages have occurred identifying these drives and the problems.
   All other drives have been shut down- their contents are not
   in main memory or on the paging device. The RPV has
   not been shut down either, so that the system will perform
   some salvaging when it comes up.

   A: Attempt to ready those drives that are not ready. When this
   has been done, retry ESD. If the drives have been made accessible,
   ESD will succeed with a normal "shutdown complete" message. If
   they cannot be made ready, the paging device (if any) is unflushed.
   See the description of the "warning: paging device unflushed" message.

   Message:
   shutdown complete

   S: $info

   T: System shutdown

   M: System shutdown, emergency or regular, has completed successfully.
   The system will return to bce.  If any problem arises
   such that the system does not return to bce, or other error
   condition, the storage system will probably not be affected.
   If such problem arises, attempt ESD. The message "system already
   shut down" will be printed if there is no problem.
   When the "shutdown complete" message is issued, there is no more
   Multics information in main memory.


   END MESSAGE DOCUMENTATION */

     end;




		    switch_shutdown_file_system.alm 11/11/89  1101.2r w 11/11/89  0808.5       13275



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "
"
"	switch_shutdown_file_system
"
"	Switch stacks to inzr_stk0, call shutdown_file_system
"
"	Written March 1982 by J. Bongiovanni
"
" " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " " "

	name	switch_shutdown_file_system

	entry	switch_shutdown_file_system

switch_shutdown_file_system:

	eppsb	inzr_stk0$		" Stack to switch to
	epaq	sb|0			" Segno in AU
	als	1			" SDW index in AU
	sprisb	pds$stack_0_ptr		" Set stack_0 pointers
	eppbp	dseg$,au			" bp -> SDW for inzr_stk0
	spribp	pds$stack_0_sdwp	

	eppbp	sb|stack_header.stack_begin_ptr,* " Reset stack end pointer
	spribp	sb|stack_header.stack_end_ptr

	push				" Switch stacks

	call	shutdown_file_system$shutdown_file_system

	return				" Should never happen

"
	include	stack_header

	end




		    verify_lock.pl1                 11/11/89  1101.2r w 11/11/89  0808.5      203958



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */

/* format: style3 */

verify_lock:
     procedure;

/*

   verify_lock: called by signal_ before we leave ring 0.

   USAGE: call verify_lock;

   NOTES:
   1. If an error condition exist this proc will crash the system
   with an appropriate error message.

   Modification history:
   75-05-30, A. Bensoussan: Initial coding
   76-07-26, Greenberg: Modified to avoid online-salv recursion in pdir salv
   79-02-03, D. Spector: Modified to log only crawl-outs which unlock locks
   79-07-28, W. Olin Sibert: Modified to unlock all dir locks, even if
     they don't correspond to real dirs -- fixes Volume_Dumper lossage
     which causes notify timeouts when fake dir remains locked
   81-04-09, J. Bongiovanni: Modified to call vtoc_man$crawlout if vtoc
     buffer lock held, and to correct syserr logging of history registers
   82-02-23, BIM: Modified for improved dir locking and other stuff.
   82-04-01, J. Bongiovanni: Modified for PVT locks
   82-04-15, JIS: Changed to cleanup system_free_seg before checking lock array
   82-04-28, BIM: Modified for removal of system free seg entirely.
   83-01-18, BIM: Modified to cleanup of write_sw in dirlockt.
   83-03-12, BIM: Modified for readers in the dir_lock_seg_, better messages.
   83-08-05, Chris Jones: Modified for ioi_verify_lock.
   84-10-25, WOS: Changed for syserr_seg_manager$verify
   83-11-08, BIM: Change for better readers in dir_lock_seg_, check for masked.
   84-11-01, Keith Loepere to remove unused notion of directory detectability.
   85-02-21, EJ Sharpe: use syserr_fault_msg include for binary messages,
		added condition_nolog entrypoint for initial use by scavenger
   85-03-28, EJ Sharpe: chaged to log MC/HREG only if some lock unlocked for phx16862
   85-05-13, EJ Sharpe: added check for lock on dm_journal_seg_ 
*/

/****^  HISTORY COMMENTS:
  1) change(86-06-05,GJohnson), approve(86-06-05,MCR7387),
     audit(86-06-10,Martinson), install(86-07-11,MR12.0-1091):
     Correct error message documentation.
  2) change(86-10-23,Fawcett), approve(86-10-23,MCR7517),
     audit(86-10-30,Beattie), install(86-11-03,MR12.0-1206):
     Changed to remove the word BOS from Error message documentation.
                                                   END HISTORY COMMENTS */

dcl	1 dirs_locked	aligned,			/* remember them here, */
	  2 count		fixed bin,		/* so they can all be unlocked before */
	  2 array		(30) aligned,		/* any are salvaged */
	    3 seg_ptr	pointer,
	    3 uid		bit (36) aligned;

dcl	code		fixed bin (35);
dcl	cond_name		char (32);

dcl	check_masked	bit (1) aligned;
dcl	log_condition	bit (1) aligned;		/* flag indicating we should log this condition */
dcl	unlock_occurred	bit (1) aligned;		/* indicates something was force unlocked */
dcl	mcptr		ptr;
dcl	pvtx		fixed bin;
dcl	pagex		fixed bin;
dcl	p99		pic "99";
dcl	tsdw		fixed bin (71);

%include hc_lock;

dcl	condition_	entry (char (*), entry);
dcl	ioi_verify_lock	entry () returns (bit (1) aligned);
dcl	reversion_	entry (char (*));
dcl	syserr		entry options (variable);
dcl	syserr$binary	entry options (variable);
dcl	syserr$error_code	entry options (variable);
dcl	on_line_salvager	entry (ptr, fixed bin (35));
dcl	lock$dir_unlock_given_uid
			entry (bit (36) aligned);
dcl	lock$dir_lock_salvage
			entry (ptr, bit (36) aligned, fixed bin (35));
dcl	lock$unlock_fast	entry (ptr);
dcl	lock$lock_fast	entry (pointer);
dcl	pxss$notify	entry (bit (36) aligned);
dcl	get_pvtx$cleanup	entry () returns (bit (1) aligned);
dcl	debug_check	entry (char (4) aligned) returns (bit (1));
dcl	vtoc_man$crawlout	entry;
dcl	tty_lock$verify	entry () returns (bit (1) aligned);
dcl	syserr_seg_manager$verify_lock
			entry () returns (bit (1) aligned);
dcl	kstsrch		entry (bit (36) aligned, fixed bin (17), ptr);
dcl	page$write_volmap_page_unwired
			entry (ptr, fixed bin);
dcl	page$unlock_volmap	entry (ptr);
dcl	pmut$swap_sdw	entry (ptr, ptr);
dcl	pmut$read_mask	entry (fixed bin (71));
dcl	vtoce_stock_man$force_unlock
			entry (ptr);

dcl	pds$process_group_id
			external char (32) aligned;
dcl	pds$processid	external bit (36) aligned;
dcl	pds$block_lock_count
			external fixed bin (17);
dcl	scs$sys_level	fixed bin (71) external static;
dcl	error_table_$salv_pdir_procterm
			external fixed bin (35);
dcl	ahd$search_rules_lock
			external;
dcl	sst$astl		bit (36) aligned external static;
dcl	tc_data$system_shutdown
			external bit (1) aligned;
dcl	tc_data$lock_error_severity
			fixed bin external static;
dcl	pvt$n_entries	fixed bin external static;
dcl	volmap_abs_seg$	external static;

dcl	seg_fault_error	condition;
dcl	page_fault_error	condition;
dcl	subscriptrange	condition;

dcl	(addr, addrel, baseptr, convert, hbound, null, unspec)
			builtin;
%page;
/* MAIN PROGRAM */

	cond_name = "r0 process termination";
	check_masked = "0"b;
	mcptr = null;
	log_condition = "1"b;

start:
	if debug_check ("crwl")
	then call syserr (SYSERR_CRASH_SYSTEM, "verify_lock: Crawlout stop specified on PARM card.");

	unlock_occurred = "0"b;
	code = 0;

	if (syserr_seg_manager$verify_lock ())
	then call NOTE_UNLOCK ("syserr_log");

	call VERIFY_PVT_LOCKS;

	call VERIFY_VTOC_BUFFERS;

	if (ioi_verify_lock ())			/* logs own messages */
	then unlock_occurred = "1"b;

	call VERIFY_DBM;

	call VERIFY_DM_JOURNAL_SEG;

	if (get_pvtx$cleanup ())			/* logs own messages */
	then unlock_occurred = "1"b;

	call VERIFY_DIR_LOCK_SEG;

	call VERIFY_AST (code);
	if code ^= 0
	then call syserr (SYSERR_CRASH_SYSTEM, "verify_lock: Crawlout with AST lock set.");

	call VERIFY_SEARCH_RULES;

	if (tty_lock$verify ())			/* logs own messages */
	then unlock_occurred = "1"b;

	dirs_locked.count = 0;
	dirs_locked.seg_ptr (*) = null ();
	dirs_locked.uid (*) = (36)"0"b;

	call VERIFY_DIRECTORIES (code);
	if code ^= 0
	then call syserr (SYSERR_CRASH_SYSTEM, "verify_lock: Crawlout error on directory cleanup.");

	call SALVAGE_DIRECTORIES;

	if pds$block_lock_count ^= 0
	then call syserr (SYSERR_CRASH_SYSTEM, "verify_lock: block_lock_count ^d, should be 0", pds$block_lock_count);

	if check_masked
	then call VERIFY_MASKED;


	if log_condition & unlock_occurred
	then if mcptr = null
	     then call syserr (SYSERR_LOG_OR_PRINT, "verify_lock: ^a condition by ^a", cond_name, pds$process_group_id);
	     else call make_syserr_message (cond_name, mcptr);

	return;
%page;
/* These entry points are called when hardcore wants to log a message about the condition. */

verify_lock_bad_dir:
     entry (a_mcptr);

	cond_name = "bad_dir_";
	mcptr = null;
	check_masked = "1"b;
	log_condition = "1"b;
	go to start;

condition:
     entry (a_name, a_mcptr);

dcl	a_name		char (*);
dcl	a_mcptr		ptr;

	cond_name = a_name;
	mcptr = a_mcptr;
	check_masked = "1"b;
	log_condition = "1"b;
	go to start;


/* The following entrypoint is used by hardcore procedures which perform
their own logging of the condition. */

condition_nolog:
     entry (a_name, a_mcptr);

	cond_name = a_name;
	mcptr = a_mcptr;
	check_masked = "1"b;
	log_condition = "0"b;
	go to start;
%page;
VERIFY_VTOC_BUFFERS:
     proc;

	vtoc_buffer_segp = addr (vtoc_buffer_seg$);
	lock_ptr = addr (vtoc_buffer.lock);

	if lock.pid = pds$processid
	then do;
		call vtoc_man$crawlout;
		call lock$unlock_fast (lock_ptr);
		call NOTE_UNLOCK ("vtoc_buffer_seg");
	     end;
	else call CHECK_NOTIFY (lock_ptr);
	return;
     end VERIFY_VTOC_BUFFERS;
%page;
VERIFY_DBM:
     procedure;

%include dbm;
%page;
	dbmp = addr (dbm_seg$);
	lock_ptr = addr (dbm.lock_data);
	if lock.pid = pds$processid
	then do;
		call lock$unlock_fast (lock_ptr);
		call NOTE_UNLOCK ("dbm_seg");
	     end;
	else call CHECK_NOTIFY (lock_ptr);
	return;
     end VERIFY_DBM;
%page;
VERIFY_DM_JOURNAL_SEG:
     procedure;

%include dm_journal_seg_;
%page;
	dm_journal_segp = addr (dm_journal_seg_$);
	lock_ptr = addr (dm_journal.lock);
	if lock.pid = pds$processid
	then do;
		call lock$unlock_fast (lock_ptr);
		call NOTE_UNLOCK ("dm_journal_seg_");
	     end;
	else call CHECK_NOTIFY (lock_ptr);
	return;
     end VERIFY_DM_JOURNAL_SEG;
%page;
VERIFY_DIR_LOCK_SEG:
     procedure;

	dir_lock_segp = addr (dir_lock_seg$);
	lock_ptr = addr (dir_lock_seg.seg_lock);

	if lock.pid = pds$processid
	then do;
		call NOTE_UNLOCK ("dir_lock_seg");
		call lock$unlock_fast (lock_ptr);
	     end;
	else call CHECK_NOTIFY (lock_ptr);
	return;
     end VERIFY_DIR_LOCK_SEG;



VERIFY_AST:
     proc (code);

dcl	code		fixed bin (35);

	lock_ptr = addr (sst$astl);

	if lock.pid = pds$processid
	then do;
		code = 1;
	     end;
	else call CHECK_NOTIFY (lock_ptr);
	return;
     end VERIFY_AST;
%page;

/* Check for dir locks */


VERIFY_DIRECTORIES:
     procedure (code);

dcl	code		fixed bin (35);
dcl	i		fixed bin (17);
dcl	rx		fixed bin;
dcl	this_dir_locked	bit (1) aligned;

	code = 0;
	dir_lock_segp = addr (dir_lock_seg$);
	dir_lock_all_locksp = dir_lock_seg.header.locks_ptr;
	dir_lock_all_readersp = dir_lock_seg.header.readers_ptr;

LOOP_OVER_DIRS:
	do i = 1 to dir_lock_seg.header.highest_in_use;
	     this_dir_locked = "0"b;
	     dir_lockp = addr (dir_lock_all_dir_locks (i));
	     dir_read_lockers_ptr = addr (dir_lock_all_readers (i, 1));
	     if dir_lock.lock_count ^= 0
	     then do;
		     call lock$lock_fast (addr (dir_lock_seg.header.seg_lock));
						/* make sure this is for real */
		     if dir_lock.lock_count > 0
		     then if dir_lock.write_locker = pds$processid
			then this_dir_locked = "1"b;
			else ;			/* locked exclusively to someone else */
		     else if dir_lock.lock_count < 0
		     then /* read locked */
LOOP_OVER_LOCKERS:
			do rx = 1 to hbound (dir_read_lockers, 1);
			     if dir_read_lockers (rx) = pds$processid
			     then this_dir_locked = "1"b;
			end LOOP_OVER_LOCKERS;

		     call lock$unlock_fast (addr (dir_lock_seg.header.seg_lock));
		     if this_dir_locked
		     then call VERIFY_DIR (dir_lock.uid, (dir_lock.salvage_sw), (dir_lock.lock_count > 0));
		end;

	end LOOP_OVER_DIRS;
	return;

     end VERIFY_DIRECTORIES;


VERIFY_DIR:
     procedure (uid, salvage_sw, write_sw) options (non_quick);

dcl	uid		bit (36) aligned;
dcl	salvage_sw	bit (1) aligned;
dcl	write_sw		bit (1) aligned;

	dp = GET_SEG_PTR (uid);

	if salvage_sw				/* Salvager had it locked */
	then do;					/* Do nearly nothing */
		call syserr (SYSERR_LOG_OR_PRINT, "verify_lock: Crawlout while in directory salvager, dir (^w,^p).",
		     uid, dp);
		go to unlock_return;
	     end;

	if dp = null				/* This is not the KST uid, the dir may not even be there */
	then go to unlock_return;

	on seg_fault_error, page_fault_error go to NO_MODIFY_CHECK;
	if (dir.modify ^= pds$processid) & (dir.modify ^= ""b)
	then do;
		call syserr (tc_data$lock_error_severity, "verify_lock: dir.modify ^p ^w ^^= processid.", dp,
		     dp -> dir.modify);
	     end;

NO_MODIFY_CHECK:
	revert seg_fault_error, page_fault_error;

	on subscriptrange
	     call syserr (SYSERR_CRASH_SYSTEM, "verify_lock: more than ^d directories locked to process.",
		hbound (dirs_locked.seg_ptr, 1));

	dirs_locked.count = dirs_locked.count + 1;
(subscriptrange):
	dirs_locked.seg_ptr (dirs_locked.count) = dp;
	revert subscriptrange;

	dirs_locked.uid (dirs_locked.count) = uid;
unlock_return:
	call syserr (SYSERR_LOG_OR_PRINT, "verify_lock: Unlocking dir ^w. Locked for ^[read^]^[write^]^[, salvage^].",
	     uid, ^write_sw, write_sw, salvage_sw);
	unlock_occurred = "1"b;

	call lock$dir_unlock_given_uid (uid);		/* we may be one of many readers */

     end VERIFY_DIR;

SALVAGE_DIRECTORIES:
     procedure;

declare	dirx		fixed bin;
declare	uid		bit (36) aligned;

	if dirs_locked.count = 0
	then return;

	do dirx = 1 to dirs_locked.count;
	     call lock$dir_lock_salvage (dirs_locked.seg_ptr (dirx), uid, (0));
						/* get unique lock */

	     call syserr (SYSERR_LOG_OR_PRINT, "verify_lock: Salvaging dir ^p ^w on crawlout.", dp, uid);

	     call condition_ ("any_other", salvager_handler);

	     code = 0;

	     call on_line_salvager (dirs_locked.seg_ptr (dirx), code);

	     call reversion_ ("any_other");


	     if code = error_table_$salv_pdir_procterm
	     then call syserr$error_code (SYSERR_TERMINATE_PROCESS, code, "Terminating user process ^a: ",
		     pds$process_group_id);

CONTINUE_VERIFY_LOCK:
	     call lock$dir_unlock_given_uid (uid);	/* unlock it even if it isn't a real dir */
	end;
	return;

salvager_handler:
     procedure (mc_ptr, condition_name, wc_ptr, info_ptr, continue_flag);

declare	(mc_ptr, wc_ptr, info_ptr)
			pointer;
declare	condition_name	character (*);
declare	continue_flag	bit (1) aligned;


	call syserr (SYSERR_PRINT_ON_CONSOLE, "verify_lock: ^a condition by ^a while salvaging directory.",
	     condition_name, pds$process_group_id);

	if mc_ptr ^= null
	then call make_syserr_message (condition_name, mc_ptr);

	go to CONTINUE_VERIFY_LOCK;			/* unwind stack, running cleanup handlers */
						/* in salvager subsystem */
     end salvager_handler;

     end SALVAGE_DIRECTORIES;
%page;
VERIFY_PVT_LOCKS:
     procedure;

	pvt_arrayp = addr (pvt$array);
	do pvtx = 1 to pvt$n_entries;

	     pvtep = addr (pvt_array (pvtx));

	     if pvte.vtoc_map_lock = pds$processid
	     then do;
		     call vtoce_stock_man$force_unlock (pvtep);
		     call syserr (SYSERR_LOG_OR_PRINT,
			"verify_lock: Force unlocked VTOC Map lock (^a_^a^[^a^;^s^]) on crawlout for ^a", pvte.devname,
			convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name, pds$process_group_id);
		     pvte.vol_trouble_count = pvte.vol_trouble_count + 1;
		     tsdw = 0;
		     unlock_occurred = "1"b;
		     call pmut$swap_sdw (addr (volmap_abs_seg$), addr (tsdw));
		end;

	     if pvte.volmap_lock = pds$processid
	     then do;
		     call pmut$swap_sdw (addr (volmap_abs_seg$), addr (pvte.volmap_seg_sdw));
		     record_stockp = pvte.volmap_stock_ptr;
		     do pagex = 0 to record_stock.n_volmap_pages;
			call page$write_volmap_page_unwired (pvtep, pagex);
		     end;
		     call page$unlock_volmap (pvtep);
		     call syserr (SYSERR_LOG_OR_PRINT,
			"verify_lock: Force unlocked Volmap lock (^a_^a^[^a^;^s^]) on crawlout for ^a", pvte.devname,
			convert (p99, pvte.logical_area_number), pvte.is_sv, pvte.sv_name, pds$process_group_id);
		     tsdw = 0;
		     unlock_occurred = "1"b;
		     call pmut$swap_sdw (addr (volmap_abs_seg$), addr (tsdw));
		end;

	end;

     end VERIFY_PVT_LOCKS;
%page;
VERIFY_SEARCH_RULES:
     proc;

	if tc_data$system_shutdown
	then return;
	lock_ptr = addr (ahd$search_rules_lock);
	if lock.pid = pds$processid
	then do;
		call NOTE_UNLOCK ("search rules");
		call lock$unlock_fast (lock_ptr);
	     end;
	else call CHECK_NOTIFY (lock_ptr);
     end VERIFY_SEARCH_RULES;



VERIFY_MASKED:
     procedure;

declare	mask		fixed bin (71);

	call pmut$read_mask (mask);
	if mask = scs$sys_level
	then call syserr (SYSERR_CRASH_SYSTEM, "verify_lock: Crawlout while masked.");

	return;
     end VERIFY_MASKED;


CHECK_NOTIFY:
     proc (a_lock_ptr);

dcl	a_lock_ptr	ptr;

	lock_ptr = a_lock_ptr;
	if lock.pid = (36)"0"b & lock.flags.notify_sw = "1"b
	then call pxss$notify (lock.event);
	return;
     end CHECK_NOTIFY;


NOTE_UNLOCK:
     procedure (What_did_we_unlock);

declare	What_did_we_unlock	char (*);

	call syserr (SYSERR_LOG_OR_PRINT, "verify_lock: Unlocked ^a.", What_did_we_unlock);
	unlock_occurred = "1"b;
     end NOTE_UNLOCK;


GET_SEG_PTR:
     proc (uid) returns (ptr);

dcl	uid		bit (36) aligned;
dcl	segptr		ptr;

	call kstsrch (uid, (0), kstep);
	if kstep ^= null
	then segptr = baseptr (kstep -> kste.segno);
	else segptr = null;
	return (segptr);
     end GET_SEG_PTR;


make_syserr_message:
     procedure (cond_name, mcptr);

dcl	cond_name		character (*);
dcl	mcptr		pointer;
dcl	1 auto_fault_msg	aligned like fault_msg;	/* Machine conditions and history for syserr logging */
dcl	ssptr		pointer;			/* pointer to signaller stack frame */

	ssptr = addrel (mcptr, -8);			/* signaller_stack.pad is 8 words long! */
						/* Construct contiguous machine conditions and history registers */
	unspec (auto_fault_msg.mach_cond) = unspec (ssptr -> signaller_stack.mach_cond);
	auto_fault_msg.hist_reg = ssptr -> signaller_stack.history_registers;
	call syserr$binary (SYSERR_LOG_OR_PRINT, addr (auto_fault_msg), SB_verify_lock, SBL_verify_lock,
	     "verify_lock: ^a condition by ^a", cond_name, pds$process_group_id);
						/* Save machine cond (and history) if known */

     end make_syserr_message;

/* format: off */

%page; %include dir_header;
%page; %include dir_lock_seg_;
%page; %include kst;
%page; %include pvte;
%page; %include signaller_stack;
%page; %include stock_seg;
%page; %include syserr_binary_def;
%page; %include syserr_constants;
%page; %include syserr_fault_msg;
%page; %include mc;
%page; %include vtoc_buffer;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   verify_lock: Crawlout stop specified on PARM card.

   S:	$crash

   T:	$run

   M:	The system PARM card specified the CRWL parameter.
   A process is attempting to crawl out.
   This message will occur so that system programmers can take a dump.

   A:	Take a dump.
   Issuing the BCE go command
   will cause the system to continue.

   Message:
   verify_lock: Crawlout with AST lock set.

   S:	$crash

   T:	$run

   M:	A user process encountered
   a condition while processing with the AST locked.
   This condition may have been due to a
   hardware or software failure.
   $crashes

   A:	$recover

   Message:
   verify_lock: Crawlout error on directory cleanup.

   S:	$crash

   T:	$run

   M:	A process encountered a signalled condition
   with one or more directories locked.
   Before the system causes a crawlout,
   it unlocks and salvages
   all locked directories for the process.
   This process of cleanup encountered an unrecoverable error.
   $crashes

   A:	$recover

   Message:
   verify_lock: block_lock_count XX, should be 0

   S:	$crash

   T:	$run

   M:	A process has encountered
   a condition in ring 0,
   and is in the process of attempting a crawlout.
   The system must unlock all locks
   before it performs the crawlout;
   all known locks have been unlocked
   but the process' lock counter is still nonzero.
   $err
   $crashes

   A:	$recover

   Message:
   verify_lock: NAME condition by PERS.PROJ

   S:	$log

   T:	$run

   M:	User PERS.PROJ encountered a NAME condition in ring 0.
   The system attempts to unlock and reset all ring 0 data bases
   locked by the process.

   A:     These messages almost always indicate benign errors in
   the supervisor. They should be reported, nonetheless. They are
   accompanied by the binary machine condition information.
   This message is logged only when the condition occured while
   some ring-0 lock was set.  One or more messages preceeding
   this one will indicate which locks were held by the process
   and forcibly reset.

   Message:
   verify_lock: Crawlout while in directory salvager, dir (UID,PTR).

   S:	$log

   T:	$run

   M:	A process faulted while salvaging a dir on crawlout.

   A:     $ignore

   Message:
   verify_lock: dir.modify PPPP WWWW ^^= processid.

   S:	$crash

   T:	$run

   M:	A process is attempting to crawl out.
   The system has discovered that a directory
   which is marked locked to the process
   has its "modify" field
   not equal to the processid of the process.
   $err
   $crashes

   A:	$recover

   Message:
   verify_lock: more than N directory locks locked to process.

   S:     $crash

   T:     $run

   M:     The process held more dir locks than verify lock
   could store for later salvaging. This indicates a logic error
   in the supervisor.

   A:    $crashes
   $recover

   Message:
   verify_lock: Unlocking dir UUUUUUUUUUUU. Locked for READ_OR_WRITE {,salvage}.

   S:	$log

   T:	$run

   M:	The directory with UID UUUUUUUUUUUU was found locked at crawl-out
   time. It is salvaged and then unlocked.

   A:	$inform

   Message:
   verify_lock: Salvaging dir PTR UID on crawlout.

   S:	$log

   T:	$run

   M:	This message is displayed for each directory found locked on a
   crawlout.  The online salvager will be called and the directory unlocked.

   A:	$ignore

   Message:
   Terminating user process NAME: Fatal salvaging of process directory.

   S:	$term

   T:	$run

   M:	A process is attempting to crawl out. The system discovered that
   the process was interrupted while its process directory was locked, and has
   salvaged the process directory. Salvaging the process directory may delete
   critical process segments and cause the process to terminate, so the process
   is terminated cleanly instead.

   A:	$ignore

   Message: 
   verify_lock: COND condition by USER while salvaging directory.

   S:	$announce

   T:	$salvt

   M:	A fault occurred while salvaging a directory found locked at
   crawlout. This indicates a serious problem with the directory.

   A:	$inform

   Message:
   verify_lock: Force unlocked VTOC Map lock (dskX_NN) on crawlout for PERSON.PROJECT.TAG

   S:     $log

   T:	$run

   M:	The VTOC Map lock for the device indicated was found locked to the
   process on crawlout. The lock has been reset, and the count of volume
   inconsistencies has been incremented by one.

   A:     Any free records or VTOCEs lost because of the crawlout can be
   recovered by a volume salvage.

   Message:
   verify_lock: Force unlocked Volmap lock (dskX_NN) on crawlout for PERSON.PROJECT.TAG

   S:     $log

   T:	$run

   M:	The Volmap Lock for the device indicated was found locked to a
   process on crawlout. The lock has been reset, and the count of volume
   inconsistencies for the device has been incremented by one.

   A:     Any free records or VTOCEs lost because of the crawlout can
   be recovered by a volume salvage.

   Message:
   verify_lock: Crawlout while masked.

   S:	$crash

   T:	$run

   M:	$crashes

   A:	$inform

   Message:
   verify_lock: Unlocked LOCK.

   S:	$log

   T:	$run

   M:	The lock LOCK was found locked at crawlout and unlocked.

   A:	$ignore

   END MESSAGE DOCUMENTATION */

     end verify_lock;





		    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
