



		    cumulative_page_trace.pl1       06/04/84  1613.8rew 06/04/84  1241.7      212202



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


cumulative_page_trace: cpt: proc;

/*
   Additional control arguments:

   -length n, -lg n  format output with line length n.
*/

/* coded	Feb 10, 1971	J.W. Gintell */
/* modified June, 1974 for new system trace in 23.10 - MCR 598  */
/* modified June 1975 by John Gintell for MCR's 957,970, and 1060 */
/* modified Aug 1976 by John Gintell to make cleanup condition handler work */
/* modified July 1977 by John Gintell to add linkage fault trace, segment fault counting and default -int 500 */
/* modified January 81 by J. Bongiovanni to avoid fatal process error due to
          record quota overflow in pdir, add -temp_dir  */
/* modified January 82 by J. Bongiovanni for extended page fault type */

		        
		        

dcl  hcs_$high_low_seg_count external entry (fixed bin, fixed bin);
dcl  hcs_$trace_marker entry (char (4));
dcl  hcs_$make_seg external entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin(35));
dcl  hcs_$truncate_seg external entry (ptr, fixed bin, fixed bin(35));
dcl  hcs_$delentry_seg entry (ptr, fixed bin(35));
dcl  absolute_pathname_ entry (char(*), char(*), fixed bin(35));
dcl  ioa_ external entry options (variable);
dcl  ioa_$rsnnl external entry options (variable);
dcl  ioa_$ioa_switch external entry options (variable);
dcl  page_trace$print_trace_entry entry (ptr, ptr, bit (1) aligned);
dcl  cv_bin_$oct external entry (fixed bin (11)) returns (char (12) aligned);
dcl  iox_$find_iocb entry (char (*), ptr, fixed bin(35));
dcl  iox_$attach_iocb entry (ptr, char (*), fixed bin(35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin(35));
dcl  iox_$close entry (ptr, fixed bin(35));
dcl  iox_$detach_iocb entry (ptr, fixed bin(35));
dcl  com_err_ external entry options (variable);
dcl  cv_dec_check_ external entry (char (*), fixed bin(35)) returns (fixed bin);
dcl  cu_$arg_ptr external entry (fixed bin, ptr, fixed bin, fixed bin(35));
dcl  cu_$arg_count external entry returns (fixed bin);
dcl  cu_$cp external entry (ptr, fixed bin, fixed bin(35));
dcl  hcs_$get_page_trace external entry (ptr);
dcl  hcs_$fs_get_path_name external entry (ptr, char (*), fixed bin, char (*), fixed bin(35));
dcl  interpret_bind_map_ entry (ptr, char (*), fixed bin, fixed bin(35));
dcl  get_entry_name_ entry (ptr, char (*), fixed bin, char (8), fixed bin(35));
dcl  ring0_get_$name external entry (char (*), char (*), ptr, fixed bin(35));
dcl  ring0_get_$definition external entry (ptr, char (*), char (*), fixed bin, fixed bin, fixed bin(35));
dcl  ring_zero_peek_ entry (ptr, ptr, fixed bin, fixed bin(35));
dcl (null, addr, baseptr, max, fixed, substr, divide, ltrim, ptr, rel, binary, baseno, stackframeptr, hbound) builtin;
dcl  timer_manager_$sleep external entry (fixed bin (71), bit (2));
dcl  timer_manager_$cpu_call external entry (fixed bin (71), bit (2), entry);
dcl  timer_manager_$reset_cpu_call external entry (entry);

dcl  sys_info$max_seg_size external fixed bin (19);
dcl  highpage fixed bin static;
dcl  myname char (21) static options (constant) init ("cumulative_page_trace");

%include trace_types;
%include sys_trace;


dcl (cleanup, not_in_read_bracket, record_quota_overflow) condition;

dcl 1 trace_copy aligned like trace;

dcl  char4 char (4) based;
dcl  cptb char (4);
dcl  cpte char (4);					/* marker */
dcl  counter fixed bin static init (0);			/* counter for marker */

dcl 1 seg (0:1023) aligned based (datap),		/* array of counters, one for each page of each segment */
    2 any bit (1) unaligned,				/* = 1 if any pages seen in this segment */
    2 segf fixed bin (16) unaligned,
    2 total_no_page fixed bin (17) unaligned,		/* number of pages touched for this segment */
    2 total_no_pagef fixed bin (35),			/* total number of faults for this segment */
    2 page (0:255) fixed bin (8) unaligned;
dcl  datap ptr static;				/* pointer to data segment */
dcl  packedptr ptr unal based;
dcl  unpackedptr ptr;

dcl 1 linkfaults based (linkp),
    2 nextlp fixed bin,
    2 elem (0:131070),
      3 fromptr ptr unal,
      3 toptr ptr unal;
dcl  linkp ptr init (null) static;

dcl  seg_no fixed bin (11);
dcl  type fixed bin (5);
dcl  page_no fixed bin (11);
dcl  beg_found bit (1);				/* used during scan to mark when in good zone */
dcl  beg_found1 bit (1);
dcl  end_found bit (1);				/* used during scan to indicate when end marker found */

dcl  total_pages fixed bin init (0);
dcl  total_segf fixed bin init (0);
dcl  total_pfaults fixed bin init (0) static;

dcl  flushptr (0:63) ptr init ((64) null);
dcl  qoverflow bit (1) init (""b);
dcl  make_seg_failed bit (1) init (""b);
dcl  flushp_index fixed bin;
dcl  zzzzz9 pic "zzzzz9";
dcl  flushi fixed bin;
dcl 1 flush_seg based aligned,
    2 page (0:255),
      3 word (0:1023) fixed bin;
dcl  garbage fixed bin;
dcl  nused fixed bin;
dcl  nused_ptr ptr init (null);
dcl  nused_offset fixed bin;
dcl (last_blockno) fixed bin;
dcl  deftype fixed bin;

dcl  dirname char (168);
dcl  ename char (32);				/* returned name of segment */
dcl  comp_name char (8);
dcl  callee_name char (32);
dcl  caller_ename char (32);
dcl  entry_name char (32);
dcl  offset fixed bin;
dcl  char32 char (32);
dcl  path char (168);				/* pathname for ios_ call */
dcl  pnum char (8);					/* string in which to put page number */
dcl  pnumb char (pnumbl) based (addr (pnum));
dcl  pnumbl fixed bin;				/* length of page number string */
dcl  arg char (len) based (aptr);			/* argument string from cu_$arg_ptr */
dcl  len fixed bin;
dcl  aptr ptr;					/* pointer to argument returned by cu_$arg_ptr */
dcl  iocbp ptr;					/* pointer to iocb for cpt.out */
dcl  dump_iocbp ptr;				/* pointer to iocb for cpt.dump, user must attach open */
dcl  command char (132);				/* command string */
dcl  comptr ptr;
dcl  comlen fixed bin;				/* length of command string */
dcl  pstring char (256) ;				/* place in which to build page number string */
dcl  pstringf char (lstr) based (addr (pstring));
dcl (i, j, k, high_seg) fixed bin;
dcl  code fixed bin (35);
dcl  maxhigh fixed bin static init (0);
dcl  timersw bit (1) init (""b);
dcl  ignoreint bit (1) init ("0"b);
dcl  save_ignoreint bit (1);
dcl  look_for_timers bit (1) init ("0"b);
dcl  look_for_restart bit (1) init ("0"b);
dcl  noise bit (1) ;				/* if we suspect noise in data */
dcl  tempdsw bit (1) init ("0"b);
dcl  temp_dir_name char (168);

dcl (countsw, loopsw, flushsw, sleepsw, printsw, totalsw, resetsw, comsw, debugsw, tracesw) bit (1) init (""b);
dcl  intsw bit (1) init ("1"b);
dcl (linksw, printlinksw) bit (1) init (""b);
dcl  nocaller bit (1);
dcl  longsw bit (1) aligned init (""b);
dcl  loopcnt fixed bin init (0);			/* count of number of loops requested */
dcl  totalloop fixed bin static;			/* total number of iterations */
dcl  sleeptime fixed bin (71);			/* length of sleep time */
dcl  inttime fixed bin (71) init (500000);		/* length of CPU interrupt interval */
dcl  totalint fixed bin init (0);			/* total number of interrupts */
dcl  lstr fixed bin;				/* length of page number string mod line */
dcl  maxlstr fixed bin init (80);			/* max length */

dcl  firstinit bit (1) static init ("1"b);		/* initialization switch */
dcl  hcsc fixed bin static;				/* hardcore segment count */

	if firstinit then do;			/* first time initialization */

	     highpage = divide (sys_info$max_seg_size, 1024, 17, 0) - 1;
	     call hcs_$high_low_seg_count (high_seg, hcsc); /* get high hardcore segment count */
	     call hcs_$make_seg ("", "cpt.data", "", 01010b, datap, code);
	     if datap = null then do;
TEMPERR:		call com_err_ ((code), myname, "Couldn't make temp seg.");
		return;
	     end;
	     call hcs_$make_seg ("", "cpt.link", "", 01010b, linkp, code);
	     if linkp = null then goto TEMPERR;
	     call reset;

	     firstinit = ""b;
	end;

/* obtain all arguments given to command */
	do i = 1 to cu_$arg_count ();

	     call cu_$arg_ptr (i, aptr, len, code);
	     if code = 0 then do;

		if arg = "-flush" then flushsw = "1"b;
		else if arg = "-trace" then do;
		     tracesw = "1"b;
		     call attach (iocbp, "cpt.out");
		     if code ^= 0 then goto ARGERR;
		end;
		else if arg = "-sleep" then do;
		     sleepsw = "1"b;
		     i = i +1;
		     call cu_$arg_ptr (i, aptr, len, code);
		     if code ^= 0 then go to ARGERR;
		     sleeptime = cv_dec_check_ (arg, code);
		     if sleeptime <= 0 | code ^= 0 then go to ARGERR;
		end;
		else if arg = "-loop" then do;
		     loopsw = "1"b;
		     i = i +1;
		     call cu_$arg_ptr (i, aptr, len, code);
		     if code ^= 0 then go to ARGERR;
		     loopcnt = cv_dec_check_ (arg, code);
		     if loopcnt <= 0 | code ^= 0 then go to ARGERR;
		end;
		else if arg = "-interrupt" | arg = "-int" then do;
		     intsw = "1"b;
		     i = i + 1;
		     call cu_$arg_ptr (i, aptr, len, code);
		     if code ^= 0 then go to ARGERR;
		     inttime = cv_dec_check_ (arg, code);
		     if inttime < 100 | code ^= 0 then goto ARGERR;
		     inttime = inttime * 1000;
		end;
		else if arg = "-temp_dir" | arg = "-td" then do;
		     tempdsw = "1"b;
		     i = i + 1;
		     call cu_$arg_ptr (i, aptr, len, code);
		     if code ^= 0 then goto ARGERR;
		     call absolute_pathname_ (arg, temp_dir_name, code);
		     if code ^= 0 then goto ARGERR;
		end;
		else if arg = "-reset" | arg = "-rs" then resetsw = "1"b;
		else if arg = "-trace_linkage_faults" then linksw = "1"b;
		else if arg = "-print_linkage_faults" then printlinksw = "1"b;
		else if arg = "-count" | arg = "-ct" then countsw = "1"b;
		else if arg = "-print" | arg = "-pr" then printsw = "1"b;
		else if arg = "-total" | arg = "-tt" then totalsw = "1"b;
		else if arg = "-shortline" | arg = "-short" | arg = "-sh" then maxlstr = 48;
		else if arg = "-timers" then timersw = "1"b;
		else if arg = "-long" | arg = "-lg" then longsw = "1"b;
		else if arg = "-length" | arg = "-ln" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, aptr, len, code);
		     if code ^= 0 then goto ARGERR;
		     maxlstr = cv_dec_check_ (arg, code);
		     if maxlstr < 48 | code ^= 0 then goto ARGERR;
		     if maxlstr > 130 then goto ARGERR;
		     maxlstr = maxlstr - 32;
		end;
		else if substr (arg, 1, 1) = "-" then goto ARGERR;
		else if ^comsw then do;		/* this is command string */
		     command = arg;			/* copy since must be aligned */
		     comsw = "1"b;
		     comlen = len;
		     if ^loopsw then loopcnt = 1;
		end;
		else do;
