copy_erf_seg_.pl1 11/21/84 1206.5rew 11/21/84 1034.8 51165 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Extract segments from a Multics dump */ /* Created: by C. Hornig */ /* Modified: 24 February 1981 by J. A. Bush for larger fdump header size */ /* Modified: 29 December 1981 by G. Palter to not fault when asked about the same dump multiple times and to not reference a non-existant error code */ /* Modified: October 1984 by Greg Texada to use amu_ and change Erf to character. */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ copy_erf_seg_: procedure (Erf, Segno, Out_ptr, Out_len, Code); dcl Erf char (*) parameter; /* ERF number */ dcl Segno fixed binary (15) unsigned parameter; /* segment to copy out */ dcl Segname character (*) parameter; /* name of segment to copy out */ dcl Out_ptr pointer parameter; /* where to copy */ dcl Out_len fixed binary (19) unsigned parameter; /* how long it was */ dcl Code fixed binary (35) parameter; dcl cleanup condition; dcl (addr, baseno, baseptr, binary, null, pointer) builtin; dcl amu_$fdump_mgr_init_fdump entry(char(*), ptr, ptr, fixed bin(35)), amu_$find_system_fdump entry (char(*), ptr, fixed bin(35)), amu_$terminate_translation entry (ptr), amu_$do_translation entry (ptr, fixed bin, ptr, fixed bin(18), fixed bin(18), fixed bin(35)), amu_$hardcore_info_set_cur_ptrs entry (ptr, ptr); dcl sys_info$max_seg_size fixed bin (35) ext static; dcl hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35)); dcl hcs_$truncate_seg entry (ptr, uns fixed bin (19), fixed bin (35)); dcl ring0_get_$segptr_given_slt entry (char (*), char (*), ptr, fixed bin (35), ptr, ptr); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, uns fixed bin (19), fixed bin (35)); dcl segno uns fixed bin (15); dcl segname char (32); dcl optr ptr; dcl segp ptr; dcl sdw_hold bit (72) aligned; dcl seg_size uns fixed bin (19); dcl offset fixed bin (18); dcl range fixed bin (18); /* */ /* Extract a segment by segment number */ /* copy_erf_seg_: entry (Erf, Segno, Out_ptr, Out_len, Code); */ segno = Segno; segname = ""; /* flag that we ARE the number entry */ goto common_amu; /* Extract a segment by name */ name: entry (Erf, Segname, Out_ptr, Out_len, Code); segname = Segname; /* Flag that we are the name entry */ common_amu: Code = 0; optr = Out_ptr; if Erf = "-1" then do; /* wants data form the running system */ if Segname ^= "" then goto OLD_WAY_FOR_RUNNING_SYSTEM_NAME; else goto OLD_WAY_FOR_RUNNING_SYSTEM_NO; end; amu_info_ptr = null (); /* so below will make one for us */ on cleanup begin; if amu_info_ptr ^= null () then call amu_$terminate_translation (amu_info_ptr); end; system_dump_info_ptr = addr (sdi); sdi.version = SYSTEM_DUMP_INFO_VERSION_1; sdi.dump_dir_name, sdi.dump_seg_prefix, sdi.dump_name, sdi.dump_entry_format = ""; call amu_$find_system_fdump (Erf, system_dump_info_ptr, Code); /* uses the dumps search list to find */ if Code ^= 0 then goto return_to_caller_amu; /* the erf */ call amu_$fdump_mgr_init_fdump ("copy_erf_seg_", system_dump_info_ptr, amu_info_ptr, Code); if Code ^= 0 then goto return_to_caller_amu; if segname ^= "" then do; /* name entry, get hardcore info */ call amu_$hardcore_info_set_cur_ptrs (amu_info_ptr, addr (local_hardcore)); call ring0_get_$segptr_given_slt ("", segname, segp, Code, local_hardcore.sltp, local_hardcore.sltntp); if Code ^= 0 then goto return_to_caller_amu; segno = binary (baseno (segp), 15); end; call hcs_$truncate_seg (optr, 0, (0)); /* ok, all the same from here on.. */ offset = 0; range = sys_info$max_seg_size; /* because amu_ wants to WRITE to it! */ call amu_$do_translation (amu_info_ptr, (segno), optr, offset, range, Code); if Code = 0 then call hcs_$set_bc_seg(optr, (range * 36), Code); return_to_caller_amu: if amu_info_ptr ^= null () then call amu_$terminate_translation (amu_info_ptr); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ OLD_WAY_FOR_RUNNING_SYSTEM_NO: segno = Segno; goto common; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ OLD_WAY_FOR_RUNNING_SYSTEM_NAME: segname = Segname; call ring0_get_$segptr ("", segname, segp, Code); if Code ^= 0 then return; segno = binary (baseno (segp), 15); common: call hcs_$truncate_seg (optr, 0, (0)); sdwp = addr (sdw_hold); call ring_zero_peek_ (pointer (baseptr (0), 2 * segno), sdwp, 2, Code); /* get SDW */ if Code ^= 0 then return; seg_size = 16 * (1 + binary (sdw.bound, 14)); segp = baseptr (segno); call ring_zero_peek_ (segp, optr, seg_size, Code); if Code ^= 0 then return; Out_len = seg_size; return_to_caller: return; /* */ %include sdw; %include system_dump_info; dcl 1 sdi like system_dump_info; %include amu_info; %include amu_hardcore_info; dcl 1 local_hardcore like hardcore_cur; end copy_erf_seg_;  get_gate_data_.pl1 11/20/86 1410.4r w 11/20/86 1145.0 81342 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* GET_GATE_DATA_ - Procedure to Get Metering Data from a Gate. revised 9/15/76 by Noel I. Morris Modified June 1981 by J. Bongiovanni to fix zero linkage size bug Modified July 1984 by Keith Loepere to work against the new, larger hcs_. */ get_gate_data_: proc (gate_name, table, nentries, tempp, reset_sw, code); dcl gate_name char (*), /* name of gate */ nentries fixed bin, /* number of gate entries */ tempp ptr, /* pointer to temp segment */ reset_sw bit (1) aligned, /* "1"b if reset operation to be performed at end */ code fixed bin (35); /* error code */ dcl 1 table (*) like gate_table aligned; /* gate information table */ dcl gp ptr, /* pointer to gate_info */ caller_ptr ptr, /* pointer to caller of this procedure */ gatep ptr, /* pointer to gate */ gateno fixed bin (18), /* segno of gate */ savep ptr, /* pointer to original copy of linkage */ slp ptr, /* pointer to static copy of linkage */ type fixed bin (2), /* segment type */ bc fixed bin (24), /* segment bit count */ pptr ptr unal, /* packed pointer from lot */ l0p ptr, /* pointer to linkage in ring 0 */ llth fixed bin (18), /* length of linkage */ linkp ptr, /* pointer to linkage */ tlth fixed bin (18), /* length of text */ textp ptr, /* pointer to copy of teext */ defp ptr, /* pointer to defs */ no_entries fixed bin, /* number of gate entries */ p ptr, /* working pointer for searching defs */ i fixed bin, /* gate table index */ namep ptr, /* pointer to entry name */ entryp ptr, /* pointer to gate entry point */ vrel bit (18), /* rel pointer to gate validation info */ vp ptr, /* pointer to validation info */ datarel bit (18); /* rel ptr to gate data */ dcl 1 linkhdr like header auto; /* automatic copy of linkage header */ dcl ap ptr static init (null ()), /* pointer to system free area */ fgp ptr static init (null ()), /* ptr to first gate_info */ lotp0 ptr static init (null ()); /* pointer to ring 0 lot */ dcl caller entry returns (ptr), ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)), hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)), ring_zero_peek_ entry (ptr, ptr, fixed bin (18), fixed bin (35)), get_system_free_area_ entry (ptr); dcl (addr, addrel, baseno, bin, divide, hbound, lbound, null, ptr, size, unspec) builtin; dcl 1 gate_info aligned based (gp), 2 name char (32), /* name of gate */ 2 user ptr unal, /* pointer to caller */ 2 textp ptr unal, /* ptr to segment in ring 0 */ 2 linkp ptr unal, /* ptr to linkage in ring 0 */ 2 defp ptr unal, /* pointer to defs */ 2 textl fixed bin (18), /* length of text in words */ 2 linkl fixed bin (18), /* length of linkage in words */ 2 stp ptr unal, /* pointer to static buffer used when doing resets */ 2 next ptr unal; dcl 1 acc_name based (namep) aligned, /* name in ACC format */ (2 size fixed bin (8), 2 name char (acc_name.size)) unaligned; dcl 1 gate_entry based aligned, /* entry pointer to gate */ 2 body_ptr bit (18); /* pointer to body of gate entry */ dcl 1 gate_body based aligned, /* body of gate entry */ 2 nargs bit (18) unal, /* number of arguments */ 2 info_ptr bit (18) unal; /* rel pointer to information in linkage */ dcl 1 save_data (no_entries) aligned based (savep) like gate_entry_data, 1 static_data (no_entries) aligned based (slp) like gate_entry_data, 1 current_data (no_entries) aligned based (tempp) like gate_entry_data; dcl based_area area based (ap); dcl 1 definitions_$ (0:511) ext aligned, /* hardcore definitions */ (2 offset bit (18), 2 length bit (18)) unal; % include gate_data; % include linkdcl; % include definition; code = 0; /* If this is the first call, get static pointers. */ if ap = null () then /* Get pointer to system free area. */ call get_system_free_area_ (ap); if lotp0 = null () then /* Get a pointer to ring 0 lot. */ call ring0_get_$segptr ("", "lot", lotp0, code); if code ^= 0 then return; /* See if we already have data. */ caller_ptr = caller (); /* Get pointer to this procedure's caller. */ gp = fgp; do while (gp ^= null ()); if (gate_info.name = gate_name) & (gate_info.user = caller_ptr) then go to found; gp = gate_info.next; end; /* Set up new entry. */ allocate gate_info in (ap -> based_area) set (gp); gate_info.next = fgp; fgp = gp; call hcs_$status_minf (">system_library_1", gate_name, 1, type, bc, code); if code ^= 0 then return; /* Get length of text. */ tlth = divide (bc, 36, 18, 0); call ring0_get_$segptr ("", gate_name, gatep, code); /* Get segno of gate. */ if code ^= 0 then return; gateno = bin (baseno (gatep), 18); call ring_zero_peek_ (addrel (lotp0, gateno), addr (pptr), 1, code); /* Find linkage for gate. */ if code ^= 0 then return; l0p = pptr; call ring_zero_peek_ (l0p, addr (linkhdr), size (linkhdr), code); /* Copy linkage header. */ llth = bin (linkhdr.begin_links, 18) - size (linkhdr); /* Get length of linkage from header. */ no_entries = divide (llth, size (gate_entry_data), 17, 0); /* Compute no of elements. */ if no_entries > 0 then do; allocate static_data in (ap -> based_area) set (slp); /* Allocate static buffer. */ unspec (static_data) = "0"b; /* Clear the data. */ end; else slp = null (); defp = ptr (addr (definitions_$), definitions_$ (gateno).offset); /* Get pointer to definitions for gate. */ /* Fill in new gate info entry. */ gate_info.linkp = addrel (l0p, 8); gate_info.linkl = llth; gate_info.defp = defp; gate_info.textp = gatep; gate_info.textl = tlth; gate_info.stp = slp; gate_info.name = gate_name; gate_info.user = caller_ptr; found: if gate_info.stp = null () then do; nentries = 0; return; end; /* Copy the linkage from ring 0. */ l0p = gate_info.linkp; llth = gate_info.linkl; call ring_zero_peek_ (l0p, tempp, llth, code); /* Copy out the linkage. */ if code ^= 0 then return; /* Compute differences from previous data. */ slp = gate_info.stp; no_entries = divide (llth, size (gate_entry_data), 17, 0); /* Copy the text from ring 0. */ gatep = gate_info.textp; tlth = gate_info.textl; textp = addrel (tempp, llth); call ring_zero_peek_ (gatep, textp, tlth, code); if code ^= 0 then return; savep = addrel (textp, tlth); /* Get pointer for saved data. */ save_data = current_data; /* Save the just copied out data. */ current_data = current_data - static_data; /* Compute the differences. */ /* Iterate through the linkage. */ linkp = addrel (tempp, -8); /* Make pointer to imaginary linkage header. */ defp = gate_info.defp; i = lbound (table, 1); /* Initialize count. */ do p = defp repeat addrel (defp, p -> definition.forward) while (p -> definition.forward); if i > hbound (table, 1) then go to done; if p -> definition.ignore then /* If this isn't really an entry */ go to next_entry; if p -> definition.class ^= "0"b then /* Test for segdef to text. */ go to next_entry; namep = addrel (defp, p -> definition.symbol); if acc_name.name = ".my_lp" then goto next_entry; /* Skip the segdef for gate linkage pointer. */ if acc_name.name = ".tv_end" then goto next_entry; /* also watch out for call limited segdef */ entryp = addrel (textp, p -> definition.value); /* Generate pointer to entry point. */ vrel = entryp -> gate_entry.body_ptr; /* Get relative ptr to validation information. */ vp = addrel (textp, vrel); /* Convert to ITS pointer. */ vp = addrel (vp, -1); /* information is instruction right before */ datarel = vp -> gate_body.info_ptr; /* Get relative ptr to gate data. */ if datarel = "0"b then goto next_entry; /* some gates aren't metered */ gate_datap = addrel (linkp, datarel); /* Convert to ITS pointer. */ table (i).entryp = addr (acc_name.name); table (i).entryl = acc_name.size; table (i).datap = gate_datap; i = i + 1; next_entry: end; done: nentries = i - lbound (table, 1); if reset_sw then /* If reset desired ... */ static_data = save_data; /* Set new static data. */ return; end get_gate_data_;  meter_util_.pl1 01/26/85 1313.2r w 01/22/85 1306.0 47790 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ meter_util_: proc; /* This procedure contains several entries which are used by the hardcore metering programs. To use this package, the user must first call meter_util_$get_buffers to reserve some buffer space (in internal static -- or at least in the linkage segment). */ /* mod fall 78 REM- copy out 280 (not 256) words of tc_data */ /* Modified November 1984 by M. Pandolf to include hc_lock. */ dcl 1 pa (40) aligned static, 2 pad (10) fixed bin; dcl ring_zero_peek_ ext entry (ptr, ptr, fixed bin, fixed bin (35)), ioa_ ext entry options (variable), ioa_$rsnnl ext entry options (variable), ring0_get_$segptr ext entry (char (*), char (*), ptr, fixed bin), hcs_$assign_linkage ext entry (fixed bin, ptr, fixed bin), unique_index fixed bin, meter_time float bin, rs char (12) aligned, a_meter_time float bin, (a_sstp1, a_sstp2, a_tcdp1, a_tcdp2, p, lp) ptr, (code, ignore, sec, min, hr) fixed bin, error_code fixed bin (35), static_index fixed bin static init (1), (sstp0, tcdp0) ptr static, inited bit (1) static init ("0"b), (mod, addr, addrel, divide, substr) builtin, move_280 (280) fixed bin based, move_512 (512) fixed bin based; dcl 1 pa1 based (p) aligned, 2 reset_called fixed bin, 2 pad fixed bin, 2 (sstp1, sstp2, tcdp1, tcdp2) ptr; % include sst; % include tcm; % include hc_lock; /* get_buffers This entry is called to reserve 4 buffers in the combined linkage segment(s) for the process. One buffer is used for the current sst data, one buffer is used for the past sst data, one buffer is used for the current tc_data data, and the last buffer is used for the past tc_data data. */ get_buffers: entry (unique_index, a_sstp1, a_sstp2, a_tcdp1, a_tcdp2, code); unique_index = static_index; static_index = static_index + 1; /* increment unique index generator */ if static_index > 40 then do; /* don't let things get out of hand */ code = 1; return; end; call hcs_$assign_linkage (1584, lp, code); /* reserve the necessary storage */ if code ^= 0 then return; p = addr (pa (unique_index)); /* get pointer to the current sub-structure */ sstp1, a_sstp1 = lp; /* generate pointers, return them, and save them */ sstp2, a_sstp2 = addrel (lp, 512); tcdp1, a_tcdp1 = addrel (lp, 1024); tcdp2, a_tcdp2 = addrel (lp, 1304); if ^ inited then do; /* if haven't got ring zero pointers yet, get them */ call ring0_get_$segptr ("", "sst", sstp0, code); /* get ring zero sst pointer */ if code ^= 0 then return; call ring0_get_$segptr ("", "tc_data", tcdp0, code); /* get ring zero tc_data pointer */ inited = "1"b; /* indicated we've found the pointers */ end; return; fill_buffers: entry (unique_index); /* This entry reads the current data from the sst and tc_data and copies it into the "current" buffer for the specified caller. */ p = addr (pa (unique_index)); /* get a pointer to the current set of pointers */ call ring_zero_peek_ (sstp0, sstp2, 512, error_code); /* copy out the sst */ call ring_zero_peek_ (tcdp0, tcdp2, 280, error_code); /* copy out the tc_data header */ return; reset: entry (unique_index); /* This entry is called to copy the current buffers into the old buffers and hence cause an effective reset of the meters. */ p = addr (pa (unique_index)); /* get a pointer to the current set of pointers */ reset_called = 1; /* set flag saying reset was called */ tcdp1 -> move_280 = tcdp2 -> move_280; /* copy the tc_data header */ sstp1 -> move_512 = sstp2 -> move_512; /* copt the sst header */ return; time: entry (unique_index, a_meter_time); /* This entry prints the time of the metering interval and returns the same to the caller. */ p = addr (pa (unique_index)); /* get a pointer to the callers variables */ if reset_called = 0 then meter_time = tcdp2 -> tcm.last_time - tcdp2 -> tcm.initialize_time; /* use time since bootload */ else meter_time = tcdp2 -> tcm.last_time - tcdp1 -> tcm.last_time; /* use time since last reset */ sec = meter_time*1e-6; /* get number of seconds of metering */ min = divide (sec, 60, 17, 0); /* get minutes of metering */ hr = divide (min, 60, 17, 0); /* get hours of metering */ sec = mod (sec, 60); /* get seconds left in last minute */ min = mod (min, 60); /* get minutes left in last hour */ call ioa_$rsnnl ("^4d^3d^3d", rs, ignore, hr, min+100, sec+100); /* convert to character string */ substr (rs, 5, 1) = ":"; /* fill in separators */ substr (rs, 8, 1) = ":"; call ioa_ ("^/Total metering time^-^a^/", rs); /* print out the metring time */ a_meter_time = meter_time; /* return metering interval lenght */ return; end meter_util_;  metering_util_.pl1 10/24/88 1649.7r w 10/24/88 1401.3 123858 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ metering_util_$define_regions: proc; /* metering utility This is a utility subroutine for hardcore metering commands. It allows definition of "regions", which are arbitrary sections of ring-0 segments containing information of interest to the invoker. These regions are grouped by means of a unique index, which allows multiple use of this subroutine within the same process. This subroutine maintains for each region two buffers in static storage -- one for the "current" copy of the region and one for the "previous" copy; pointers to these buffers are returned following definition. The following entries are provided: metering_util_$define_regions - define hardcore regions, allocate static buffer space metering_util_$fill_buffers - copy all regions associated with a given unique index into the "current" buffers, and return pointers metering_util_$reset - copy all "current" buffers associated with a given unique index into the "previous" buffers Written December 1980 by J. Bongiovanni Modified May 1982 by J. Bongiovanni to handle area condition */ /* Parameter */ dcl current_ptrs (*) ptr; /* pointers to current static buffers */ dcl formatted_time char (*); /* metering time in hhhh:mm:ss */ dcl meter_time fixed bin (71); /* metering time in microseconds */ dcl previous_ptrs (*) ptr; /* pointers to previous static buffers */ dcl rcode fixed bin (35); /* error return code */ dcl unique fixed bin; /* instance identifier */ /* Automatic */ dcl acode fixed bin (35); dcl areap ptr; dcl arg_list_ptr ptr; dcl arg_numeric fixed bin (18); dcl arg_ptr ptr; dcl arg_size fixed bin; dcl arg_size_1 fixed bin (21); dcl arg_type fixed bin; dcl begin_offset fixed bin (18); dcl codep ptr; dcl end_offset fixed bin (18); dcl HR pic "zzz9"; dcl MIN pic "99"; dcl min fixed bin; dcl nargs fixed bin; dcl prev_region_ptr ptr; dcl region_ptr ptr; dcl region_no fixed bin; dcl r0_ptr ptr; dcl SEC pic "99"; dcl sec fixed bin; dcl sub_arg_no fixed bin; dcl time_val fixed bin (71); dcl type fixed bin; dcl unique_index_arg_ptr ptr; dcl why char (50); /* Static */ dcl our_name char (14) init ("metering_util_") int static options (constant); dcl next_unique fixed bin int static init (1); /* next instance number */ dcl unique_region_ptr (40) ptr unal int static init ((40) null ()); /* ptrs to linked list of region */ dcl (begin_end_mess char (32) init ("Region must have positive length"), fixed_char_mess char (37) init ("Argument must be type numeric or char"), ptr_char_mess char (33) init ("Argument must be type ptr or char"), std_err_mess char (12) init ("Invalid call")) int static options (constant); %include std_descriptor_types; /* Based */ dcl arg_name char (arg_size) based (arg_ptr); dcl code fixed bin (35) based (codep); dcl fixed_bin_based fixed bin (18) aligned based (arg_ptr); dcl ptr_ptr ptr based; dcl unique_index_arg fixed bin based (unique_index_arg_ptr); dcl 1 region aligned based (region_ptr), /* structure in static for each region to snap */ 2 next_region ptr, /* next region this instance */ 2 ring0_ptr ptr, /* begin of snap region in ring-0 */ 2 current_time fixed bin (71), /* time of current snap */ 2 previous_time fixed bin (71), /* time of previous snap */ 2 nwords fixed bin (19), /* number of words to snap */ 2 nwords_alloc fixed bin (19), /* number of words in array (mod 2) */ 2 current_snap (end_offset - begin_offset + mod (end_offset - begin_offset, 2) refer (region.nwords_alloc)), 2 previous_snap (end_offset - begin_offset + mod (end_offset - begin_offset, 2) refer (region.nwords_alloc)); /* Area */ dcl static_area area based (areap); /* External */ dcl error_table_$area_too_small fixed bin (35) external; dcl error_table_$bad_arg fixed bin (35) external; dcl error_table_$bad_index fixed bin (35) external; dcl error_table_$invalid_array_size fixed bin (35) external; dcl error_table_$wrong_no_of_args fixed bin (35) external; dcl sys_info$time_of_bootload fixed bin (71) external; /* Entry */ dcl assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin); dcl get_system_free_area_ entry () returns (ptr); dcl ring0_get_$definition entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin (19), fixed bin (35)); dcl sub_err_ entry options (variable); /* Builtin */ dcl (addr, clock, divide, hbound, lbound, mod, null, ptr, unspec) builtin; /* Condition */ dcl area condition; dcl cleanup condition; /* */ /* Do preliminary check of arguments. The number of arguments passed must be 2+3*N, where N is the number of hardcore regions (>0) */ call cu_$arg_count (nargs); if nargs <= 2 then do; call_suberr: call sub_err_ (error_table_$wrong_no_of_args, our_name, "s", null (), (0), std_err_mess); return; end; call cu_$arg_list_ptr (arg_list_ptr); call cu_$arg_ptr (1, unique_index_arg_ptr, arg_size_1, acode); call cu_$arg_ptr (2, codep, arg_size_1, acode); code = 0; if mod (nargs - 2, 3) ^= 0 then goto call_suberr; /* Make sure we havent run out of instances */ if next_unique > hbound (unique_region_ptr, 1) then do; code = error_table_$bad_index; return; end; /* go through each region defined, validate it, and allocate sufficient static storage to hold 2 snapshots plus control information. If an error is encountered, deallocate all static storage allocated this call */ areap = get_system_free_area_ (); region_no = 1; prev_region_ptr = null (); on area begin; code = error_table_$area_too_small; why = "area condition signalled"; goto other_error; end; on cleanup call cleanup_regions; do while (3 * region_no + 2 <= nargs); sub_arg_no = 1; why = ptr_char_mess; call arg_val (3 * region_no); /* ring-0 segment name or pointer */ if arg_type = pointer_dtype then r0_ptr = arg_ptr -> ptr_ptr; else if arg_type = char_dtype then do; call ring0_get_$segptr ("", arg_name, r0_ptr, code); if code ^= 0 then do; why = arg_name; goto other_error; end; end; else goto bad_arg; sub_arg_no = 2; why = fixed_char_mess; call arg_val (3 * region_no + 1); /* begin offset or symbol name */ if arg_type = real_fix_bin_1_dtype then begin_offset = fixed_bin_based; else if arg_type = char_dtype then do; call ring0_get_$definition (r0_ptr, "", arg_name, begin_offset, type, code); if code ^= 0 then do; why = arg_name; goto other_error; end; end; else goto bad_arg; sub_arg_no = 3; why = fixed_char_mess; call arg_val (3 * region_no + 2); /* length or name 1-word beyond end */ if arg_type = real_fix_bin_1_dtype then end_offset = fixed_bin_based + begin_offset; else if arg_type = char_dtype then do; call ring0_get_$definition (r0_ptr, "", arg_name, end_offset, type, code); if code ^= 0 then do; why = arg_name; goto other_error; end; end; else goto bad_arg; why = begin_end_mess; if end_offset - begin_offset <= 0 then goto bad_arg; allocate region in (static_area); region.next_region = null (); region.ring0_ptr = ptr (r0_ptr, begin_offset); region.current_time, region.previous_time = sys_info$time_of_bootload; region.nwords = end_offset - begin_offset; unspec (region.current_snap) = ""b; unspec (region.previous_snap) = ""b; if prev_region_ptr = null () /* 1st region this instance */ then unique_region_ptr (next_unique) = region_ptr; else prev_region_ptr -> region.next_region = region_ptr; prev_region_ptr = region_ptr; region_no = region_no + 1; end; /* Return unique index to be used in future calls */ unique_index_arg = next_unique; next_unique = next_unique + 1; return; bad_arg: code = error_table_$bad_arg; /* Error encountered after scan of hardcore regions. Deallocate all static storage allocated this call */ other_error: call cleanup_regions; call sub_err_ (code, our_name, "s", null (), (0), "^a. ^a. hardcore region ^d subarg no. ^d", std_err_mess, why, region_no, sub_arg_no); return; /* */ fill_buffers: entry (unique, meter_time, formatted_time, current_ptrs, previous_ptrs, rcode); /* validate parameters */ if unique < lbound (unique_region_ptr, 1) | unique > hbound (unique_region_ptr, 1) then do; fill_buffers_arg_error: rcode = error_table_$bad_arg; return; end; if unique_region_ptr (unique) = null () then goto fill_buffers_arg_error; region_no = 0; region_ptr = unique_region_ptr (unique); do while (region_ptr ^= null ()); region_no = region_no + 1; region_ptr = region.next_region; end; if hbound (current_ptrs, 1) ^= region_no | hbound (previous_ptrs, 1) ^= region_no then do; rcode = error_table_$invalid_array_size; return; end; /* snap each hardcore region into the current buffer for same. also pick up and return pointers to current and previous buffer */ time_val = clock (); region_ptr = unique_region_ptr (unique); region_no = 1; meter_time = time_val - region.previous_time; do while (region_ptr ^= null ()); call ring_zero_peek_ (region.ring0_ptr, addr (region.current_snap), region.nwords, rcode); if rcode ^= 0 then return; /* heavy Oops! */ region.current_time = time_val; current_ptrs (region_no) = addr (region.current_snap); previous_ptrs (region_no) = addr (region.previous_snap); region_ptr = region.next_region; region_no = region_no + 1; end; sec = divide (meter_time, 1000000, 17); SEC = mod (sec, 60); min = divide (sec, 60, 17); MIN = mod (min, 60); HR = divide (min, 60, 17); formatted_time = HR || ":" || MIN || ":" || SEC; return; /* */ reset: entry (unique, rcode); /* validate unique index */ if unique < lbound (unique_region_ptr, 1) | unique > hbound (unique_region_ptr, 1) then goto fill_buffers_arg_error; if unique_region_ptr (unique) = null () then goto fill_buffers_arg_error; rcode = 0; /* reset each region for this unique index by copying each current buffer into the corresponding previous buffer */ region_ptr = unique_region_ptr (unique); do while (region_ptr ^= null ()); region.previous_snap = region.current_snap; region.previous_time = region.current_time; region_ptr = region.next_region; end; return; /* Internal subroutine to examine arguments and do preliminary screening. Assumed on input: arg_list_ptr points to argument list for main program Set on output: arg_type - argument type arg_size - argument size arg_ptr - pointer to argument If the argument is numeric, it is converted to fixed bin (18) aligned, and the values above set to the converted argument */ arg_val: proc (n); dcl n fixed bin; /* argument number */ dcl av_code fixed bin (35); dcl len fixed bin (21); dcl ndims fixed bin; dcl packed bit (1) aligned; dcl scale fixed bin; call decode_descriptor_ (arg_list_ptr, n, arg_type, packed, ndims, arg_size, scale); if (packed & arg_type ^= char_dtype) | arg_type = -1 | ndims ^= 0 | scale ^= 0 then goto bad_arg; call cu_$arg_ptr_rel (n, arg_ptr, len, av_code, arg_list_ptr); if (arg_type <= cplx_flt_dec_9bit_dtype) | (arg_type >= real_fix_bin_1_uns_dtype & arg_type <= real_fix_bin_2_uns_dtype) | (arg_type >= real_fix_dec_4bit_ls_dtype & arg_type <= real_flt_dec_4bit_bytealigned_dtype) then do; call assign_ (addr (arg_numeric), 2 * real_fix_bin_1_dtype, 18, arg_ptr, 2 * arg_type, bin (arg_size, 35)); arg_ptr = addr (arg_numeric); arg_size = 18; arg_type = real_fix_bin_1_dtype; end; end arg_val; /* Internal procedure to clean up any space we may have allocated */ cleanup_regions: proc; prev_region_ptr = unique_region_ptr (next_unique); do while (prev_region_ptr ^= null ()); region_ptr = prev_region_ptr; prev_region_ptr = region.next_region; free region in (static_area); end; unique_region_ptr (next_unique) = null (); end cleanup_regions; end metering_util_$define_regions;  get_vol_list_.pl1 01/09/87 1338.5rew 01/09/87 1314.5 79938 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-16,Fawcett), approve(86-04-10,MCR7383), audit(86-05-27,Wallman), install(86-07-18,MR12.0-1098): Add support for subvolumes, 3380 and 3390. 2) change(86-11-10,Fawcett), approve(86-11-10,MCR7125), audit(87-01-08,Farley), install(87-01-09,MR12.0-1266): Changed by Tom Oke to conform to documentation. 3) change(86-11-10,Fawcett), approve(86-11-10,MCR7547), audit(87-01-08,Farley), install(87-01-09,MR12.0-1266): Changed so disk_meters can display subvolume devices correctly. END HISTORY COMMENTS */ get_vol_list_: proc (a_pv_list_ptr, a_lv_list_ptr, a_area_ptr, a_version, a_code); /* Program to determine logical and physical volume names in a MULTICS system and allocate and return structures with this information. */ /* format: off */ /* Input: a_pv_list_ptr is a pointer to the pv_list structure. If it is non-null, it is taken to point to an existing structure which is size checked for validity and returned and re-allocated if necessary. a_lv_list_ptr is a pointer to the lv_list structure. If it is non-null, it is taken to point to an existing structure which is size checked for validity and returned and re-allocated if necessary. a_area_ptr is a pointer to the area to allocate the structures in. If it is null (), system_free_area is used. a_version is an 8 character string of the version of structure the calling routine is expecting to receive. code error code. */ /* format: on */ /* Interface declaratons. */ dcl a_pv_list_ptr ptr; dcl a_lv_list_ptr ptr; dcl a_area_ptr ptr; dcl a_version char (8); dcl a_code fixed bin (35); /* Automatic */ dcl area_ptr ptr; dcl code fixed bin (35); dcl i fixed bin; dcl 1 ai like area_info; dcl max_lvs fixed bin; dcl max_pvs fixed bin; dcl temp_ptr ptr; /* to temp seg */ dcl (addr, currentsize, length, max, null, rtrim, unspec) builtin; dcl cleanup condition; /* Static */ dcl entry_name char (32) static options (constant) initial ("get_vol_list_"); /* Areas */ dcl areas area based (area_ptr); /* Structure Funnies */ /* The following array is used to determine the size to allocate for the structures to return. We overlay the lv and pv structures onto the array, fill in the size words (which exist within the size of the array) and then do a currentsize (of a structure which for the most part doesn't exist) to determine its real size to allocate. We cannot do it with allocation, since we need the internal size words correctly set to allocate the true size. */ dcl allocating_array (alloc_size) fixed bin (35) based; dcl alloc_size fixed bin; /* currentsize */ dcl sizing_array (10) fixed bin (35); /* Entries */ dcl area_info_ entry (ptr, fixed bin (35)); dcl error_table_$improper_data_format fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl mdc_$read_disk_table entry (ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl get_system_free_area_ entry () returns (ptr); %page; if a_version ^= get_vol_list_version then do; BAD_VERSION: a_code = error_table_$unimplemented_version; return; end; if a_area_ptr = null () then area_ptr = get_system_free_area_ (); else if valid_area (a_area_ptr) then area_ptr = a_area_ptr; else do; a_code = error_table_$improper_data_format; return; end; temp_ptr = null (); on cleanup begin; if temp_ptr ^= null () then call release_temp_segment_ (entry_name, temp_ptr, code); end; call get_temp_segment_ (entry_name, temp_ptr, code); if code ^= 0 then do; a_code = code; return; end; dtp = temp_ptr; /* setup disk_table */ call mdc_$read_disk_table (dtp, code); if code ^= 0 then do; a_code = code; goto exit; end; /* Determine if we need to allocate pv_list and lv_list. */ do i = 1 to dt.max_n_entries; if (dt.array (i).used | dt.array (i).is_sub_vol) then max_pvs = i; if dt.lv_array (i).used = "1"b then max_lvs = i; end; pv_list_ptr = a_pv_list_ptr; lv_list_ptr = a_lv_list_ptr; if pv_list_ptr ^= null () then do; if pv_list_ptr -> pv_list.version ^= get_vol_list_version then goto BAD_VERSION; if pv_list_ptr -> pv_list.pv_name_count ^= max_pvs then do; if valid_area (pv_list.area_ptr) then do; if ^ai.no_freeing then free pv_list in (pv_list.area_ptr -> areas); end; pv_list_ptr = null (); end; end; if lv_list_ptr ^= null () then do; if pv_list_ptr -> pv_list.version ^= get_vol_list_version then goto BAD_VERSION; if lv_list_ptr -> lv_list.lv_name_count ^= max_lvs then do; if valid_area (lv_list.area_ptr) then do; if ^ai.no_freeing then free lv_list in (lv_list.area_ptr -> areas); end; lv_list_ptr = null (); end; end; /* Allocate space if needed. */ if pv_list_ptr = null () then do; addr (sizing_array) -> pv_list.pv_name_count = max_pvs; alloc_size = currentsize (addr (sizing_array) -> pv_list); allocate allocating_array in (areas) set (pv_list_ptr); pv_list.pv_name_count = max_pvs; pv_list.area_ptr = area_ptr; end; if lv_list_ptr = null () then do; addr (sizing_array) -> lv_list.lv_name_count = max_lvs; alloc_size = currentsize (addr (sizing_array) -> lv_list); allocate allocating_array in (areas) set (lv_list_ptr); lv_list.lv_name_count = max_lvs; lv_list.area_ptr = area_ptr; end; pv_list.version = get_vol_list_version; lv_list.version = get_vol_list_version; pv_list.pv_name_max_length = 0; do max_pvs = max_pvs by -1 to 1; pv_list.pv_info (max_pvs).used = dt.array (max_pvs).used; pv_list.pv_info (max_pvs).storage_system = dt.array (max_pvs).storage_system; pv_list.pv_info (max_pvs).permanent = dt.array (max_pvs).permanent; pv_list.pv_info (max_pvs).hc_accepted = dt.array (max_pvs).hc_accepted; pv_list.pv_info (max_pvs).rpv = dt.array (max_pvs).rpv; pv_list.pv_info (max_pvs).is_sub_vol = dt.array (max_pvs).is_sub_vol; pv_list.pv_info (max_pvs).num_of_sv = dt.array (max_pvs).num_of_sv; pv_list.pv_info (max_pvs).sv_num = dt.array (max_pvs).sv_num; pv_list.pv_info (max_pvs).device_type = dt.array (max_pvs).device_type; pv_list.pv_info (max_pvs).lvx = dt.array (max_pvs).lvx; pv_list.pv_info (max_pvs).drive_name = dt.array (max_pvs).drive_name; pv_list.pv_info (max_pvs).pvname = dt.array (max_pvs).pvname; if dt.array (max_pvs).used = "1"b then pv_list.pv_name_max_length = max (length (rtrim (pv_list.pv_info (max_pvs).pvname)), pv_list.pv_name_max_length); end; lv_list.lv_name_max_length = 0; do max_lvs = max_lvs by -1 to 1; lv_list.lv_info (max_lvs).used = dt.lv_array (max_lvs).used; lv_list.lv_info (max_lvs).hv_mounted = dt.lv_array (max_lvs).hv_mounted; lv_list.lv_info (max_lvs).public = dt.lv_array (max_lvs).public; lv_list.lv_info (max_lvs).mounting = dt.lv_array (max_lvs).mounting; lv_list.lv_info (max_lvs).demounting = dt.lv_array (max_lvs).demounting; lv_list.lv_info (max_lvs).pdirs_ok = dt.lv_array (max_lvs).pdirs_ok; lv_list.lv_info (max_lvs).prev_bootload = dt.lv_array (max_lvs).prev_bootload; lv_list.lv_info (max_lvs).vacate_pdirs = dt.lv_array (max_lvs).vacate_pdirs; lv_list.lv_info (max_lvs).lvname = dt.lv_array (max_lvs).lvname; if dt.lv_array (max_lvs).used = "1"b then lv_list.lv_name_max_length = max (length (rtrim (lv_list.lv_info (max_lvs).lvname)), lv_list.lv_name_max_length); end; /* Cleanup and exit routine. */ exit: call release_temp_segment_ (entry_name, temp_ptr, code); a_pv_list_ptr = pv_list_ptr; a_lv_list_ptr = lv_list_ptr; return; valid_area: proc (area_ptr) returns (bit (1)); /* validates and area and leaves area information in ai. */ dcl area_ptr ptr; unspec (ai) = "0"b; ai.version = area_info_version_1; ai.areap = area_ptr; call area_info_ (addr (ai), code); if code ^= 0 then return ("0"b); if ai.version_of_area ^= ai.version then return ("0"b); return ("1"b); end valid_area; %page; %include get_vol_list_; %include disk_table; %include area_info; end get_vol_list_; 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