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