ARGERR:		     call com_err_ (code, myname, "Invalid argument - ^a", arg);
		     return;
		end;
	     end;
	end;

	if fixed (printsw) + fixed (countsw) + fixed (totalsw) > 1 then do;
	     call com_err_ ((0), myname, "Only one of -count, -print, and -total may be specified");
	     return;
	end;
	if countsw | totalsw then printsw = "1"b;

	if ^(comsw | printsw | resetsw | printlinksw) then do;
	     call com_err_ ((0), myname, "No printing requests or command string was given.");
	     return;
	end;


	if resetsw then call reset;
	on condition (cleanup) call cleaner;
	comptr = addr (command);

/* Now start the calling and accumulation of page trace data */

	do j = 1 to loopcnt;

	     if intsw then do;
		call timer_manager_$cpu_call (inttime, "10"b, timer);
		look_for_timers = ^timersw;
		ignoreint = "0"b;
	     end;

	     cptb = nexts ();
	     cpte = nexts ();
	     if flushsw then call flush;
	     call hcs_$trace_marker (cptb);

	     if comsw then call cu_$cp (comptr, comlen, code);

	     ignoreint = "1"b;

	     call hcs_$trace_marker (cpte);
	     call hcs_$get_page_trace (addr (trace_copy));

	     if intsw then do;
		call timer_manager_$reset_cpu_call (timer);
		look_for_timers = "0"b;
	     end;


	     call get_trace;			/* get page trace data */

	     if sleepsw then if j ^= loopcnt then call timer_manager_$sleep (sleeptime, "11"b);

	end;

	if intsw & totalint ^= 0 then call ioa_ ("cumulative_page_trace: There were ^d interrupts.^/", totalint);
	if qoverflow then call ioa_ ("cumulative_page_trace:  Insufficient quota to flush all pages.");
	if printsw then call print;
	if printlinksw then call printlinks;

	call cleaner;

cleaner:	proc;
	     if intsw then call timer_manager_$reset_cpu_call (timer);
	     if tracesw then call detach (iocbp, "cpt.out");
	     if debugsw then call detach (dump_iocbp, "cpt.dump");
	     if flushsw then do flushp_index = 0 to hbound (flushptr, 1);
		if flushptr (flushp_index) ^= null then do;
		     call hcs_$delentry_seg (flushptr (flushp_index), code);
		     flushptr (flushp_index) = null;
		end;
	     end;
	     
     return;
	end cleaner;

detach:	proc (a_iocbp, a_switchname);
dcl  a_iocbp ptr;					/* pointer to iocb */
dcl  a_switchname char (*);

	     call iox_$close (a_iocbp, code);
	     if code ^= 0 then call iox_err;

	     call iox_$detach_iocb (a_iocbp, code);
	     if code ^= 0 then call iox_err;

iox_err:	     proc;

		call com_err_ (code, myname, a_switchname);

	     end iox_err;

	end detach;

attach:	proc (a_iocbp, a_switchname);

dcl  a_iocbp ptr;
dcl  a_switchname char (*);

	     i = i + 1;
	     call cu_$arg_ptr (i, aptr, len, code);
	     if code ^= 0 then return;
	     path = arg;
	     call iox_$find_iocb (a_switchname, a_iocbp, code);
	     if code ^= 0 then return;
	     call iox_$attach_iocb (a_iocbp, "vfile_ "||path||" -extend", code);
	     if code ^= 0 then return;
	     call iox_$open (a_iocbp, 2, "0"b, code);
	     if code ^= 0 then return;

	end attach;

get_trace: procedure;

	     beg_found, beg_found1, end_found, noise = ""b;
	     if tracesw then call ioa_$ioa_switch (iocbp, "^/");

AGAIN:	     do i = trace_copy.next_free + 1 to trace_copy.last_available, 1 to trace_copy.next_free;

		trace_ptr = addr (trace_copy.data (i));
		type = page_trace_entry.type;

		if type = extended_page_fault_type then do;
		     seg_no = binary (extended_page_trace_entry.tsr_segno_1
			|| extended_page_trace_entry.tsr_segno_2, 12);
		     page_no = extended_page_trace_entry.tsr_pageno;
		end;
		else do;
		     seg_no = page_trace_entry.segment_number;
		     page_no = page_trace_entry.page_number;
		end;
		
		if ^beg_found then do;
		     if type = marker_type & addr (trace_copy.data (i)) -> char4 = cptb then do;
			if look_for_restart then beg_found1 = "1"b;
			else beg_found = "1"b;
		     end;
		     else if look_for_restart & beg_found1 then if type = restart_fault_type then beg_found = "1"b;
		     goto SKIP;
		end;

		if type = marker_type & addr (trace_copy.data (i)) -> char4 = cpte then do;
		     end_found = "1"b;
		     goto DONE;
		end;

		else if type = signaller_type & look_for_timers & addr (trace_copy.data (i)) -> char4 = "cput" then do;
		     end_found = "1"b;
		     goto DONE;
		end;

		else if linksw & type = linkage_fault_start then call linkfaultstart;

		else if linksw & type = linkage_fault_end then call linkfaultend;

		else if type = seg_fault_start then do;
		     seg (seg_no).segf = seg (seg_no).segf + 1;
		end;

		else if type = page_fault_type | type = extended_page_fault_type then do;
		     if seg (seg_no).page (page_no) = 0 then seg (seg_no).total_no_page = seg (seg_no).total_no_page + 1;
		     seg (seg_no).page (page_no) = seg (seg_no).page (page_no) + 1;
		     seg (seg_no).any = "1"b;
		     seg (seg_no).total_no_pagef = seg (seg_no).total_no_pagef + 1;
		     maxhigh = max (maxhigh, seg_no);
		     total_pfaults = total_pfaults + 1;
		end;
		if tracesw then
		     call page_trace$print_trace_entry (addr (trace_copy.data (i)), iocbp, longsw);
SKIP:	     end;

	     if ^beg_found then do;
		beg_found, noise = "1"b;
		if tracesw
		then call ioa_$ioa_switch (iocbp, "^/Some page faults have been missed - no beginning marker^/");
		goto AGAIN;
	     end;

	     if ^end_found then do;
		if tracesw then call ioa_$ioa_switch (iocbp, "^/Some page faults have been missed - no end marker^/");
		noise = "1"b;
	     end;

DONE:
	     if noise then call ioa_ ("cumulative_page_trace: Some page faults have been missed.");

	end get_trace;

timer:	procedure;

	     if ignoreint then return;
	     call hcs_$trace_marker (cpte);
	     call hcs_$get_page_trace (addr (trace_copy));
	     call get_trace;
	     look_for_restart = ^timersw;		/* OK to turn on now */

	     totalint = totalint + 1;
	     call timer_manager_$cpu_call (inttime, "10"b, timer);

	     cptb = nexts ();
	     cpte = nexts ();
	     if flushsw then call flush;
	     call hcs_$trace_marker (cptb);

	end timer;


/* procedure used to reset the accumulated page trace data */
reset:	procedure;

	     call hcs_$truncate_seg (datap, 0, code);

	     totalloop = 0;
	     maxhigh = 0;
	     total_pfaults = 0;
	     if linkp ^= null then call hcs_$truncate_seg (linkp, 0, code);

	end reset;

nexts:	proc returns (char (4));

dcl  zzz9 pic "zzz9";

	     zzz9 = counter;
	     counter = counter + 1;
	     return (zzz9);

	end nexts;

linkfaultstart: proc;

	     if toptr (nextlp) = null () then nextlp = nextlp + 1; /* didn't get an end linkage fault */
	     fromptr (nextlp) = addr (trace_copy.data (i)) -> packedptr;
	     toptr (nextlp) = null ();

	end linkfaultstart;


linkfaultend: proc;

	     toptr (nextlp) = addr (trace_copy.data (i)) -> packedptr;
	     nextlp = nextlp + 1;

	end linkfaultend;

/* procedure used to print the accumulated page trace data */
print:	procedure;


	     if ^totalsw then call ioa_ ("^/Segment name^-^-   page numbers^/");
	     else call ioa_ ("^/Segment name ^-^- Page Faults     Segment Faults^/^-^-^- #pages  #faults  #faults^/");

	     do i = 0 to maxhigh;

		if seg (i).any then do;
		     call getname (fixed (i, 11));

		     lstr = 0;
		     char32 = ename;
		     total_pages = total_pages + seg (i).total_no_page;
		     total_segf = total_segf + seg (i).segf;

		     if totalsw then call ioa_ ("^32a^4d^9d^9d",
			ename, seg (i).total_no_page, seg (i).total_no_pagef, seg (i).segf);
		     else do;
			do j = 0 to highpage;	/* build string of page numbers */
			     if seg (i).page (j) ^= 0 then do;
				if seg (i).page (j) = 1 | ^countsw then call ioa_$rsnnl ("^o ", pnum, pnumbl, j);
				else call ioa_$rsnnl ("^o(^d) ", pnum, pnumbl, j, seg (i).page (j));
				substr (pstring, lstr+1, pnumbl) = pnumb;
				lstr = lstr + pnumbl; /* string length */
				if lstr >maxlstr then do;
				     call ioa_ ("^32a^a", char32, pstringf);
				     char32 = "";
				     lstr = 0;
				end;
			     end;
			end;
			if lstr ^= 0 then call ioa_ ("^32a^a", char32, pstringf);
		     end;
		end;
	     end;

	     call ioa_ ("^/Total number of pages: ^d, Total page faults: ^d, Total segment faults: ^d^/",
		total_pages, total_pfaults, total_segf);

	end print;

printlinks: proc;

	     call ioa_ ("^2/^2- Linkage Faults^/");

	     do i = 0 to nextlp -1;

		unpackedptr = fromptr (i);
		if baseno (unpackedptr) = "0"b
		then do;
		     caller_ename = "hcs_$make_ptr call";
		     nocaller = "1"b;
		end;
		else do;
		     nocaller = "0"b;
		     offset = binary (rel (unpackedptr), 18);
		     entry_name = "";
		     on not_in_read_bracket goto ISGATE;
		     call interpret_bind_map_ (unpackedptr, entry_name, offset, code);
		     revert not_in_read_bracket;
ISGATE:
		     if entry_name ^= "" then entry_name = ": " || entry_name;
		     call getname (fixed (baseno (unpackedptr), 11));
		     caller_ename = ename;
		end;

		unpackedptr = toptr (i);
		call get_entry_name_ (unpackedptr, callee_name, binary (baseno (unpackedptr)), comp_name, code);
		if callee_name = "" then callee_name = "0";
		call getname (fixed (baseno (unpackedptr), 11));

		call ioa_ ("^a^[^s^s^;^a|^o^]    ===>    ^a$^a",
		     caller_ename, nocaller, entry_name, offset, ename, callee_name);
	     end;
	     call ioa_ ("");

	end printlinks;

getname:	procedure (segnum);

dcl  segnum fixed bin (11);

	     ename = "";

	     if segnum < hcsc then call ring0_get_$name (dirname, ename, baseptr (segnum), code);
	     else call hcs_$fs_get_path_name (baseptr (segnum), dirname, k, ename, code);
	     if ename = "" then ename = ">";

	     if code ^= 0 then ename = ltrim (cv_bin_$oct (segnum)); /* convert segment number */

	end getname;

/*  procedure called for each iteration if -flush specified.
    The idea is to improve the accuracy of the data by eliminating the effect
    of background system load.  This is done by flushing main memory of all
    pages which we (or, for that matter, anyone else) might have touched.
    The only way to do this is to fill memory with other pages.  These
    pages belong to segments in the process directory, or in a user-specified
    directory, and we create these segments during the
    first pass through this procedure.  Note that this extraneous paging
    is detrimental to system performance, and that this detriment is
    evident to all users on the system.  If the flush pages are in
    the process directory, strange things can happen due to record quota
    overflow.  The stack might not be able to expand to handle the record
    quota overflow condition, resulting in a fatal process error.
    If the pages are left around between calls to cpt, someone else might
    get a record quota overflow (probably on the stack).  To avoid these
    problems, we do the following:
          1. Touch the next page of the stack, in case we need to expand
             it for any reason and no quota is left.
          2. Truncate all flush segments after flushing (thus returning
             their quota)
    Note that these problems are not serious if the user has specified
    -temp_dir.										*/
	

flush:	procedure;

	     if qoverflow | make_seg_failed then return;	/* lost before				*/
	     save_ignoreint = ignoreint;
	     ignoreint = "1"b;			/* could lose interrupts */
	     last_blockno = 0;
	     call ring0_get_$definition (nused_ptr, "sst", "nused", nused_offset, deftype, code);
	     if code = 0
	     then do;
		call ring_zero_peek_ (ptr (nused_ptr, nused_offset), addr (nused), 1, code);
		if code ^= 0 then nused = 1024;
	     end;
	     else nused = 1024;

	     garbage = stackframeptr () -> flush_seg.page (1).word (0); /* get page for stack expand	*/

	     do flushp_index = 0 to divide (nused+highpage, highpage, 17, 0) -1;
		if flushptr (flushp_index) = null then do;
		     zzzzz9 = flushp_index;
		     if tempdsw
			then call hcs_$make_seg (temp_dir_name, "cpt.flush."||ltrim (zzzzz9), "", 01010b, flushptr (flushp_index), code);
		     else call hcs_$make_seg ("", "cpt.flush."||ltrim (zzzzz9), "", 01010b, flushptr (flushp_index), code);
		     if flushptr (flushp_index) = null then do;
			call com_err_ (code, myname, "cpt.flush");
			make_seg_failed = "1"b;
			return;
		     end;

		end;

		on record_quota_overflow begin;
		     qoverflow = "1"b;
		     goto NOQUOTA;
		end;
		do flushi = 0 to highpage;
		     garbage = flushptr (flushp_index) -> flush_seg.page (flushi).word (0);
		end;
		revert record_quota_overflow;
	     end;
NOQUOTA:
	     do flushp_index = 0 to divide (nused+highpage, highpage, 17, 0) -1;
		if flushptr (flushp_index) ^= null()
		     then call hcs_$truncate_seg (flushptr (flushp_index), 0, code);
	     end;

	     ignoreint = save_ignoreint;

	end flush;

     end cumulative_page_trace;




		    page_trace.pl1                  06/04/84  1613.8rew 06/04/84  1241.7      121455



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
%;
/* ******************************************************
   *                                                    *
   *                                                    *
   * Copyright (c) 1972 by Massachusetts Institute of   *
   * Technology and Honeywell Information Systems, Inc. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* originally coded by Steve Webber  May 1971.
   Modified by Steve Webber March 1974.
   Modified by John Gintell June 1974 for MCR  598
   Modified by John Gintell May 1975 for MCR's 957 and 970,
   Modified by John Gintell Oct 1975 for MCR 1342.
   Modified 760506 by PG for MCRs 1832 (fix bug in link fault printing) and 1833 (add ctl args).
   Modified Feb 1979 by John Gintell for  MCR 3663 (fix bug in print_trace_entry).
   Modified June 1981 by J. Bongiovanni to fix bug in -from processing
   Modified January 1982 by J. Bongiovanni for extended page fault type
*/

page_trace: pgt: proc;

/* automatic */

dcl (header, longsw, print_pagefaults, marker_seen, stop_at_marker, count_given) bit (1) aligned,
    (dp, eptr, tp) ptr,
     ring_no fixed bin (3),
    (from, to) char (4) aligned,
     string char (20),
    offset fixed bin(18),
    (next, total, count, i, tc, long, fmtx, start_index) fixed bin,
     code fixed bin (35),
     data_area (1024) fixed bin,
    (time, type, seg_no, page_no, hcscnt) fixed bin,
     dirname char (168),
     ename char (32),
     proc_name char (32),
     proc_offset fixed bin (18),
     proc_segno fixed bin,
     comp_name char (8),
     entry_name char (32),
     switch_ptr ptr,				/* pointer to I/O switch */
     ftime float bin;

/* based */

dcl  based_char_4 char (4) aligned based,
     packedptr ptr based unal,
     targ char (tc) based (tp);


/* internal static */

dcl  output_format (0:11) char (50) varying aligned internal static options (constant) initial (
     "^20x^s^8.2f^3o^6o^5o^2x^s^a",			/* 0 - short page fault */
     "^20x^s^8.2f^3o^6o^5o^2x^a>^a",			/* 1 - long page fault */
     "^20a^8.2f^3x^s^6o^5x^s^2x^s^a",			/* 2 - short (seg/bound) fault */
     "^20a^8.2f^3x^s^6o^5x^s^2x^a>^a",			/* 3 - long (seg/bound) fault */
     "^20a^8.2f^3x^s^6o^5x^s^2x^s^a$^a",		/* 4 - short end linkage fault */
     "^20a^8.2f^3x^s^6o^5x^s^2x^a>^a$^a",		/* 5 - long end linkage fault */
     "^20a^8.2f^3x^s^6x^s^5x^s^2x^s^a",			/* 6 - signal generated/user marker/etc */
     "^20a^8.2f",					/* 7 - make ptr/signal restarted/reschedule */
     "^20a^8.2f^3x^s^6o^5x^s^2x^s^a^a|^o",		/* 8 - short start linkage fault */
     "^20a^8.2f^3x^s^6o^5x^s^2x^a>^a^a|^o",		/* 9 - long  start linkage fault */
     "^20x^s^8.2f^3x^s^6o^5o^2x^s^a",			/* 10 - short page fault (extended) */
     "^20x^s^8.2f^3x^s^6o^5o^2x^a>^a^2s^/^46xby ^a|^o");	/* 11 - long page fault(extended)  */

/* external static */

dcl (active_all_rings_data_$hcscnt fixed bin,
     iox_$user_output ptr) external static;
dcl  error_table_$badopt fixed bin (35) external static;
dcl  error_table_$inconsistent fixed bin (35) external static;

/* entries */

dcl  hcs_$get_page_trace entry (ptr),
     hcs_$fs_get_path_name entry (ptr, char(*), fixed bin, char(*), fixed bin(35)),
     ioa_$ioa_switch entry options (variable),
     iox_$look_iocb entry (char (*), ptr, fixed bin (35)),
     get_entry_name_ entry (ptr, char (*), fixed bin, char (8), fixed bin (35)),
     com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     cu_$arg_count entry returns (fixed bin),
     interpret_bind_map_ entry (ptr, char(*), fixed bin(18), fixed bin(35)),
     ring0_get_$name entry (char(*), char(*), ptr, fixed bin (35));

/* builtins */

dcl (addr, baseno, baseptr, rel, binary, convert, substr, unspec) builtin;

/* conditions */

dcl (conversion, not_in_read_bracket) condition;

/* include files */

%include sys_trace;
%include trace_types;

/*  */

	dp = addr (data_area);			/* get a pointer to buffer */
	call hcs_$get_page_trace (dp);		/* copy the trace information from ring 0 */

	longsw = ""b;				/* default is short mode */
	count_given = ""b;
	print_pagefaults = "1"b;			/* default is to print page faults */
	stop_at_marker = ""b;			/* default is to print until end */
	from = "";				/* default is no from argument */
	to = "";					/* default is no to argument */
	marker_seen = "0"b;				/* haven't seen from marker yet. */

	hcscnt = active_all_rings_data_$hcscnt;
	switch_ptr = iox_$user_output;

	next =  dp -> trace.next_free;		/* get index to last used cell */
	count, total = dp -> trace.last_available;	/* get size of trace array */

	do i = 1 to cu_$arg_count ();
	     call cu_$arg_ptr (i, tp, tc, code);	/* pick up the argument (if it's given) */
	     if targ = "-long" | targ = "-lg" then longsw = "1"b;
	     else if targ = "-no_header" | targ = "-nhe" then header = "0"b;
	     else if targ = "-output_switch" | targ = "-os" then do;
		i = i + 1;
		call cu_$arg_ptr (i, tp, tc, code);
		if code ^= 0 then do;
		     call com_err_ (code, "page_trace", "-output_switch must be followed by a switch name.");
		     return;
		end;
		call iox_$look_iocb (targ, switch_ptr, code);
		if code ^= 0 then do;
		     call com_err_ (code, "page_trace", "Switch ^a not found.", targ);
		     return;
		end;
	     end;
	     else if targ = "-from" | targ = "-fm" then do;
		i = i + 1;
		call cu_$arg_ptr (i, tp, tc, code);
		if code ^= 0 then do;
		     call com_err_ (code, "page_trace", "-from must be followed by a character string.");
		     return;
		end;
		from = targ;
	     end;
	     else if targ = "-to" then do;
		i = i + 1;
		call cu_$arg_ptr (i, tp, tc, code);
		if code ^= 0 then do;
		     call com_err_ (code, "page_trace", "-to must be followed by a character string.");
		     return;
		end;
		stop_at_marker = "1"b;
		to = targ;
	     end;
	     else if targ = "-npf" | targ = "-no_pagefaults" then print_pagefaults = ""b;
	     else if substr (targ, 1, 1) = "-" then do;	/* mispelled ctl arg */
		call com_err_ (error_table_$badopt, "page_trace", "^a", targ);
		return;
	     end;
	     else do;
		count_given = "1"b;
		on conversion go to bad_count;	/* trap bad numbers */
		count = convert (count, targ);	/* convert args to binary */
		revert conversion;			/* make handler go away */
		if count <= 0 | count > total then do;
bad_count:
		     call com_err_ (0, "page_trace", "Invalid count value given, ^a", targ);
		     return;
		end;
	     end;
	end;

	if count_given & (from ^= "" | to ^= "") then do;
	     call com_err_ (error_table_$inconsistent, "page_trace",
		"count and ^[-from ^]^[-to ^]", (from ^= ""), (to ^= ""));
	     return;
	end;

	if header
	then call ioa_$ioa_switch (switch_ptr, "^/^-^-Elapsed^/     Trace Type    Time (ms) Ring Segno Page^-Segment^/");

	if count > next
	then start_index = total + next - count + 1;
	else start_index = next - count + 1;

	if from ^= ""				/* -from specified? */
	then if count > next
	     then do i = start_index to total, 1 to next;
		trace_ptr = addr (dp -> trace.data (i));
		if trace_ptr -> page_trace_entry.type = marker_type
		then if trace_ptr -> based_char_4 = from
		     then do;
			start_index = i;
			go to scan;
		     end;
		count = count - 1;
	     end;
	     else do i = start_index to next;
		trace_ptr = addr (dp -> trace.data (i));
		if trace_ptr -> page_trace_entry.type = marker_type
		then if trace_ptr -> based_char_4 = from
		     then do;
			start_index = i;
			go to scan;
		     end;
		count = count - 1;
	     end;

scan:
	if count > next
	then do i = start_index to total, 1 to next;	/* wrap-around ? */
	     trace_ptr = addr (dp -> trace.data (i));	/* get pointer to entry */
	     call output;
	     if stop_at_marker
	     then if trace_ptr -> page_trace_entry.type = marker_type
		then if trace_ptr -> based_char_4 = to
		     then go to done;
	end;
	else do i = start_index to next;		/* no wrap-around, just scan the last 'count' */
	     trace_ptr = addr (dp -> trace.data (i));	/* get pointer to entry */
	     call output;
	     if stop_at_marker
	     then if trace_ptr -> page_trace_entry.type = marker_type
		then if trace_ptr -> based_char_4 = to
		     then go to done;
	end;

done:
	call ioa_$ioa_switch (switch_ptr, "");
	return;

output:	proc;

	     if unspec (trace_ptr -> page_trace_entry) = "0"b
		then return;

	     type = trace_ptr -> page_trace_entry.type;
	     time = trace_ptr -> page_trace_entry.time;
	     if time = 65535 then ftime = 0e0;
	     else ftime = time*64/1e3;		/* convert the time to milli-seconds */

	     if type = page_fault_type | type = seg_fault_start
		| type = seg_fault_end
		| type = boundfault_start | type = boundfault_end
		then seg_no = trace_ptr -> page_trace_entry.segment_number;

	     else if type = extended_page_fault_type
		then seg_no = binary (trace_ptr -> extended_page_trace_entry.tsr_segno_1 
		|| trace_ptr -> extended_page_trace_entry.tsr_segno_2, 12);

	     else if type = linkage_fault_end
	     then do;
		eptr = trace_ptr -> packedptr;
		call get_entry_name_ (eptr, entry_name, seg_no, comp_name, code);
		if entry_name = "" then entry_name = "0";
	     end;

	     else if type = linkage_fault_start then do;
		eptr = trace_ptr->packedptr;
		offset = binary(rel(eptr),18);
		entry_name = "";
		on not_in_read_bracket goto ISGATE;
		call interpret_bind_map_(eptr,entry_name,offset,code );
		revert not_in_read_bracket;
ISGATE:
		if entry_name ^= "" then entry_name = ": " || entry_name;
		seg_no = binary(baseno(eptr),18);
	     end;

	     else seg_no = -1;

	     if seg_no ^= -1 then call get_segment_name (seg_no, dirname, ename);
	     else dirname, ename = "";
	     


	     page_no = 0;
	     ring_no = 0;
	     proc_name = "";
	     proc_segno = 0;
	     proc_offset = 0;
	     long = binary (longsw, 1);

	     if type = page_fault_type then do;
		if ^print_pagefaults then return;
		page_no = trace_ptr -> page_trace_entry.page_number;
		ring_no = trace_ptr -> page_trace_entry.ring;
		fmtx = 0 + long;
	     end;
	     else if type = extended_page_fault_type then do;
		page_no = trace_ptr -> extended_page_trace_entry.tsr_pageno;
		proc_segno = trace_ptr -> extended_page_trace_entry.psr_segno;
		proc_offset = trace_ptr -> extended_page_trace_entry.psr_offset;
		call get_segment_name (proc_segno, (""), proc_name);
		fmtx = 10 + long;
	     end;
	     else if type = seg_fault_start then do;
		string = "SEG-FAULT-START";
		fmtx = 2 + long;
	     end;
	     else if type = seg_fault_end then do;
		string = "SEG-FAULT-END";
		fmtx = 2 + long;
	     end;
	     else if type = boundfault_start then do;
		string = "BOUND-FAULT-START";
		fmtx = 2 + long;
	     end;
	     else if type = boundfault_end then do;
		string = "BOUND-FAULT-END";
		fmtx = 2 + long;
	     end;
	     else if type = linkage_fault_start then do;
		if seg_no = 0 then do;
		     string = "MAKE-PTR-CALL";
		     fmtx = 7;
		end;
		else do;
		     string = "LINKAGE FAULT BY";
		     fmtx = 8 + long;
		end;
	     end;
	     else if type = linkage_fault_end then do;
		string = "RESOLVED LINK TO";
		fmtx = 4 + long;
	     end;
	     else if type = signaller_type then do;
		string = "SIGNAL GENERATED";
		fmtx = 6;
		ename = trace_ptr -> based_char_4;
	     end;
	     else if type = restart_fault_type then do;
		string = "SIGNAL RESTARTED";
		fmtx = 7;
	     end;
	     else if type = reschedule_type then do;
		string = "RESCHEDULING";
		fmtx = 7;
	     end;
	     else if type = marker_type then do;
		string = "USER MARKER";
		fmtx = 6;
		ename = trace_ptr -> based_char_4;
	     end;
	     else do;
		string = "UNRECOGNIZABLE ENTRY";
		fmtx = 6;
		ename = trace_ptr -> based_char_4;
	     end;

	     call ioa_$ioa_switch (switch_ptr, output_format (fmtx),
		string, ftime, ring_no, seg_no, page_no, dirname, ename,
		entry_name, offset, proc_name, proc_offset);

	     return;
	end;
%page;
print_trace_entry: entry (a_trace_ptr, a_switch_ptr, a_longsw);

/*	internal interface provided for cumulative_page_trace.
   *	It interprets and prints one entry from the system trace array.
*/

dcl  a_trace_ptr ptr;				/* pointer to entry in system trace array */
dcl  a_switch_ptr ptr;				/* switch_ptr onto which output is placed */
dcl  a_longsw bit (1) aligned;			/* set to "1"b if -long was given */

	hcscnt = active_all_rings_data_$hcscnt;
	switch_ptr = a_switch_ptr;
	trace_ptr = a_trace_ptr;
	longsw = a_longsw;
	print_pagefaults = "1"b;

	call output;

	return;

%page;
get_segment_name:
proc (segment_number, dname, ename);

dcl segment_number fixed bin;
dcl dname char (*);
dcl ename char (*);

dcl temp fixed bin;

	     if segment_number >= active_all_rings_data_$hcscnt then do; /* if user initiated segment ... */
		call hcs_$fs_get_path_name (baseptr (segment_number), dname, temp, ename, code);
		if code ^= 0 then do;
		     dname = "";
		     ename = "*** unknown segment ***";
		end;
		else if ^longsw then if ename = "" then ename = ">"; /* root */
	     end;
	     else do;
		call ring0_get_$name (dname, ename, baseptr (segment_number), code);
		dname = "";
	     end;

end get_segment_name;

end page_trace;




		    ring_zero_peek_.pl1             11/04/82  1920.0rew 11/04/82  1615.5      126774



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


ring_zero_peek_: procedure (P_from_ptr, P_to_ptr, P_word_count, P_code);

/* *	This routine attempts to get some specific data item from hardcore
   *	by calling phcs_$ring_0_peek or metering_ring_zero_peek_ as appropriate.
   *	There are three cases worth considering:
   *	   1) The user hasn't got access to either gate.
   *	   2) The user has access to metering_ring_zero_peek_ only.
   *	   3) The user has access to both gates.
   *	For a class 3 user, we should always call phcs_, since it is more efficient.
   *
   *	The convoluted flow of control which tries to insure that phcs_ is always
   *	called, if possible, and that as few linkage faults as possible are taken
   *	does actually work, I believe, though considerable study is required to
   *	convince yourself of it.
   *
   *	ring_zero_peek_$by_name, ring_zero_peek_$by_definition:
   *
   *	There are additional entrypoints for peeking by segment name and definition.
   *	These are present so programs which need to copy from named ring zero segments
   *	or particular ring zero definitions can avoid the inconvenience of calling
   *	ring0_get_ every time, maintaining static pointers, initializing them, etc.
   *
   *	Since it would be expensive to always call ring0_get_, ring_zero_peek_
   *	maintains a hashed list of the segment names and definitions it has been called
   *	to look up, and uses the pointers stored therein rather than using ring0_get_
   *	every time.
   *
   *	This efficiency mechanism should make the additional cost of using ring_zero_peek_
   *	to copy by name or definition quite negligible, and the interface provided is far
   *	more convenient than the usual techniques. In those occasional programs where
   *	efficiency and absolute minimum of page faults are very important, the static
   *	pointer technique will be more efficient.
   *
   *	The hashed lookup table should always work, since it is effectively serving only
   *	as a cache on a static database, that of ring zero segments and definitions.
   *	Since this database is read off the system tape, and is never changed throughout
   *	the duration of a bootload, the cache is guaranteed to always be valid, and needs
   *	no flushing or clearing protocols.
   *
   *	First written on January 14, 1974 by R F Mabee.
   *	Last modified on 01/17/74 at 15:05:27 by R F Mabee.
   *	Last modified on 05/26/79 W. Olin Sibert, to call phcs_ if possible
   *	Last modified on 12/24/79 W. Olin Sibert, to add $by_name and $by_definition entries.
   *	Last modified on 12/25/79 W. Olin Sibert, to add max length entrypoints.
   *	Last modified on 02/22/81 W. Olin Sibert, to clean up for installation.
   */

dcl (P_from_ptr pointer,
     P_to_ptr pointer,
     P_word_count fixed bin (19),
     P_seg_name char (*),
     P_seg_ptr pointer,
     P_entrypoint_name char (*),
     P_offset fixed bin (18),
     P_max_length fixed bin (19),
     P_code fixed bin (35)) parameter;

dcl (tried_phcs, tried_mrzp) bit (1) aligned;
dcl  system_area_ptr pointer;
dcl  system_area area based (system_area_ptr);
dcl  def_name char (72) varying;
dcl  temp_def_name char (72);
dcl  def_offset fixed bin (18);
dcl  r0_ptr pointer;
dcl  def_ptr pointer;
dcl  copy_ptr pointer;
dcl  last_name_entry_ptr pointer;
dcl  hash_index fixed bin;
dcl  temp_word bit (36) aligned;
dcl  ring_zero_only bit (1) aligned;
dcl 1 temp_sdw aligned like sdw automatic;

dcl  phcs_ok bit (1) aligned internal static init ("1"b);
dcl  hash_buckets (127) pointer unaligned internal static init ((127)(null ()));

dcl  name_entry_ptr pointer;
dcl  name_entry_lth fixed bin;
dcl 1 name_entry aligned based (name_entry_ptr),
    2 next pointer unaligned,
    2 r0_ptr pointer unaligned,
    2 name_lth fixed bin,
    2 name char (name_entry_lth refer (name_entry.name_lth));

dcl  get_system_free_area_ entry () returns (pointer);
dcl  metering_ring_zero_peek_ entry (pointer, pointer, fixed binary (19), fixed bin (35));
dcl  phcs_$ring_0_peek entry (pointer, pointer, fixed binary (19));
dcl  ring0_get_$definition entry (pointer, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35));
dcl  ring0_get_$segptr entry (char (*), char (*), pointer, fixed bin (35));
dcl  ring_zero_peek_ entry (pointer, pointer, fixed bin (19), fixed bin (35));
dcl  ring_zero_peek_$by_name entry (char (*), fixed bin (18), pointer, fixed bin (19), fixed bin (35));

dcl (error_table_$no_info,
     error_table_$invalidsegno,
     error_table_$bad_arg) fixed bin (35) external static;

dcl (seg_fault_error, linkage_error) condition;

dcl (addr, addrel, baseno, binary, dimension, length, mod, null, rank, rtrim, search, size, substr) builtin;

/*  */

/* *	ring_zero_peek_: procedure (P_from_ptr, P_to_ptr, P_word_count, P_code);
   *
   *	This entry is used to merely extract words from ring zero, specified
   *	by a pointer into ring zero. */

	copy_ptr = P_from_ptr;			/* generate the pointer to copy from */

	goto PERFORM_RING_ZERO_PEEK;			/* and join common peeking code */

/*  */

ring_zero_peek_$by_name: entry (P_seg_name, P_offset, P_to_ptr, P_word_count, P_code);

/* *	This entry is used to copy words from the named ring zero segment,
   *	starting at P_offset. */

	if search (P_seg_name, "<>") ^= 0 then do;	/* it's a pathname, reject it */
	     P_code = error_table_$bad_arg;		/* best code I could find */
	     return;
	     end;

	call lookup (P_seg_name);			/* sets name_entry_ptr, last_name_entry_ptr, hash_index */

	if name_entry_ptr = null () then do;		/* not there already, we must find it */
	     call ring0_get_$segptr ("", P_seg_name, r0_ptr, P_code); /* call to find it */
	     if P_code ^= 0 then return;		/* Nope. */

	     call insert (P_seg_name, r0_ptr);		/* insert it */
	     end;

	else r0_ptr = name_entry.r0_ptr;		/* otherwise, copy it from the found name_entry */

	copy_ptr = addrel (r0_ptr, P_offset);		/* generate the pointer to copy from */

	goto PERFORM_RING_ZERO_PEEK;			/* and join common peeking code */

/*  */

ring_zero_peek_$by_definition: entry (P_seg_name, P_entrypoint_name, P_offset, P_to_ptr, P_word_count, P_code);

/* *	This entry is used to copy words from the definition P_seg_name$P_entrypoint_name,
   *	in ring zero, possibly offset by P_offset. */

	if search (P_seg_name, "<>") ^= 0 then do;	/* it's a pathname, reject it */
	     P_code = error_table_$bad_arg;		/* best code I could find */
	     return;
	     end;

	def_name = rtrim (P_seg_name);		/* construct lookup name */
	def_name = def_name || "$";
	def_name = def_name || rtrim (P_entrypoint_name);
	temp_def_name = def_name;

	call lookup (temp_def_name);			/* sets name_entry_ptr, last_name_entry_ptr, hash_index */

	if name_entry_ptr = null () then do;		/* not there already, we must find it */
	     r0_ptr = null ();			/* indicate that this should be an output argument */
	     call ring0_get_$definition (r0_ptr, P_seg_name, P_entrypoint_name, def_offset, (0), P_code);
	     if P_code ^= 0 then return;		/* Nope. */

	     def_ptr = addrel (r0_ptr, def_offset);	/* generate a pointer to the actual definition */
	     call insert (temp_def_name, def_ptr); 	/* insert it */
	     end;

	else def_ptr = name_entry.r0_ptr;		/* otherwise, copy it from the found name_entry */

	copy_ptr = addrel (def_ptr, P_offset);		/* add optionl offset, and generate pointer */

	goto PERFORM_RING_ZERO_PEEK;			/* join common peeking code */

/*  */

/* *	This block of code is responsible for actually performing the peek.
   *	It implements the complex heuristics described above for moderating access.
   *	It tries to copy P_word_count words from the location in ring zero identified
   *	by copy_ptr out to the location identified by P_to_ptr, setting P_code to
   *	indicate success or failure. It is accessed via a goto rather than being an
   *	internal procedure for reasons of efficiency; it would have to be a nonquick
   *	procedure, since it sets up condition handlers, and it seemed worth saving
   *	the additional overhead at the expense of making the program logic somewhat
   *	more complicated. */

PERFORM_RING_ZERO_PEEK:
	tried_phcs = "0"b;				/* indicates that we have already tried and failed */
	tried_mrzp = "0"b;				/* indicates that m_r_z_p_ lost as well */

	if ^phcs_ok then goto NO_PHCS;		/* don't bother with linkage fault if we know already */


TRY_PHCS: tried_phcs = "1"b;				/* don't come back */

	on linkage_error goto NO_PHCS;

	call phcs_$ring_0_peek (copy_ptr, P_to_ptr, P_word_count);

	phcs_ok = "1"b;				/* indicate this will work in the future */
	P_code = 0;				/* assume success */
	return;


NO_PHCS:	if tried_mrzp then goto NO_MRZP;		/* only try this once */

	tried_mrzp = "1"b;				/* don't come back here */
	phcs_ok = "0"b;				/* can only get here if we lost trying phcs_ */

	on linkage_error goto NO_MRZP;

	call metering_ring_zero_peek_ (copy_ptr, P_to_ptr, P_word_count, P_code);
	if P_code = 0 then return;			/* it worked */
						/* otherwise, fall through and maybe try phcs_ */


NO_MRZP:	if ^tried_phcs then goto TRY_PHCS;		/* we lost for m_r_z_p_, try phcs_ once */

	P_code = error_table_$no_info;		/* Sorry, out of luck */
	return;					/* end of code for peeking */

/*  */

ring_zero_peek_$get_max_length: entry (P_seg_name, P_max_length, P_code);

/* *	These entries return the max length of a selected ring zero segment,
   *	by the simple expedient of peeking at the SDW for the segment. */

	ring_zero_only = "1"b;
	goto PERFORM_GET_MAX_LTH;			/* Only genuine ring 0 segs from hardcore address space */


ring_zero_peek_$get_max_length_ptr: entry (P_seg_ptr, P_max_length, P_code);

	ring_zero_only = "0"b;
	goto PERFORM_GET_MAX_LTH;			/* Max length from SDW for any segment */


PERFORM_GET_MAX_LTH:
	P_max_length = -1;				/* initialization */

	if ring_zero_only then do;			/* get a pointer to the named segment */
	     call ring0_get_$segptr ("", P_seg_name, r0_ptr, P_code);
	     if P_code ^= 0 then return;		/* sorry, you lose */
	     end;
	else r0_ptr = P_seg_ptr;			/* otherwise, copy the input pointer */

	call ring_zero_peek_$by_name ("dseg", (2 * binary (baseno (r0_ptr), 17)),
	     addr (temp_sdw), size (temp_sdw), P_code);	/* copy the SDW from the users dseg */
	if P_code ^= 0 then return;			/* sorry, outta luck */

	if temp_sdw.df = "0"b then do;		/* not active */
	     on condition (seg_fault_error)		/* protect against nasties */
		goto INVALID_SEGMENT_NUMBER;

	     call ring_zero_peek_ (r0_ptr, addr (temp_word), size (temp_word), P_code);
	     if P_code ^= 0 then			/* try to segfault on it, to get a valid SDW */
		return;				/* Couldn't. Tough luck, Chucko. */

	     revert condition (seg_fault_error);

	     call ring_zero_peek_$by_name ("dseg", (2 * binary (baseno (r0_ptr), 17)),
		addr (temp_sdw), size (temp_sdw), P_code); /* try again to get the SDW */
	     if P_code ^= 0 then
		return;

	     if temp_sdw.df = "0"b then		/* Still not active -- just punt */
		goto INVALID_SEGMENT_NUMBER;
	     end; 				/* at this point, we apparently have a valid SDW */

	P_max_length = 16 + (16 * binary (temp_sdw.bound, 14));

	P_code = 0;
	return;


INVALID_SEGMENT_NUMBER:				/* Couldn't access something */
	P_code = error_table_$invalidsegno;
	return;					/* all done with ring_zero_peek_$get_max_length  */

/*  */

lookup: proc (P_name);

/* *	This procedure looks up P_name in the internal name hash table, and sets
   *	hash_index, name_entry_ptr, and last_name_entry_ptr appropriately. It will
   *	always set hash_index correctly. If P_name is found, name_entry_ptr points
   *	to the name_entry block for it, and last_name_entry_ptr will be invalid.
   *	If P_name is not found, name_entry_ptr will be null, and last_name_entry_ptr
   *	will either point to the last name_entry block in the chain, or be null if
   *	the chain is empty. */

dcl  P_name char (*) parameter;

dcl  hash_sum fixed bin;
dcl  idx fixed bin;

	hash_sum = 43;				/* This is just to start it somewhere other than zero */
						/* The choice of 43 is completely arbitrary */
	do idx = 1 to length (rtrim (P_name));
	     hash_sum = hash_sum + rank (substr (P_name, idx, 1));
	     end;

	hash_index = 1 + mod (hash_sum, dimension (hash_buckets, 1));

	last_name_entry_ptr = null ();
	do name_entry_ptr = hash_buckets (hash_index)
		repeat (name_entry_ptr -> name_entry.next)
		while (name_entry_ptr ^= null ());

	     last_name_entry_ptr = name_entry_ptr;

	     if name_entry.name = P_name then return;	/* jackpot */
	     end; 				/* of loop through name_entry blocks */

	return;					/* all done. the pointers are set appropriately by the loop */
	end lookup;

/*  */

insert: proc (P_name, P_ptr);

/* *	This procedure adds another name_entry block to the appropriate chain for
   *	the association of P_name and P_ptr. It assumes that hash_index and
   *	last_name_entry_ptr have already been set properly (presumably by lookup). */

dcl (P_name char (*),
     P_ptr pointer) parameter;

	system_area_ptr = get_system_free_area_ ();	/* allocate a new name_entry */
	name_entry_lth = length (rtrim (P_name));

	allocate name_entry in (system_area) set (name_entry_ptr);

	name_entry.next = null ();			/* initialize values */
	name_entry.r0_ptr = P_ptr;
	name_entry.name_lth = name_entry_lth;
	name_entry.name = P_name;

	if last_name_entry_ptr ^= null () then		/* and string in -- after last one, if there was such; */
	     last_name_entry_ptr -> name_entry.next = name_entry_ptr;
	else hash_buckets (hash_index) = name_entry_ptr;

	return;					/* all done */
	end insert;

%page;	%include sdw;

	end ring_zero_peek_;			/* External procedure */





		    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
