force_write.pl1 10/23/92 1027.5rew 10/23/92 1026.2 98631 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1992 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(92-09-16,WAAnderson), approve(92-09-16,MCR8261), audit(92-09-24,Vu), install(92-10-23,MR12.5-1040): The values sst$fw_none and sst$force_pwrites were not being updated correctly due to the uninitialized variable num_writ in WRITE_ONE_SEGMENT. It was possible to use the value to determine the actions taken by a conditional statement and used in a calculation before it was ever set. END HISTORY COMMENTS */ /* format: style3 */ force_write: proc (Segp, Fwf, Code); /* Force_write-- procedure to force I/O on a segment from user ring. Bernard Greenberg 2/3/77 */ /* Bob Mullen made this program a lot better, several times in '77, '78 */ /* pds limit, BSG 8/18/78 */ /* Modified for ADP PTWs, SDWs, 03/21/81, W. Olin Sibert */ /* Modified for consecutive, list entries, November 1982, J. Bongiovanni */ /* Modified to work on segments which are currently not connected to the caller's process, 30mar83, M.Pandolf */ /* Note: we do not use search_ast$check, to avoid the expense of deriving the pvid and vtocx for the segment. If there is actually a double-uid conflict, we are either going to write the correct segment, or harrass some other segment. In either case, we end up with the pages of the 'correct' segment on disk, if at all possible. */ /* Parameter */ dcl Code fixed bin (35) parameter; /* Standard error code */ dcl Flush_Consecp ptr parameter; /* -> structure describing segments to be flushed */ dcl Flushp ptr parameter; /* -> structure describing pages to be flushed */ dcl Fwf bit (36) unaligned parameter; /* Flags - see force_write_flags.incl.pl1 */ dcl Segp pointer parameter; /* -> segment to be written */ dcl Write_Limit fixed bin parameter; /* Maximum outstanding I/Os for this val level on force-write */ /* Automatic */ dcl code fixed bin (35); dcl done_list bit (1) aligned; dcl done_seg bit (1) aligned; dcl first_page fixed bin; dcl 1 fwf like force_write_flags aligned; dcl have_list bit (1) aligned; dcl n_pages fixed bin; dcl page_list (0:255) fixed bin; dcl page_no fixed bin; dcl pagex fixed bin; dcl seg_no fixed bin; dcl seg_pagex fixed bin; dcl segp ptr; dcl segx fixed bin; dcl write_limit fixed bin; /* Based */ dcl 1 Flush_Consec aligned like flush_consec based (Flush_Consecp); dcl 1 Flush aligned like flush based (Flushp); /* External */ dcl error_table_$argerr fixed bin (35) external static; dcl error_table_$dirseg fixed bin (35) external static; dcl error_table_$invalidsegno fixed bin (35) external static; dcl error_table_$unimplemented_version fixed bin (35) external static; dcl pds$force_write_limit (0:7) fixed bin external static; dcl pds$validation_level fixed bin external static; dcl sst$astsize fixed bin external static; dcl sst$force_pwrites fixed bin (35) external static; dcl sst$force_swrites fixed bin (35) external static; dcl sst$force_updatevs fixed bin (35) external static; dcl sst$fw_none fixed bin (35) external static; dcl sst$fw_retries fixed bin (35) external static; /* Entry */ dcl get_ptrs_$given_segno entry (fixed bin (17)) returns (ptr); dcl lock$lock_ast entry (); dcl lock$unlock_ast entry (); dcl pc_wired$write_wait_uid entry (ptr, fixed bin, fixed bin, bit (36) aligned); dcl pc_wired$write_wait_uid_list entry (ptr, ptr, fixed bin, fixed bin, bit (36) aligned); dcl ptw_util_$get_phm entry (pointer, bit (1) aligned); dcl search_ast entry (bit (36) aligned) returns (ptr); dcl update_vtoce entry (ptr); /* Builtin */ dcl addr builtin; dcl addrel builtin; dcl baseno builtin; dcl baseptr builtin; dcl fixed builtin; dcl hbound builtin; dcl min builtin; dcl null builtin; dcl string builtin; dcl unspec builtin; %page; segp = Segp; string (fwf) = Fwf; have_list = "0"b; n_pages = -1; call WRITE_ONE_SEGMENT (code); Code = code; return; %page; consecutive: entry (Flush_Consecp, Code); Code = 0; unspec (fwf) = ""b; have_list = "1"b; if Flush_Consec.version ^= FLUSH_CONSEC_VERSION_1 then do; Code = error_table_$unimplemented_version; return; end; do segx = 1 to Flush_Consec.n_segs; segp = baseptr (Flush_Consec.seg (segx).segno); first_page = Flush_Consec.seg (segx).first_page; n_pages = Flush_Consec.seg (segx).n_pages; if first_page < 0 | (first_page + n_pages) > 255 then do; Code = error_table_$argerr; return; end; unspec (page_list) = ""b; do pagex = 0 to n_pages - 1; page_list (pagex) = first_page + pagex; end; call WRITE_ONE_SEGMENT (Code); if Code ^= 0 then return; end; return; %page; list: entry (Flushp, Code); Code = 0; unspec (fwf) = ""b; have_list = "1"b; if Flush.version ^= FLUSH_VERSION_1 then do; Code = error_table_$unimplemented_version; return; end; done_list = "0"b; seg_pagex = 1; do while (^done_list); if seg_pagex > Flush.n_pages then done_list = "1"b; else do; seg_no = Flush.seg_page (seg_pagex).seg_no; segp = baseptr (seg_no); pagex = 0; done_seg = "0"b; do while (^done_seg); if seg_pagex > Flush.n_pages then done_seg = "1"b; else if Flush.seg_page (seg_pagex).seg_no ^= seg_no then done_seg = "1"b; else do; page_no = Flush.seg_page (seg_pagex).page_no; if page_no < 0 | page_no > 255 then do; ARGERR: Code = error_table_$argerr; return; end; if pagex > hbound (page_list, 1) then goto ARGERR; page_list (pagex) = page_no; pagex = pagex + 1; seg_pagex = seg_pagex + 1; end; end; n_pages = pagex; call WRITE_ONE_SEGMENT (Code); if Code ^= 0 then return; end; end; return; %page; set_force_write_limit: entry (Write_Limit, Code); write_limit = Write_Limit; if write_limit < 1 | write_limit > 256 then code = error_table_$argerr; else do; pds$force_write_limit (pds$validation_level) = write_limit; code = 0; end; Code = code; return; %page; /* Internal Procedure to do the work for one segment */ WRITE_ONE_SEGMENT: proc (Code); dcl Code fixed bin (35) parameter; dcl first_page fixed bin; dcl force_write_limit fixed bin; dcl i fixed bin; dcl increment fixed bin; dcl last_page fixed bin; dcl lp fixed bin; dcl num_writ fixed bin; dcl page_no fixed bin; dcl phm_bit bit (1) aligned; dcl ptp pointer; dcl segno fixed bin (17); dcl tuid bit (36) aligned; Code = 0; num_writ = 0; segno = fixed (baseno (segp)); /* Get segno */ kstp = pds$kstp; force_write_limit = pds$force_write_limit (pds$validation_level); if segno < kst.lowseg | segno > kst.highest_used_segno then do; /* Validate segno range */ segno_is_bad: Code = error_table_$invalidsegno; return; end; sst$force_swrites = sst$force_swrites + 1; /* Meter */ kstep = addr (kst.kst_entry (segno)); if unspec (kste.entryp) = ""b then goto segno_is_bad; /* Verify that seg is initiated */ if kste.dirsw then do; /* Don't force write dirs */ Code = error_table_$dirseg; return; end; tuid = kste.uid; astep = get_ptrs_$given_segno (segno); /* Get astep via dseg */ if astep = null then do; /* Segment is not connected */ call lock$lock_ast; astep = search_ast (tuid); call lock$unlock_ast; if astep = null /* Segment is not active */ then goto ret; end; if aste.uid = ""b then do; Code = error_table_$invalidsegno; goto ret; /* No soap on hc segs */ end; RETRY: ptp = addrel (astep, sst$astsize); num_writ = 0; /* nothing written yet */ first_page = -1; if force_write_limit < 2 then fwf.serial_write = "1"b; if have_list then lp = n_pages - 1; else lp = fixed (aste.csl, 9) - 1; do i = 0 to lp; if have_list then page_no = page_list (i); else page_no = i; call ptw_util_$get_phm (addrel (ptp, page_no), phm_bit); /* Modified anytime? */ if phm_bit /* See if page needs writing, */ then do; /* and do so if we are to write serially */ last_page = i; if first_page = -1 then first_page = i; num_writ = num_writ + 1; if fwf.serial_write then call pc_wired$write_wait_uid (astep, page_no, 1, tuid); end; end; if ^fwf.serial_write & num_writ ^= 0 /* If parallel write and we have pages */ then do; /* then write the lot out */ if num_writ <= force_write_limit then increment = last_page - first_page + 1; else increment = force_write_limit; do i = first_page to last_page by increment; if have_list then call pc_wired$write_wait_uid_list (astep, addr (page_list), i, min ((last_page - i + 1), increment), tuid); else call pc_wired$write_wait_uid (astep, i, min ((last_page - i + 1), increment), tuid); end; end; if aste.uid ^= tuid then do; /* check race with segmove */ call lock$lock_ast; astep = search_ast (tuid); call lock$unlock_ast; if astep ^= null () then do; sst$fw_retries = sst$fw_retries + 1; goto RETRY; end; else goto ret; /* deactivated seg means all done */ end; /* if here then valid astep and aste.uid = tuid */ if ^aste.fmchanged /* no change in aste? */ then if aste.uid = tuid /* and still same aste? */ then goto ret; /* then this is the EZ case */ call lock$lock_ast; /* If here then looks like vtoce needs updating */ if aste.uid ^= tuid /* Has aste moved? */ then astep = search_ast (tuid); /* If so then find it */ if astep ^= null then if aste.fmchanged /* no one else did update */ then do; sst$force_updatevs = sst$force_updatevs + 1; call update_vtoce (astep); end; call lock$unlock_ast; ret: if num_writ = 0 then sst$fw_none = sst$fw_none + 1; else sst$force_pwrites = sst$force_pwrites + num_writ; return; end WRITE_ONE_SEGMENT; /* format: off */ %page; %include aste; %page; %include flush_structures; %page; %include force_write_flags; %page; %include kst; end force_write;  hc_tune.pl1.pmac 11/11/89 1136.0rew 11/11/89 0800.0 236997 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* use: pl1_macro hc_tune.pl1.pmac */ hc_tune: proc (); /* * HC_TUNE * * This procedure manages the getting and setting of system tuning parameters. * It is organized in a somewhat unusual fashion for a PL/I program, in order to * make the addition of new tuning parameters as simple as possible. All the tuning * parameters appear in a section of code at the very end of this program. A complex * mechanism of gotos and label variables is used to minize the size of the program, * and, more importantly, to make the description of individual tuning parameters * as simple and straightforward as possible. Each tuning parameter must be a single * word quantity at some known address in the supervisor, and is described by a * block of code like this: * * dcl tc_data$post_purge_switch fixed bin (35) external static; * %set NUM to NUM + 1; * TP (NUM): call tp_init (addr (tc_data$post_purge_switch), * "post_purge", "pp", TP_ON_OFF); * * call on_or_off (); * goto RETURN; * * The parameters to tp_init are: * 1) The location of the value in the supervisor address space. * 2) The long name of the tuning parameter. * 3) The short name. If the short name is "", it will be the same as the long name. * 4) The type, as defined in tuning_parameter_info.incl.pl1 * * Additionally, the value tp_special may be set to "1"b to indicate that this parameter * is not to be listed by a normal listing operation. It is intended for internal system * parameters, solely in order to make them easy to set by other than patching. * * There are two procedures available to insure that an input value is acceptable. The * range procedure is called with two limits, and aborts an attempt to set if the value * falls outside the limits of the specified range. The on_or_off procedure aborts if * an attempt is made to set an on/off parameter to an invalid value. Additionally, the * procedure abort may be called if it is necessary to invalid a n attempt to set a * tuning parameter for some other, more complex, reason. * * The existing examples in this program should be used as guidelines for how to add * and name new tuning parameters. * * 04/21/81, W. Olin Sibert * Modified 10/24/81, J. Bongiovanni, to fix bug in maxabs * Modified February 1982, BIM, for stack truncation parameters * Modified March 1982, J. Bongiovanni, for trap_invalid_masked, wsf bug fix * Modified April 1982, J. Bongiovanni, gv_integration * Modified July 1982, J. Bongiovanni, meter_ast_locking * Modified August 1982, J. Bongiovanni, realtime_io parameters * Modified October 1982, J. Bongiovanni, checksum_filemap * Modified February 1983, E. N. Kittlitz, default_256K_enable * Modified October 1984, M. Pandolf, dirlock_writebehind */ /* */ dcl P_input_name char (32) parameter; /* Name of parameter to get or set */ dcl P_old_value bit (36) aligned parameter; /* Current value for parameter */ dcl P_new_value bit (36) aligned parameter; /* New value, for setting */ dcl P_tp_ptr pointer parameter; /* Its address (in ring zero) */ dcl P_long_name char (*) parameter; /* Long name, for output */ dcl P_short_name char (*) parameter; /* Short name, for output */ dcl P_error char (*) parameter; /* Description of error while setting, if any */ dcl P_tp_type fixed bin parameter; /* Its type */ dcl P_area_ptr pointer parameter; /* Pointer to area for parameter list allocation */ dcl P_special_flag bit (1) aligned parameter; /* Whether to return "special" values, in a listing */ dcl P_tp_count fixed bin parameter; /* Number of defined tuning parameters */ dcl P_tp_list_ptr pointer parameter; /* Pointer to returned array of info */ dcl P_code fixed bin (35) parameter; /* Error code */ dcl input_name char (32); dcl function fixed bin; /* What we are supposed to do */ dcl return_label label variable internal local; /* Used for our pseudo-subroutine call mechanism */ dcl lookup_return_label variable label internal local; dcl severity fixed bin; /* Severity code for syserr call */ dcl code fixed bin (35); dcl return_special bit (1) aligned; /* Whether to list "special" parameters */ dcl error_reason char (128); /* Description of error encountered in setting */ dcl based_value bit (36) aligned based; /* For parameter assignment */ dcl list_area area based (list_area_ptr); dcl list_area_ptr pointer; dcl 1 tp_list (tp_list_size) based (tp_list_ptr) like tp_info; dcl tp_list_ptr pointer; dcl tp_list_size fixed bin; dcl list_idx fixed bin; dcl tp_ptr pointer; /* Pointer to tuning parameter currently of interest */ dcl tp_type fixed bin; /* Type of this tuning parameter */ dcl tp_idx fixed bin; /* Its index */ dcl tp_short_name char (16); /* Short and long names */ dcl tp_long_name char (32); dcl tp_special bit (1) aligned; /* Whether it is "special" */ dcl tp_value bit (36) aligned; /* Current value, as bits */ dcl binary_value fixed bin (35) aligned; /* unspec equivalent of tp_value */ dcl scaled_value fixed bin (35, 18) aligned; /* unspec equivalent of tp_value */ dcl char_value char (4) aligned; /* unspec equivalent of tp_value */ dcl float_value float bin (27) aligned; /* unspec equivalent of tp_value */ dcl new_value bit (36) aligned; /* New value, as above */ dcl new_binary_value fixed bin (35) aligned; dcl new_scaled_value fixed bin (35, 18) aligned; dcl new_char_value char (4) aligned; dcl new_float_value float bin (27) aligned; dcl pds$process_group_id char (32) aligned external static; dcl error_table_$unknown_tp fixed bin (35) external static; dcl error_table_$invalid_tp_value fixed bin (35) external static; dcl syserr entry options (variable); dcl ONE_SECOND fixed bin (35) internal static options (constant) init (1000000); /* Assorted limits in microseconds */ dcl ONE_MINUTE fixed bin (35) internal static options (constant) init (60000000); dcl TEN_MINUTES fixed bin (35) internal static options (constant) init (600000000); dcl FIVE_HOURS fixed bin (35) internal static options (constant) init (18000000000); dcl SCALE fixed bin (35) internal static options (constant) init (262144); /* Converts fixed bin (35) to (35,18) */ dcl LIST init (1) fixed bin internal static options (constant); dcl GET init (2) fixed bin internal static options (constant); dcl SET init (3) fixed bin internal static options (constant); dcl (addr, decimal, divide, float, hbound, round, trunc, unspec) builtin; /* */ hc_tune$get: entry (P_input_name, P_tp_type, P_old_value, P_tp_ptr, P_long_name, P_short_name, P_code); /* This entrypoint returns the address and present value of the named tuning parameter. It will return an error code if the tuning parameter does not exist. It is accessed via metering_gate_$get_tuning_parameter */ input_name = P_input_name; /* Copy input parameter */ function = GET; /* Say what we're doing */ code = 0; return_label = GET_LOOKUP_RETURNS; goto LOOKUP; /* Find it, set idx & code */ GET_LOOKUP_RETURNS: if code ^= 0 then do; /* Couldn't find it */ P_code = code; return; end; P_old_value = tp_value; /* Return value and address */ P_tp_ptr = tp_ptr; P_tp_type = tp_type; P_long_name = tp_long_name; P_short_name = tp_short_name; P_code = 0; return; /* End of hc_tune$get */ /* */ hc_tune$set: entry (P_input_name, P_new_value, P_old_value, P_tp_ptr, P_error, P_code); /* This entry sets a tuning parameter, also returning its old value and address. The change is announced on the BOS console. It is accessed via hphcs_$set_tuning_parameter */ severity = ANNOUNCE; goto SET_COMMON; hc_tune$set_silent: entry (P_input_name, P_new_value, P_old_value, P_tp_ptr, P_error, P_code); /* This entry sets a tuning parameter, as above, but logs the change without typing it out. Used only by the Initializer, it is accessed via initializer_gate_$set_tuning_parameter */ severity = LOG; goto SET_COMMON; SET_COMMON: code = 0; input_name = P_input_name; /* Copy input parameter */ new_value = P_new_value; unspec (new_binary_value) = new_value; /* Make it available in all its forms */ unspec (new_scaled_value) = new_value; unspec (new_char_value) = new_value; unspec (new_float_value) = new_value; function = GET; /* First, find it */ return_label = SET_LOOKUP_RETURNS; goto LOOKUP; /* Find it, set idx & code */ SET_LOOKUP_RETURNS: if code ^= 0 then do; /* Can't set it */ P_code = code; P_error = error_reason; return; end; P_old_value = tp_value; /* Return value and address */ P_tp_ptr = tp_ptr; function = SET; /* Next, check whether the new value is valid */ return_label = SET_CHECK_RETURNS; goto TP (tp_idx); SET_CHECK_RETURNS: if code ^= 0 then do; /* Can't set it */ P_code = code; P_error = error_reason; return; end; /* */ if tp_type = TP_CHAR then /* Call syserr to announce the change */ call syserr (severity, "hc_tune: Changing ^a from ""^4a"" to ""^4a"" for ^a", tp_long_name, char_value, new_char_value, pds$process_group_id); else if tp_type = TP_INTEGER then call syserr (severity, "hc_tune: Changing ^a from ^d to ^d for ^a", tp_long_name, binary_value, new_binary_value, pds$process_group_id); else if tp_type = TP_SCALED_INTEGER then call syserr (severity, "hc_tune: Changing ^a from ^f to ^f for ^a", tp_long_name, round (decimal (scaled_value), 4), round (decimal (new_scaled_value), 4), pds$process_group_id); else if tp_type = TP_MICROSECONDS then call syserr (severity, "hc_tune: Changing ^a from ^f to ^f seconds for ^a", tp_long_name, (float (binary_value) / 1.0e6), (float (new_binary_value) / 1.0e6), pds$process_group_id); else if tp_type = TP_ON_OFF then call syserr (severity, "hc_tune: Changing ^a from ^[on^;off^] to ^[on^;off^] for ^a", tp_long_name, (binary_value ^= 0), (new_binary_value ^= 0), pds$process_group_id); else if tp_type = TP_FLOAT then call syserr (severity, "hc_tune: Changing ^a from ^f to ^f for ^a.", tp_long_name, float_value, new_float_value, pds$process_group_id); else call syserr (severity, "hc_tune: Changing ^a from ^w to ^w for ^a", tp_long_name, tp_value, new_value, pds$process_group_id); tp_ptr -> based_value = new_value; /* Do it */ P_code = 0; P_error = ""; return; /* End of hc_tune$get */ /* */ hc_tune$list: entry (P_area_ptr, P_special_flag, P_tp_count, P_tp_list_ptr); /* This entrypoint returns a list of all the defined tuning parameters, and their current values. If P_special_flag is set, it returns all parameters, including special ones. It is accessed via metering_gate_$list_tuning_parameters. */ input_name = ""; code = 0; list_area_ptr = P_area_ptr; return_special = P_special_flag; function = LIST; return_label = LIST_COUNT_RETURNS; /* "return" to our label, below */ tp_list_size = 0; /* start out empty */ do tp_idx = 1 to hbound (TP, 1); /* First, count them */ goto TP (tp_idx); /* "call" */ LIST_COUNT_RETURNS: if return_special | (^tp_special) then tp_list_size = tp_list_size + 1; end; allocate tp_list in (list_area) set (tp_list_ptr); /* Make room to return to our caller */ return_label = LIST_LISTING_RETURNS; /* "return" to our label, below */ list_idx = 1; /* start out with the first one */ do tp_idx = 1 to hbound (TP, 1); /* Get info for each parameter, again */ goto TP (tp_idx); /* "call" to get info on this parameter */ LIST_LISTING_RETURNS: /* and "return" here */ if tp_special & (^return_special) then goto LIST_NOT_RETURN_THIS_ONE; tp_list (list_idx).type = tp_type; tp_list (list_idx).long_name = tp_long_name; tp_list (list_idx).short_name = tp_short_name; tp_list (list_idx).ptr = tp_ptr; tp_list (list_idx).value = tp_value; tp_list (list_idx).special = tp_special; list_idx = list_idx + 1; LIST_NOT_RETURN_THIS_ONE: end; P_tp_count = tp_list_size; /* Return info */ P_tp_list_ptr = tp_list_ptr; return; /* End of hc_tune$list */ /* */ tp_init: proc (P_tp_ptr, P_long_name, P_short_name, P_type); dcl P_tp_ptr pointer parameter; dcl P_long_name char (*) parameter; dcl P_short_name char (*) parameter; dcl P_type fixed bin; /* This procedure initializes values for a single tuning parameter */ tp_ptr = P_tp_ptr; tp_long_name = P_long_name; tp_short_name = P_short_name; tp_type = P_type; if tp_short_name = "" then tp_short_name = tp_long_name; tp_special = "0"b; code = 0; tp_value = tp_ptr -> based_value; /* Get the value from ring zero */ unspec (binary_value) = tp_value; unspec (scaled_value) = tp_value; unspec (char_value) = tp_value; unspec (float_value) = tp_value; return; end tp_init; /* */ /* This portion of the program decides whether a particular tuning parameter exists, and sets code and tp_idx appropriately. */ LOOKUP: lookup_return_label = return_label; /* Save return label, for "recursion" */ return_label = LOOKUP_INTERNAL_RETURN; do tp_idx = 1 to hbound (TP, 1); /* Try each one in its turn */ goto TP (tp_idx); /* "call" */ LOOKUP_INTERNAL_RETURN: if tp_long_name = input_name then goto lookup_return_label; /* This is the one we want */ if tp_short_name = input_name then goto lookup_return_label; end; code = error_table_$unknown_tp; /* Sorry, no sale */ error_reason = ""; tp_idx = -1; goto lookup_return_label; /* "return" */ /* This part of the program finishes off the lookup/checking of each individual tuning parameter */ RETURN: goto return_label; /* Set all values, etc. */ /* This label is used to indicate that a parameter cannot be set to the requested value for some reason. No attempt is made to describe the reason, however. */ ABORT_SETTING: code = error_table_$invalid_tp_value; goto return_label; /* */ range: proc (P_lower, P_upper, P_range_description); /* This procedure insures that, for set attempts only, the specified value is within range */ dcl P_lower fixed bin (35) parameter; dcl P_upper fixed bin (35) parameter; dcl P_range_description char (*) parameter; if function ^= SET then return; /* Not setting, ignore it */ if new_binary_value < P_lower then call abort (P_range_description); if new_binary_value > P_upper then call abort (P_range_description); return; /* All OK */ end range; need_integer: proc (); /* This procedure aborts if a scaled "integer" is not actually an integral value */ if function ^= SET then return; if trunc (new_scaled_value) ^= new_scaled_value then call abort ("an integer value"); return; end need_integer; on_or_off: proc (); /* This procedure rejects attempts to set on/off parameters to invalid values */ if function ^= SET then return; /* Not setting, ignore it */ if new_binary_value ^= 0 then if new_binary_value ^= 1 then call abort ("Not ""on"" or ""off"""); return; /* All OK */ end on_or_off; /* COMMENT THIS IN WHEN A FLOATING POINT PARM IS DEFINED */ /* float_range: /* procedure (P_lower, P_upper, P_range_description); /* /* declare (P_lower, P_upper) float bin (27) aligned; /* declare P_range_description character (*); /* if function ^= SET then return; /* if new_float_value < P_lower | new_float_value > P_upper /* then call abort (P_range_description); /* return; /* end float_range; */ scaled_range: procedure (P_lower, P_upper, P_range_description); declare (P_lower, P_upper) fixed bin (35, 18); declare P_range_description character (*); if function ^= SET then return; if new_scaled_value < P_lower | new_scaled_value > P_upper then call abort (P_range_description); return; end scaled_range; abort: proc (P_reason); /* This procedure just performs an abort -- it would be used anywhere the valid values cannot be tested by either of the above procedures. It is a procedure only in order to retain the general procedural structure of this program. */ dcl P_reason char (*); error_reason = P_reason; goto ABORT_SETTING; end abort; /* */ /* At last, the tuning parameters themselves: */ %set NUM to 0; dcl tc_data$tefirst fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$tefirst), "tefirst", "", TP_MICROSECONDS); call range (500, ONE_MINUTE, "between 500 us. and one minute"); goto RETURN; dcl tc_data$telast fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$telast), "telast", "", TP_MICROSECONDS); call range (500, ONE_MINUTE, "between 500 us. and one minute"); if function = SET then if ^tc_data$gv_integration_set then tc_data$gv_integration = 4 * new_binary_value; goto RETURN; dcl tc_data$timax fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$timax), "timax", "", TP_MICROSECONDS); call range (500, ONE_MINUTE, "between 500 us. and one minute"); goto RETURN; dcl tc_data$priority_sched_inc fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$priority_sched_inc), "priority_sched_inc", "psi", TP_MICROSECONDS); call range (100000, FIVE_HOURS, "between 100 ms. and five hours"); goto RETURN; dcl tc_data$ncpu fixed bin (35) external static; dcl tc_data$max_max_eligible fixed bin (35) external static; dcl tc_data$min_eligible fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$min_eligible), "min_eligible", "mine", TP_SCALED_INTEGER); call need_integer (); call range ((tc_data$ncpu * SCALE), (tc_data$max_eligible), "at least as large as the number of cpus"); call range (0, (tc_data$max_eligible), "not greater than max_eligible"); goto RETURN; /* up to the maximum allowed */ dcl tc_data$max_eligible fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$max_eligible), "max_eligible", "maxe", TP_SCALED_INTEGER); call need_integer (); call range ((tc_data$min_eligible), (tc_data$max_max_eligible), "between min_eligible and max_max_eligible"); goto RETURN; /* up to the maximum allowed */ dcl tc_data$max_batch_elig fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$max_batch_elig), "max_batch_elig", "maxabs", TP_INTEGER); call range (0, (tc_data$max_eligible), "between 0 and max_eligible"); goto RETURN; dcl tc_data$working_set_factor fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$working_set_factor), "working_set_factor", "wsf", TP_SCALED_INTEGER); call range (0, (2 * SCALE), "between 0 and 2"); goto RETURN; dcl tc_data$working_set_addend fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$working_set_addend), "working_set_addend", "wsa", TP_INTEGER); call range (-1000, 1000, "between -1000 and 1000"); goto RETURN; dcl tc_data$deadline_mode fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$deadline_mode), "deadline_mode", "dmode", TP_ON_OFF); call on_or_off (); /* only two possible values */ goto RETURN; dcl tc_data$int_q_enabled fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$int_q_enabled), "int_q_enabled", "intq", TP_ON_OFF); call on_or_off (); /* only two possible values */ goto RETURN; dcl tc_data$post_purge_switch fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$post_purge_switch), "post_purge", "pp", TP_ON_OFF); call on_or_off (); /* only two possible values */ goto RETURN; dcl tc_data$pre_empt_sample_time fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$pre_empt_sample_time), "pre_empt_sample_time", "pest", TP_MICROSECONDS); call range (500, ONE_SECOND, "between 500 us. and one second"); goto RETURN; dcl tc_data$gp_at_notify fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$gp_at_notify), "gp_at_notify", "gpn", TP_ON_OFF); call on_or_off (); /* only two possible values */ goto RETURN; dcl tc_data$gp_at_ptlnotify fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$gp_at_ptlnotify), "gp_at_ptlnotify", "gpp", TP_ON_OFF); call on_or_off (); /* only two possible values */ goto RETURN; dcl tc_data$process_initial_quantum fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$process_initial_quantum), "process_initial_quantum", "piq", TP_MICROSECONDS); call range (100000, (30 * ONE_SECOND), "between 100 ms. and 30 seconds"); goto RETURN; dcl tc_data$quit_priority fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$quit_priority), "quit_priority", "qp", TP_SCALED_INTEGER); call range (0, (2 * SCALE), "between zero and two"); goto RETURN; dcl tc_data$nto_delta fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$nto_delta), "notify_timeout_interval", "nto_delta", TP_MICROSECONDS); call range (ONE_SECOND, TEN_MINUTES, "between one second and ten minutes"); goto RETURN; dcl tc_data$time_out_severity fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$time_out_severity), "notify_timeout_severity", "nto_severity", TP_INTEGER); call range (-1, 5, "any of -1, 0, 1, 3, 4, or 5"); /* Disallow 2 */ if new_binary_value = 2 then call abort ("any of -1, 0, 1, 3, 4, or 5"); goto RETURN; dcl sst$nused fixed bin (35) external static; dcl sst$write_limit fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (sst$write_limit), "write_limit", "wlim", TP_INTEGER); call range (30, divide (sst$nused, 2, 35, 0), "between 30 pages and half of memory"); goto RETURN; %set NUM to NUM + 1; declare tc_data$stk_truncate bit (1) ext static; TP (NUM): call tp_init (addr (tc_data$stk_truncate), "stack_truncation", "stkt", TP_ON_OFF); tp_special = "1"b; call on_or_off (); goto RETURN; declare tc_data$stk_truncate_always bit (1) aligned ext; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$stk_truncate_always), "stack_truncation_always", "stta", TP_ON_OFF); tp_special = "1"b; call on_or_off; goto RETURN; %set NUM to NUM + 1; declare tc_data$stk_trunc_avg_f1 aligned fixed bin (35, 18) ext static; declare tc_data$stk_trunc_avg_f2 aligned fixed bin (35, 18) ext static; TP (NUM): call tp_init (addr (tc_data$stk_trunc_avg_f1), "stk_trunc_block_avg_factor", "stk_baf", TP_SCALED_INTEGER); tp_special = "1"b; call scaled_range (0b, 1b, "between zero and one."); if function = SET then tc_data$stk_trunc_avg_f2 = 1b - tc_data$stk_trunc_avg_f1; goto RETURN; %set NUM to NUM + 1; declare wired_hardcore_data$trap_invalid_masked bit (1) aligned ext static; TP (NUM): call tp_init (addr (wired_hardcore_data$trap_invalid_masked), "trap_invalid_masked", "", TP_ON_OFF); tp_special = "1"b; call on_or_off (); goto RETURN; %set NUM to NUM + 1; declare tc_data$gv_integration fixed bin (35) external static; declare tc_data$gv_integration_set bit (1) aligned external static; TP (NUM): call tp_init (addr (tc_data$gv_integration), "gv_integration", "", TP_MICROSECONDS); call range ((tc_data$telast), FIVE_HOURS, "between telast and 5 hours"); if function = SET then tc_data$gv_integration_set = "1"b; goto RETURN; dcl sst$meter_ast_locking fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (sst$meter_ast_locking), "meter_ast_locking", "", TP_ON_OFF); tp_special = "1"b; call on_or_off (); goto RETURN; dcl tc_data$realtime_io_priority_switch fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$realtime_io_priority_switch), "realtime_io_priority", "io_prior", TP_ON_OFF); call on_or_off (); goto RETURN; dcl tc_data$realtime_io_deadline fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$realtime_io_deadline), "realtime_io_deadline", "io_deadline", TP_MICROSECONDS); call range (500, ONE_MINUTE, "between 500 us. and one minute"); goto RETURN; dcl tc_data$realtime_io_quantum fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (tc_data$realtime_io_quantum), "realtime_io_quantum", "io_quantum", TP_MICROSECONDS); call range (500, ONE_MINUTE, "between 500 us. and one minute"); goto RETURN; dcl sst$checksum_filemap fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (sst$checksum_filemap), "checksum_filemap", "", TP_ON_OFF); tp_special = "1"b; call on_or_off (); goto RETURN; dcl sys_info$default_256K_enable bit (1) aligned ext static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (sys_info$default_256K_enable), "default_256K_enable", "", TP_ON_OFF); tp_special = "1"b; call on_or_off (); go to RETURN; dcl sst$dirlock_writebehind fixed bin (35) external static; %set NUM to NUM + 1; TP (NUM): call tp_init (addr (sst$dirlock_writebehind), "dirlock_writebehind", "dirw", TP_ON_OFF); call on_or_off (); goto RETURN; %page; %include tuning_parameter_info; %page; %include syserr_constants; end hc_tune;  history_reg_save.pl1 11/11/89 1136.0r w 11/11/89 0800.9 20772 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ history_reg_save: proc; /* history_reg_save - hardcore primitives for turning on or off the ability to save history regs, either per process (with the per_proc entry) or per-system (with the per_system entry). Written 9/16/80 by J. A. Bush for the DPS8/70M CPU */ dcl (pp_state, ps_state) bit (1) aligned; /* entry parameters */ dcl pds$save_history_regs bit (1) aligned ext; dcl wired_hardcore_data$global_hregs bit (1) aligned ext; /* entry to return the state of a process's ability to save history regs, called from hcs_$history_regs_get */ per_proc_get: entry (pp_state); /* per-process get entry */ pp_state = pds$save_history_regs; /* return switch state */ return; /* thats it, return to caller */ /* entry to save a process's history regs, called from hcs_$history_regs_set */ per_proc_set: entry (pp_state); /* per-process set entry */ pds$save_history_regs = pp_state; /* set the desired switch state */ return; /* thats it, return to caller */ /* entry to return the state of the systems ability to save history regs, called from hphcs_$history_regs_get */ per_system_get: entry (ps_state); /* per-system get entry */ ps_state = wired_hardcore_data$global_hregs; /* return switch state */ return; /* thats it, return to caller */ /* entry to save everybodies history regs_set called from hphcs_$history_regs_set */ per_system_set: entry (ps_state); /* per-system set entry */ wired_hardcore_data$global_hregs = ps_state; /* set the desired switch state */ return; /* thats it, return to caller */ end history_reg_save;  set_procs_required.pl1 11/11/89 1136.0rew 11/11/89 0800.9 132615 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1986 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /****^ HISTORY COMMENTS: 1) change(81-09-01,Bongiovanni), approve(), audit(), install(): Written by J. Bongiovanni. 2) change(83-08-01,Bongiovanni), approve(), audit(), install(): Modified to initialize variables in given_processid. 3) change(86-06-02,Lippard), approve(87-02-09,MCR7616), audit(87-06-03,Farley), install(87-08-06,MR12.1-1063): Modified to fix coding error which sometimes allowed sprq'ing an offline cpu. 4) change(87-01-12,Lippard), approve(87-02-09,MCR7616), audit(87-06-03,Farley), install(87-08-06,MR12.1-1063): Modified to check ACS before allowing sprq. Removed the obsolete single_cpu entry point and associated code. 5) change(87-08-07,Lippard), approve(87-02-09,PBF7616), audit(87-08-11,Farley), install(87-08-18,MR12.1-1090): Added entry points get_procs_required and get_system_procs_required. 6) change(87-08-27,Lippard), approve(87-02-09,PBF7616), audit(87-08-28,Farley), install(87-09-01,MR12.1-1095): Always allow Initializer access. END HISTORY COMMENTS */ /* format: style3 */ set_procs_required: proc (a_procs_required, a_code); /* Ring-0 routine to allow suitably a privileged process to set per-process or system default CPUs required. Access is controlled by gates to this procedure. Although this routine locks the Global APT Lock, it is normally unwired, as it is called infrequently. Entries: set_procs_required - sets per-process CPUs required given_processid - sets per-process CPUs required for another process system_default - sets the system default group of CPUs required (this default applies to processes which have not requested specific CPUs) get_procs_required - gets per-process CPUs required get_system_procs_required - gets system default group of CPUs required */ /* Parameter */ dcl a_code fixed bin (35) parameter; /* standard error code */ dcl a_default_flag bit (1) aligned parameter; /* on if set of CPUs is default */ dcl a_processid bit (36) aligned parameter; /* target processid */ dcl a_procs_required bit (8) aligned parameter; /* mask of CPUs required */ /* Automatic */ dcl apteap ptr; /* pointer to APTE array */ dcl aptex fixed bin; /* index into APTE array */ dcl bad_processid bit (1); /* ON => invalid target processid */ dcl code fixed bin (35); /* error code (standard or otherwise) */ dcl cpu_num fixed bin; /* CPU number (0-7) */ dcl 1 event_flags like audit_event_flags; /* audit flags for access_audit_ */ dcl is_default bit (1); /* ON => setting to system default */ dcl local_apte_ptr ptr; /* pointer to user's APT entry */ dcl mode bit (36) aligned; /* ACS access mode */ dcl n_aptes fixed bin; /* number of APTEs */ dcl no_cpus_online bit (1); /* ON => requested set of CPUs had none online */ dcl old_procs_required bit (8) aligned; /* previous value of system default */ dcl old_procs_required_tags char (8); /* CPU tags of previous system default */ dcl processid bit (36) aligned; /* target processid */ dcl procs_required bit (8) aligned; /* mask of CPUs required */ dcl procs_required_tags char (8); /* CPU tags of new system default */ dcl ptwp ptr; /* saved pointer to stack page table for pmut */ dcl saved_mask fixed bin (71); /* saved interrupt mask for pmut */ /* Static */ dcl CPUS char (8) init ("ABCDEFGH") int static options (constant); dcl INITIALIZER char (23) init ("Initializer.SysDaemon.z") int static options (constant); dcl MAX_CPU_TAG fixed bin init (7) int static options (constant); dcl SPRQ_ACS_DIR char (14) init (">sc1>admin_acs") int static options (constant); dcl SPRQ_ACS_SEG char (21) init ("set_proc_required.acs") int static options (constant); /* Based */ dcl 1 aptea (n_aptes) aligned based (apteap) like apte; dcl 1 local_apte aligned based (local_apte_ptr) like apte; /* Entry */ dcl access_audit_$log_general entry options (variable); dcl level$get entry returns (fixed bin); dcl pmut$wire_and_mask entry (fixed bin (71), ptr); dcl pmut$unwire_unmask entry (fixed bin (71), ptr); dcl pxss$lock_apt entry; dcl pxss$lock_apte entry (bit (36) aligned, ptr, fixed bin (35)); dcl pxss$set_procs_required entry (bit (8) aligned, fixed bin (35)); dcl pxss$unlock_apt entry; dcl pxss$unlock_apte entry (ptr); dcl status_$get_user_raw_mode entry (char (*), char (*), char (*), bit (36) aligned, fixed bin (35)); dcl syserr entry options (variable); dcl syserr$error_code entry options (variable); dcl wire_proc$wire_me entry; dcl wire_proc$unwire_me entry; /* External */ dcl access_operations_$get_procs_required bit (36) aligned external; dcl access_operations_$set_procs_required bit (36) aligned external; dcl error_table_$bad_arg fixed bin (35) external; dcl error_table_$insufficient_access fixed bin (35) ext static; dcl error_table_$no_cpus_online fixed bin (35) external; dcl error_table_$process_unknown fixed bin (35) external; dcl pds$apt_ptr ptr external; dcl pds$process_group_id char (32) aligned external; dcl scs$processor bit (8) aligned external; dcl tc_data$apt bit (36) aligned external; dcl tc_data$apt_size fixed bin external; dcl tc_data$default_procs_required bit (8) aligned external; /* Builtin */ dcl addr builtin; dcl null builtin; dcl rtrim builtin; dcl string builtin; dcl substr builtin; %page; /* SET_PROCS_REQUIRED - set CPUs required for this process takes a bit mask specifying CPUs required ("0"b means current system default) return code = 0 - this process running on some CPU in the group error_table_$no_cpus_online - the set requested had no CPUs online */ procs_required = a_procs_required; /* copy to stack which will be wired */ if ^CHECK_ACCESS (access_operations_$set_procs_required) then do; a_code = error_table_$insufficient_access; return; end; call SET_MY_PROCS_REQUIRED (procs_required, code); a_code = code; return; %page; /* GIVEN_PROCESSID - sets per-process CPUs required for another process takes a bit mask specifying CPUs required ("0"b means current system default) and a processid. return code = 0 - proc_required mask set for target process (will take effect on next trip thru getwork) error_table_$no_cpus_online - the set requested had no CPUs online error_table_$process_unknown - the target processid is invalid */ given_processid: entry (a_procs_required, a_processid, a_code); procs_required = a_procs_required; /* copy arguments to stack to be wired */ processid = a_processid; call WIRE_LOCK_APT; /* ---------- WIRED, MASKED, GLOBAL APT LOCK HELD ---------- */ if procs_required = "0"b then do; /* system default */ is_default = "1"b; procs_required = tc_data$default_procs_required; end; else is_default = "0"b; bad_processid = "0"b; /* Steve Harris says this is useful */ if (scs$processor & procs_required) = "0"b then no_cpus_online = "1"b; /* No online CPUs in requested set */ else do; no_cpus_online = "0"b; /* Steve was correct */ call pxss$lock_apte (processid, aptep, code); /* Check processid, lock APTE, set aptep */ if code ^= 0 then bad_processid = "1"b; /* Could not lock - processid not found */ else if apte.flags.idle /* Don't allow idle process to change */ then do; bad_processid = "1"b; call pxss$unlock_apte (aptep); end; else do; apte.procs_required = procs_required; apte.flags.default_procs_required = is_default; call pxss$unlock_apte (aptep);/* Unlock APTE */ end; end; call UNLOCK_APT_UNWIRE; /* ---------- UNMASKED, UNWIRED, NO LOCKS HELD ---------- */ if no_cpus_online then a_code = error_table_$no_cpus_online; else if bad_processid then a_code = error_table_$process_unknown; else a_code = 0; return; %page; /* SYSTEM_DEFAULT - sets the system default group of CPUs required takes a bit mask specifying the CPUs required walks the APTE array and changes procs_required for all processes with current default to new default return code = 0 - default set as requested error_table_$no_cpus_online - the set requested had no CPUs online error_table_$bad_arg - a mask of "0"b was specified (no CPUs) */ system_default: entry (a_procs_required, a_code); procs_required = a_procs_required; /* copy to stack to be wired */ if procs_required = "0"b then do; /* no CPUs in set */ a_code = error_table_$bad_arg; return; end; no_cpus_online = "0"b; call WIRE_LOCK_APT; /* ---------- WIRED, MASKED, GLOBAL APT LOCK HELD ---------- */ if (scs$processor & procs_required) = "0"b then no_cpus_online = "1"b; /* No online CPUs in set requested */ else do; old_procs_required = tc_data$default_procs_required; tc_data$default_procs_required = procs_required; apteap = addr (tc_data$apt); n_aptes = tc_data$apt_size; do aptex = 1 to n_aptes; if aptea (aptex).flags.default_procs_required /* This process has system default */ then aptea (aptex).procs_required = procs_required; end; end; call UNLOCK_APT_UNWIRE; /* ---------- UNMASKED, UNWIRED, NO LOCKS HELD ---------- */ if no_cpus_online then a_code = error_table_$no_cpus_online; else do; a_code = 0; procs_required_tags, old_procs_required_tags = ""; /* Build syserr message */ do cpu_num = 0 to MAX_CPU_TAG; if substr (procs_required, cpu_num + 1, 1) = "1"b then procs_required_tags = rtrim (procs_required_tags) || substr (CPUS, cpu_num + 1, 1); if substr (old_procs_required, cpu_num + 1, 1) = "1"b then old_procs_required_tags = rtrim (old_procs_required_tags) || substr (CPUS, cpu_num + 1, 1); end; call syserr (SYSERR_PRINT_ON_CONSOLE, "set_procs_required: Changing system default CPUs required from ^a to ^a for ^a", old_procs_required_tags, procs_required_tags, pds$process_group_id); end; return; %page; /* GET_PROCS_REQUIRED - gets the per-process CPUs required returns a bit mask specifying CPUs required, a bit indicating whether the CPUs required is the default, and an error code. */ get_procs_required: entry (a_procs_required, a_default_flag, a_code); if ^CHECK_ACCESS (access_operations_$get_procs_required) then do; a_code = error_table_$insufficient_access; return; end; local_apte_ptr = pds$apt_ptr; a_procs_required = local_apte.procs_required; a_default_flag = local_apte.flags.default_procs_required; a_code = 0; return; %page; /* GET_SYSTEM_PROCS_REQUIRED - gets system default group of CPUs required returns a bit mask specifying CPUs required by the system */ get_system_procs_required: entry (a_procs_required); a_procs_required = tc_data$default_procs_required; return; %page; /* Internal Procedure to check ACS segment for access */ CHECK_ACCESS: proc (a_access_op) returns (bit (1) aligned); dcl a_access_op bit (36) aligned parm; dcl access_op bit (36) aligned; dcl have_access bit (1) aligned; dcl return_code fixed bin (35); access_op = a_access_op; have_access = "0"b; return_code = 0; if pds$process_group_id = INITIALIZER then return ("1"b); call status_$get_user_raw_mode (SPRQ_ACS_DIR, SPRQ_ACS_SEG, "", mode, code); if code ^= 0 then do; call syserr$error_code (SYSERR_LOG_OR_PRINT, code, "set_procs_required: Failed to check access for ^a.", pds$process_group_id); return ("0"b); end; if (mode & RW_ACCESS) = RW_ACCESS then have_access = "1"b; else return_code = error_table_$insufficient_access; string (event_flags) = ""b; event_flags.priv_op = "1"b; event_flags.grant = have_access; call access_audit_$log_general ("set_procs_required", level$get (), string (event_flags), access_op, "", return_code, null (), 0); return (have_access); end CHECK_ACCESS; %page; /* Internal Procedure to set the CPUs required for this process */ SET_MY_PROCS_REQUIRED: proc (procs, code); dcl procs bit (8) aligned; /* Mask for CPUs required */ dcl code fixed bin (35); /* Standard error code */ dcl pxss_code fixed bin (35); /* Non-standard error code from pxss */ call pxss$set_procs_required (procs, pxss_code); if pxss_code = 0 then code = 0; else code = error_table_$no_cpus_online; return; end SET_MY_PROCS_REQUIRED; %page; /* Internal Procedure to wire this procedure (text and linkage), wire stack, mask to system level, and lock the Global APT Lock */ WIRE_LOCK_APT: proc; call wire_proc$wire_me; call pmut$wire_and_mask (saved_mask, ptwp); call pxss$lock_apt; end WIRE_LOCK_APT; /* Internal Procedure to Unlock Global APT Lock, Reset mask to previous, Unwire Stack, Unwire text and linkage */ UNLOCK_APT_UNWIRE: proc; call pxss$unlock_apt; call pmut$unwire_unmask (saved_mask, ptwp); call wire_proc$unwire_me; end UNLOCK_APT_UNWIRE; %page; %include access_audit_eventflags; %include access_mode_values; %include apte; %include syserr_constants; %page; /* BEGIN MESSAGE DOCUMENTATION Message: set_procs_required: Changing system default CPUs required from XXXX to YYYY for PERSON.PROJECT.TAG S: $info T: $run M: The default set of CPUs has been changed from XXXX (CPU tags) to YYYY (CPU tags) by PERSON.PROJECT.TAG. These are the only CPUs on which processes will run which have not requested to be run on specific CPUs. A: $ignore Message: set_procs_required: Failed to check access for USER. S: $log T: $run M: Access on >sc1>admin_acs>set_proc_required.acs could not be checked. A: Verify that the ACS seg exists. END MESSAGE DOCUMENTATION */ end set_procs_required;  tc.pl1 11/11/89 1136.0r w 11/11/89 0801.0 89964 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ tc: proc; /* This program includes those scheduler functions which are used infrequently enough that the code is appropriately written in pl1 and not permanently wired-down */ /* Coded May 1975 by RE Mullen for priority scheduler */ /* tune_work_class entry added RE Mullen for deadline scheduler */ /* Modified 29 October by M. Pierret for pin_weight and io_priority */ /* Modified June 1981 by J. Bongiovanni for governed work classes */ /* Modified May 1982 by J. Bongiovanni for interactive_q */ /* Modified November 1984 by M. Pandolf to include hc_lock. */ % include tcm; % include hc_lock; % include apte; dcl 1 wci aligned like work_class_info; % include work_class_info; dcl (i, max_wc, wct_base) fixed bin; dcl hundth_of_credits fixed bin; dcl hundth_of_scatter fixed bin; dcl (apte_count, sum, wcnum, size_of_wct_entry) fixed bin (35); dcl ptwp ptr; dcl oldmask fixed bin (71); dcl code fixed bin (35); dcl tc_data$ external; dcl ( error_table_$action_not_performed, error_table_$obsolete_function, error_table_$bad_work_class, error_table_$bad_arg) external static fixed bin (35); dcl clock_ entry returns (fixed bin (71)); dcl (pxss$lock_apt, pxss$unlock_apt) entry (); /* only way to touch apt lock */ dcl pmut$wire_and_mask entry (fixed bin (71), ptr); dcl pmut$unwire_unmask entry (fixed bin (71), ptr); dcl wire_proc$wire_me entry (); dcl wire_proc$unwire_me entry (); dcl (addr, addrel, bin, divide, fixed, rel, size) builtin; /* END DCLS */ /* */ tune_work_class: entry (a_wctup, a_code); dcl a_wctup ptr; dcl wctup ptr; dcl 1 wctu_info aligned like work_class_tune_info; wctup = a_wctup; code = 0; tcmp = addr (tc_data$); wctu_info = wctup -> work_class_tune_info; if wctu_info.version < WCTI_version_3 then do; code = error_table_$obsolete_function; go to TWC_RETURN; end; i = wctu_info.wc_number; if (i<0) | (i>16) then do; code = error_table_$bad_work_class; go to TWC_RETURN; end; if ^tcm.wcte (i).defined then do; code = error_table_$bad_work_class; go to TWC_RETURN; end; if wctu_info.set.governed then if wctu_info.max_percent < 0 | wctu_info.max_percent > 100 then do; code = error_table_$bad_arg; goto TWC_RETURN; end; /* Now set the new parameters for this work_class. */ call WIRE_LOCK; /* TRAFFIC CONTROLLER LOCKED */ if wctu_info.set.resp1 then tcm.wcte (i).resp1 = wctu_info.resp1; if wctu_info.set.resp2 then tcm.wcte (i).resp2 = wctu_info.resp2; if wctu_info.set.quantum1 then tcm.wcte (i).quantum1 = wctu_info.quantum1; if wctu_info.set.quantum2 then tcm.wcte (i).quantum2 = wctu_info.quantum2; if wctu_info.set.purging then if wctu_info.flags.purging then tcm.wcte (i).purging = 1; else tcm.wcte (i).purging = 0; if wctu_info.set.realtime then if wctu_info.flags.realtime then tcm.wcte (i).realtime = 1; else tcm.wcte (i).realtime = 0; if wctu_info.set.maxel then tcm.wcte (i).maxel = wctu_info.maxel; if wctu_info.set.pin_weight then tcm.wcte (i).pin_weight = wctu_info.pin_weight; if wctu_info.set.io_priority then tcm.wcte (i).io_priority = wctu_info.flags.io_priority; if wctu_info.set.governed then do; if wctu_info.max_percent = 0 then tcm.wcte (i).flags.governed = "0"b; else do; hundth_of_scatter = divide (tcm.credits_per_scatter, 100, 17); tcm.wcte (i).maxf = hundth_of_scatter * wctu_info.max_percent; tcm.wcte (i).governing_credits = 0; tcm.wcte (i).flags.governed = "1"b; end; if ^wctu_info.set.interactive_q /* Use default */ then tcm.wcte (i).flags.interactive_q = ^tcm.wcte (i).flags.governed; end; if wctu_info.set.interactive_q then tcm.wcte (i).flags.interactive_q = wctu_info.flags.interactive_q; call UNLOCK_UNWIRE; /* TRAFFIC CONTROLLER LOCKED */ TWC_RETURN: a_code = code; return; define_work_classes: entry (a_wcip, a_code); dcl a_wcip ptr; dcl a_code fixed bin (35); /* First copy args */ wcip = a_wcip; wci = work_class_info; wci.error_process_id = ""b; wci.error_work_class = 0; code = 0; /* If setting user workclasses then compute sum and max_wc */ /* In any case validate arguments */ if wci.set_user_wc then do; sum = 0; /* Compute the sum of the "percents" */ max_wc = 0; /* Assume only zeroth exists */ do i = 1 to 16; if wci.user_wc_defined (i) then do; if wci.user_wc_min_pct (i) <= 0 | (wci.governed (i) & (wci.user_wc_max_pct (i) <= 0 | wci.user_wc_max_pct (i) > 100)) then do; code = error_table_$bad_arg; go to DWC_RETURN; end; sum = sum + wci.user_wc_min_pct (i); max_wc = i; end; end; end; if wci.set_system_wc then do; if wci.system_wc_min_pct <= 0 then do; code = error_table_$bad_arg; go to DWC_RETURN; end; end; call WIRE_LOCK; /* TRAFFIC CONTROLLER LOCKED */ /* Verify that existing processes will belong to defined work classes */ aptep = addr (tcm.apt); apte_count = tcm.apt_size; size_of_wct_entry = size (wct_entry); wct_base = fixed (rel (addr (tcm.wcte (0))), 18); if wci.set_user_wc then do; do i = 1 to apte_count; if ^ apte.flags.idle then /* Idle processes are not in wc's */ if bin (apte.flags.state, 18) ^= 0 then /* Dont worry about empties */ if bin (apte.flags.state, 18) ^= 5 then do; /* Dont worry about stopped */ wcnum = divide (fixed (apte.wct_index, 18) - wct_base, size_of_wct_entry, 17, 0); if wcnum > 0 then do; if ^ wci.user_wc_defined (wcnum) then do; wci.error_process_id = apte.processid; wci.error_work_class = wcnum; go to DWC_UU_RETURN; end; end; end; aptep = addrel (aptep, tcm.apt_entry_size); /* Move to next APTE */ end; tcm.max_wct_index = rel (addr (tcm.wcte (max_wc))); if sum ^= 0 then /* Scheduler algorithm requires normalization to 100% */ hundth_of_credits = divide (tcm.credits_per_scatter, sum, 17, 0); else hundth_of_credits = 0; /* no user_work_classes defined */ hundth_of_scatter = divide (tcm.credits_per_scatter, 100, 17, 0); /* Set per-work_class parameters as specified */ do i = 1 to 16; if wci.user_wc_defined (i) then do; tcm.wcte (i).flags.defined = "1"b; tcm.wcte (i).minf = fixed (wci.user_wc_min_pct (i), 7) * hundth_of_credits; /* Set credits to a modest amount. */ tcm.wcte (i).credits = tcm.wcte (i).minf + tcm.telast; end; else do; tcm.wcte (i).flags.defined = "0"b; tcm.wcte (i).credits, tcm.wcte (i).minf = 0; end; tcm.wcte (i).purging = 1; tcm.wcte (i).maxel = 0; if wci.version >= 2 & wci.user_wc_defined (i) then do; if wci.realtime (i) then tcm.wcte.realtime (i) = 1; else tcm.wcte (i).realtime = 0; tcm.wcte (i).resp1 = wci.resp1 (i); tcm.wcte (i).quantum1 = wci.quantum1 (i); tcm.wcte (i).resp2 = wci.resp2 (i); tcm.wcte (i).quantum2 = wci.quantum2 (i); end; else do; /* set default parms for this wc */ tcm.wcte (i).resp1 = 4000000; /* 4sec */ tcm.wcte (i).quantum1 = 500000; /* half sec */ tcm.wcte (i).resp2 = 32000000; /* 32 sec */ tcm.wcte (i).quantum2 = 1000000; /* one sec */ tcm.wcte (i).realtime = 0; end; if wci.version >= 3 & wci.user_wc_defined (i) & wci.governed (i) then do; tcm.wcte (i).flags.governed = "1"b; tcm.wcte (i).maxf = hundth_of_scatter * wci.user_wc_max_pct (i); end; else tcm.wcte (i).flags.governed = "0"b; tcm.wcte (i).flags.interactive_q = ^tcm.wcte (i).flags.governed; tcm.wcte (i).governing_credits = 0; end; end; /* Set global parameters if requested. */ if wci.set_sked_mode then tcm.deadline_mode = bin (wci.deadline_mode, 1); if wci.set_max_batch_elig then tcm.max_batch_elig = wci.max_batch_elig; if wci.set_system_wc then do; tcm.wcte (0).minf = fixed (wci.system_wc_min_pct, 7) * divide (tcm.credits_per_scatter, 100, 17, 0); tcm.wcte (0).credits = tcm.wcte (0).minf + tcm.telast; end; /* Re-initialize metering data */ if wci.set_user_wc | wci.set_system_wc then do; do i = 0 to 16; tcm.wcte (i).cpu_sum, tcm.wcte (i).eligibilities = 0; end; tcm.define_wc_time = clock_ (); tcm.processor_time_at_define_wc = tcm.processor_time; end; DWC_UU_RETURN: call UNLOCK_UNWIRE; /* TRAFFIC CONTROLLER UNLOCKED */ DWC_RETURN: work_class_info = wci; if code = 0 then if (wci.error_work_class ^= 0) | (wci.error_process_id ^= ""b) then code = error_table_$action_not_performed; a_code = code; return; /* */ /* -------------------------------------------------------------------- */ WIRE_LOCK: proc; call wire_proc$wire_me (); call pmut$wire_and_mask (oldmask, ptwp); tcmp = addr (tc_data$); call pxss$lock_apt (); /* TRAFFIC CONTROLLER LOCKED HERE */ end WIRE_LOCK; /* -------------------------------------------------------------------- */ UNLOCK_UNWIRE: proc; call pxss$unlock_apt (); /* TRAFFIC CONTROLLER UNLOCKED HERE */ call pmut$unwire_unmask (oldmask, ptwp); call wire_proc$unwire_me (); end UNLOCK_UNWIRE; end tc;  tc_util.pl1 11/11/89 1136.0rew 11/11/89 0801.0 138501 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3 */ tc_util: proc; /* DESCRIPTION: Various traffic control utility functions which used to live in pxss. They need to run wired and masked, with various traffic control locks, but are called infrequently. Entries: check_abort - returns non-zero code if a quit or trm_ IPS signal, or a stop is pending for the process. Can be used by long-running ring-0 procedures to simulate quits. get_aptep - validates a processid and returns the apte pointer. get_ipc_operands - returns to the caller the values of apte.ipc_r_offset and apte.ipc_r_factor. These are used by user-ring (and hardcore) IPC event channel validation and decoding. It is the target of hcs_$get_ipc_operands. get_ipc_operands_priv - returns to the caller the values of apte.ipc_r_offset and apte.ipc_r_factor for a specified process. This is a highly privileged entrypoint and intended only to be used by hardcore IPC (hc_ipc) and the Initializer process (dialup_). It is the target of the gate hphcs_$get_ipc_operands_priv. ips_wakeup - send a given named IPS signal to a given process. process_status - return information about a process. resume_tc - unfreeze traffic control scheduling (see suspend_tc described below). set_cpu_monitor - establishes a wakeup call to the term processid after a given amount of virtual CPU time has been used by a specified process. set_timax - sets timax for a process suspend_tc - freeze traffic control's running of processes, with the exception of all idles and the calling process. validate_processid - determines whether a processid coresponds to an active process. Moved from pxss and converted to PL1 by J. Bongiovanni, September 1981 Modified June 1982, J. Bongiovanni, to add validate_processid Modified September 1982, J. Bongiovanni, to add check_abort Modififed February 1983, E. N. Kittlitz, to clear cpu timer if arg < 0. Modified 831111 for validate_processid_all entry -E. A. Ranzenbach Modified 831213, E. N. Kittlitz, to remove validate_processid_all and several intermediate changes. Modified: 07/15/84 by R. Michael Tague: Added ips_wakeup. Modified October 1984 by M. Pandolf to add suspend_tc and resume_tc Modified 1984-11-11 by E. Swenson for IPC event channel validation support of hcs_$get_ipc_operands. Also added highly privileged entrypoint get_ipc_operands_priv which is used in ring-0 and as the garget of the gate hphcs_$get_ipc_operands_priv. */ /* Parameter */ dcl a_allow_special_procs bit (1) aligned; /* allow special processes in get_apte search */ dcl a_code fixed bin (35) parameter; /* standard error code */ dcl a_delta_vcpu fixed bin (71) parameter; /* increment to current VCPU for wakeup */ dcl a_info_ptr ptr; /* pointer to structure of process information */ dcl a_ips_signal_name char (*); /* name of the ips signal to be sent */ dcl a_processid bit (36) aligned parameter; /* target process ID */ dcl a_timax fixed bin (35) parameter; /* value to set timax to */ dcl P_ipc_r_offset fixed bin (18) parameter; /* IPC validation operand */ dcl P_ipc_r_factor fixed bin (35) parameter; /* IPC validation operand */ /* Automatic */ dcl arg_list_ptr ptr; /* argument list pointer for ips_wakeup */ dcl code fixed bin (35); /* return code */ dcl delta_vcpu fixed bin (71); /* copy of increment to VCPU */ dcl ipc_r_offset fixed bin (18); /* automatic copy for wiring */ dcl ipc_r_factor fixed bin (35); /* automatic copy for wiring */ dcl ips_mask_index fixed bin; /* do loop index */ dcl ips_signal_name char (32); /* copy of ips signal name */ dcl oldmask fixed bin (71); /* value of interrupt mask at wire_mask */ dcl process_mp_state fixed bin; /* loaded (ON=1) + eligible (ON=2) */ dcl process_state fixed bin; /* traffic control state */ dcl process_timax fixed bin (35); /* copy of value to set timax for process */ dcl processid bit (36) aligned; /* copy of process ID */ dcl ptwp ptr; /* pointer to page table for stack */ /* Based */ dcl 1 a_process_status aligned based (a_info_ptr) like process_status_return; dcl 1 my_arg_list aligned based (arg_list_ptr) like arg_list; /* Entry */ dcl cu_$arg_list_ptr entry (ptr); dcl lock$lock_fast entry (ptr); dcl lock$unlock_fast entry (ptr); dcl pmut$wire_and_mask entry (fixed bin (71), ptr); dcl pmut$unwire_unmask entry (fixed bin (71), ptr); dcl pxss$lock_apte entry (bit (36) aligned, ptr, fixed bin (35)); dcl pxss$ips_wakeup entry (bit (36) aligned, bit (36) aligned); dcl pxss$suspend_getwork entry (); dcl pxss$unlock_apte entry (ptr); dcl signal_ entry options (variable); dcl wire_proc$unwire_me entry; dcl wire_proc$wire_me entry; /* External */ dcl error_table_$quit_term_abort fixed bin (35) external; dcl error_table_$process_unknown fixed bin (35) external; dcl pds$apt_ptr ptr external; dcl tc_data$ external; dcl tc_data$abort_ips_mask bit (36) aligned external; dcl tc_data$apt bit (36) aligned external; dcl tc_data$apt_size fixed bin external; dcl tc_data$tc_suspend_lock bit (36) aligned external; dcl tc_data$timax fixed bin (35) external; /* Builtin */ dcl addr builtin; dcl bin builtin; dcl divide builtin; dcl mod builtin; dcl null builtin; dcl ptr builtin; dcl rel builtin; dcl size builtin; dcl unspec builtin; return; /* no tc_util entry */ /* END OF DECLARATIONS */ %page; /* CHECK_ABORT - checks for quit or term IPS signal pending, or stop pending. */ check_abort: entry (a_code); a_code = 0; aptep = pds$apt_ptr; if apte.flags.stop_pending | ((apte.ips_message & tc_data$abort_ips_mask) ^= ""b) then a_code = error_table_$quit_term_abort; return; %page; /* GET_APTEP - validates that a processid corresponds to an active process and returns the apte pointer. */ get_aptep: entry (a_processid, a_allow_special_procs) returns (ptr); aptep = PROCESSID_TO_APTE ((a_processid), (a_allow_special_procs)); return (aptep); %page; /* IPS_WAKEUP - Look up the given ips signal name in sys_info and send the corresponding ips signal bit string to pxss$ips_wakeup. */ ips_wakeup: entry (a_processid, a_ips_signal_name); /* For release MR11, this entry will check its calling arguments to see if the old calling sequence of (bit (36), char (4)) was used. If so a gate_error signal is raised. This should be taken out by the next release. */ call cu_$arg_list_ptr (arg_list_ptr); if my_arg_list.header.desc_count = 0 then call signal_ ("gate_err"); else do; processid = a_processid; ips_signal_name = a_ips_signal_name; do ips_mask_index = 1 to sys_info$ips_mask_data.count while (ips_signal_name ^= sys_info$ips_mask_data.mask (ips_mask_index).name); end; if ips_mask_index <= sys_info$ips_mask_data.count then call pxss$ips_wakeup (processid, sys_info$ips_mask_data.mask (ips_mask_index).mask); end; return; %page; /* PROCESS_STATUS - return information about a process. fills in info structure like process_status_return. If processid not found, aptptr in structure is null. */ process_status: entry (a_info_ptr); processid = a_process_status.target_proc; /* copy to stack to be wired */ a_process_status.up_exec = 0; a_process_status.up_mp = 0; a_process_status.aptptr = null (); process_mp_state = 1; aptep = PROCESSID_TO_APTE (processid, "0"b); if aptep ^= null () then do; process_state = bin (apte.state, 17); if apte.flags.loaded then process_mp_state = process_mp_state + 2; if apte.flags.eligible then process_mp_state = process_mp_state + 1; /* fill in structure */ a_process_status.total_page_faults = apte.page_faults; a_process_status.aptptr = aptep; a_process_status.up_exec = process_state; a_process_status.up_mp = process_mp_state; a_process_status.up_block = apte.state_change_time; /* mis-named */ a_process_status.up_cpu = apte.time_used_clock; a_process_status.up_page = apte.paging_measure; a_process_status.virtual_cpu = apte.virtual_cpu_time; a_process_status.extra2 = 0; end; return; %page; /* SET_CPU_MONITOR - establishes a wakeup call to the term processid after a given amount of virtual CPU time has been used by a specified process. return code = 0 - wakeup established = error_table_$process_unknown - no such process */ set_cpu_monitor: entry (a_processid, a_delta_vcpu, a_code); processid = a_processid; /* copy to stack to be wired */ delta_vcpu = a_delta_vcpu; call WIRE_MASK; /* ---------- WIRED AND MASKED ---------- */ call pxss$lock_apte (processid, aptep, code); /* try to lock target APTE */ if code = 0 then do; if delta_vcpu < 0 then apte.cpu_monitor = 0; else apte.cpu_monitor = divide (apte.virtual_cpu_time + delta_vcpu, 1024, 35); call pxss$unlock_apte (aptep); end; call UNWIRE_UNMASK; /* ---------- UNWIRED AND and UNMASKED ---------- */ if code ^= 0 then a_code = error_table_$process_unknown; else a_code = 0; return; %page; /* SET_TIMAX - sets timax for a process If the value is 0, it is reset to the system default */ set_timax: entry (a_processid, a_timax); processid = a_processid; /* copy to stack to be wired */ process_timax = a_timax; if process_timax <= 0 then process_timax = tc_data$timax; call WIRE_MASK; /* ---------- WIRED AND MASKED ---------- */ call pxss$lock_apte (processid, aptep, code); /* Try to lock target APTE */ if code = 0 then do; /* Process exists and is locked */ apte.timax = process_timax; call pxss$unlock_apte (aptep); end; call UNWIRE_UNMASK; /* ---------- UNWIRED AND UNMASKED ---------- */ return; %page; /* VALIDATE_PROCESSID - validates that a processid corresponds to an active process. return code = 0 - process exists = error_table_$process_unknown - no such process */ validate_processid: entry (a_processid, a_code); a_code = 0; aptep = PROCESSID_TO_APTE ((a_processid), "0"b); if aptep = null () then a_code = error_table_$process_unknown; return; %page; /* SUSPEND_TC - turn on the mechanism in getwork (of pxss fame) that suspends the running of processes, leaving only the idles and the caller available for running. this state occurs only when tc_data$tc_suspend_lock is locked. there are no parameters to this routine; its caller is guarenteed to be the only one running upon its return. */ suspend_tc: entry (); call lock$lock_fast (addr (tc_data$tc_suspend_lock)); /* get the lock, possibly */ /* entering the WAIT state */ call pxss$suspend_getwork (); /* connect all processors */ /* and loop until only we remain */ return; %page; /* RESUME_TC - disable the suspension mechanism in getwork. */ resume_tc: entry (); call lock$unlock_fast (addr (tc_data$tc_suspend_lock)); /* possibly wake others */ /* who want the suspend service */ return; %page; get_ipc_operands: entry (P_ipc_r_offset, P_ipc_r_factor); /**** This entry, target of hcs_$get_ipc_operands, allows a process to determine the operands used for IPC validation. It returns only the operands for the calling process. These values are retrieved from the apte by the user-ring IPC at Event Channel Table initialization time. */ aptep = pds$apt_ptr; P_ipc_r_offset = apte.ipc_r_offset; P_ipc_r_factor = apte.ipc_r_factor; return; %page; get_ipc_operands_priv: entry (a_processid, P_ipc_r_offset, P_ipc_r_factor, a_code); /**** This entry is a highly priviledged entry to determine the operands used for IPC validation for a specified process. It is used by ring-0 IPC (hc_ipc) and by the Initializer process through the gate hphcs_$get_ipc_operands_priv. */ processid = a_processid; call WIRE_MASK (); /***** WIRED AND MASKED *****/ call pxss$lock_apte (processid, aptep, code); if code = 0 then do; ipc_r_offset = apte.ipc_r_offset; /* copy to wired stack frame */ ipc_r_factor = apte.ipc_r_factor; /* copy to wired stack frame */ call pxss$unlock_apte (aptep); end; call UNWIRE_UNMASK (); /***** UNWIRED AND UNMASKED *****/ if code ^= 0 then a_code = error_table_$process_unknown; else do; P_ipc_r_offset = ipc_r_offset; P_ipc_r_factor = ipc_r_factor; a_code = 0; end; return; %page; /* Internal procedure to validate that a process ID corresponds to an active process. We're not concerned with races here, since they can happen anyway (between now and when the process ID is used). */ PROCESSID_TO_APTE: proc (processid, allow_special_procs) returns (ptr); dcl processid bit (36) aligned; dcl allow_special_procs bit (1) aligned; dcl apte_offset fixed bin (18); /* Offset of APTE in tc_data */ dcl first_apte_offset fixed bin (18); /* offset of first APTE in tc_data */ dcl 1 pid aligned, /* decomposition of process ID */ 2 offset bit (18) unaligned, /* offset of APTE */ 2 unique bit (18) unaligned; /* unique number assigned by AS */ dcl taptep ptr; dcl 1 tapte aligned like apte based (taptep); unspec (pid) = processid; apte_offset = bin (pid.offset, 18); taptep = ptr (addr (tc_data$), pid.offset); first_apte_offset = bin (rel (addr (tc_data$apt)), 18); if apte_offset < first_apte_offset then return (null ()); else if apte_offset >= first_apte_offset + tc_data$apt_size * size (apte) then return (null ()); else if mod ((apte_offset - first_apte_offset), size (apte)) ^= 0 then return (null ()); else if tapte.processid ^= processid then return (null ()); else if (^allow_special_procs & (tapte.flags.hproc | tapte.flags.idle)) then return (null ()); else return (taptep); end PROCESSID_TO_APTE; %page; /* Internal Procedure to wire this procedure (text and linkage), wire stack, and mask to system level */ WIRE_MASK: proc; call wire_proc$wire_me; call pmut$wire_and_mask (oldmask, ptwp); end WIRE_MASK; /* Internal Procedure to reset mask to previous, unwire stack, unwire text and linkage */ UNWIRE_UNMASK: proc; call pmut$unwire_unmask (oldmask, ptwp); call wire_proc$unwire_me; end UNWIRE_UNMASK; /* format: off */ %page; %include apte; %page; %include process_status_return; %page; %include ips_mask_data; %page; %include arg_list; /* format: on */ end tc_util;  trace_mc.pl1 11/11/89 1136.0r w 11/11/89 0801.0 57132 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ trace_mc: proc; return; /* should never enter here */ /* trace_mc - primitive to turn on/off the hardcore machine condition trace mechanism initially coded by James A. Bush March 1977 */ dcl (a_segptr, segptr) ptr; dcl (a_trace_sw, trace_sw) bit (1) aligned; dcl (a_code, code) fixed bin (35); dcl (p, a_bp) ptr; dcl dirname char (168); dcl (i, a_buf_size, buf_size) fixed bin; dcl ename char (32); dcl vl fixed bin (3); dcl based_segno fixed bin (35); dcl rba (3) fixed bin (3); /* ring bracket array */ dcl init_buf (0 : buf_size) bit (36) based (bp); dcl 1 bseg based (addr (based_segno)) aligned, 2 seg fixed bin unal, 2 pad1 fixed bin unal; dcl level$set entry (fixed bin (3)); dcl level$get entry returns (fixed bin (3)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl append$branch entry (char (*), char (*), fixed bin (5), fixed bin (35)); dcl initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (1), ptr, fixed bin (35)); dcl ringbr_$set entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl delentry$dseg entry (ptr, fixed bin (35)); dcl user_wire entry (ptr, bit (1) aligned, fixed bin (18), fixed bin (18), fixed bin (35)); dcl set$bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl pds$process_dir_name char (32) ext; dcl pds$mc_trace_buf ptr unaligned ext; /* Note packed pointer */ dcl pds$mc_trace_seg fixed bin (35) ext; dcl 1 pds$mc_trace_sw aligned ext, 2 hc_trace_sw bit (1) unaligned, 2 init_sw bit (1) unaligned; dcl error_table_$action_not_performed fixed bin (35) ext; dcl error_table_$buffer_big fixed bin (35) ext; dcl (addr, fixed, addrel, null, rel, ptr, divide) builtin; /* */ % include mc_trace_buf; % include its; /* */ /* trace_buffer_init - entry to create and init M. C. buff | delete M. C. trace buff, per state of a_trace_sw */ trace_buffer_init: entry (a_segptr, a_trace_sw, a_buf_size, a_bp, a_code); /* copy args */ segptr = a_segptr; trace_sw = a_trace_sw; a_bp = null; a_code = 0; vl = level$get (); /* Save current validation level. */ call level$set (0); /* Set hardcore ring validation level. */ if trace_sw then do; /* are we turning trace on? */ if a_buf_size <= 0 | a_buf_size > max_buf_size then do; /* user requested invalid buffer size */ code = error_table_$buffer_big; go to erret; end; ename = unique_chars_ ("0"b) || ".mct"; /* Create unique buffer segment name. */ call append$branch (pds$process_dir_name, ename, 01010b, code); if code ^= 0 then go to erret; /* Create the buffer segment. */ call initiate (pds$process_dir_name, ename, "", 0b, 1b, bp, code); if bp = null then go to erret; /* Initiate the segment. */ rba (1) = 0; /* set ring brackets to 0 N N */ rba (2), rba (3) = vl; call ringbr_$set (pds$process_dir_name, ename, rba, code); /* Change the ring brackets of the buf seg. */ if code ^= 0 then go to erret; buf_size = a_buf_size * 1024; /* set up buffer size */ call set$bc_seg (bp, buf_size * 36, code); /* set bit count */ if code ^= 0 then go to erret; /* initialize buffer */ do i = 0 to buf_size - 1; init_buf (i) = buf_init; /* set up constant in entire buffer */ end; /* initialize trace buffer header */ mc_trace_buf.hr_cnt = buf_size / ((8 * mc_size) + hr_size); /* 8:1 ratio mc's to hr's */ mc_trace_buf.mc_cnt = (mc_trace_buf.hr_cnt * 8) - 1; /* have to have room for header */ mc_trace_buf.hr_strt = fixed (rel (addr (mc_trace_buf.h_regs (1)))); /* figure out starting loc's */ mc_trace_buf.mc_strt = fixed (rel (addr (mc_trace_buf.mach_cond (1)))); mc_trace_buf.hr_lim = (mc_trace_buf.hr_cnt * hr_size) + hr_strt; mc_trace_buf.mc_lim = (mc_trace_buf.mc_cnt * mc_size) + mc_strt; mc_trace_buf.hr_nxtad = mc_trace_buf.hr_strt; mc_trace_buf.mc_nxtad = mc_trace_buf.mc_strt; /* wire trace buffer */ call user_wire (bp, "1"b, 0, -1, code); if code = 0 then do; /* set up trace buffer pointer, segno to trace and turn on trace switch in pds */ a_bp = bp; /* set buffer pointer for user */ p = addr (segptr); bseg.seg = fixed (p -> its.segno, 15); /* set up seg number in upper half of word */ bseg.pad1 = 0; /* set lower half of word to zero */ pds$mc_trace_buf = bp; pds$mc_trace_seg = based_segno; pds$mc_trace_sw.init_sw = "1"b; /* let user turn on trace */ end; end; else do; /* user wants to turn trace off */ pds$mc_trace_sw.init_sw = "0"b; /* don't let user turn on trace */ pds$mc_trace_sw.hc_trace_sw = "0"b; /* must turn switch off first */ pds$mc_trace_seg = 0; bp = pds$mc_trace_buf; /* save buffer pointer */ pds$mc_trace_buf = null; /* this makes it cleaner */ /* Unwire trace buffer */ call user_wire (bp, "0"b, 0, 0, code); if code ^= 0 then go to erret; call delentry$dseg (bp, code); /* delete buffer segment */ end; erret: a_code = code; call level$set (vl); /* Restore original validation level. */ return; /* hc_trace_on_off - entry to turn the hc_trace_sw in the pds on or off */ hc_trace_on_off: entry (a_trace_sw, a_code); a_code = 0; /* preset good return code */ if a_trace_sw then /* user wants to turn trace on */ if ^pds$mc_trace_sw.init_sw then /* if we haven't initialized the trace buffer */ a_code = error_table_$action_not_performed; /* don't let user turn trace on */ else pds$mc_trace_sw.hc_trace_sw = "1"b; else pds$mc_trace_sw.hc_trace_sw = "0"b; /* user wants to turn hc_trace_sw off */ return; end trace_mc;  user_wire.pl1 11/11/89 1136.0r w 11/11/89 0801.0 28566 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */ user_wire: user_wire_seg: proc (a_segptr, a_wiring, a_fp, a_np, a_code); /* Greenberg 2/10/77 */ /* Modified 7/3/84 by Keith Loepere to use the new dc_find. */ /* Parameters */ dcl a_code fixed bin (35) parameter; dcl a_dn char (*) parameter; dcl a_en char (*) parameter; dcl a_fp fixed bin parameter; dcl a_np fixed bin parameter; dcl a_segptr ptr parameter; dcl a_wiring bit (1) aligned parameter; /* Variables */ dcl code fixed bin (35); dcl dn char (168); dcl en char (32); dcl fp fixed bin; dcl np fixed bin; dcl pathentry bit (1); dcl segptr ptr; dcl wiring bit (1) aligned; /* External */ dcl error_table_$argerr fixed bin (35) ext; dcl error_table_$bad_ring_brackets fixed bin (35) ext; dcl error_table_$invalidsegno fixed bin (35) ext; /* Entries */ dcl activate entry (ptr, fixed bin (35)) returns (ptr); dcl level$get entry returns (fixed bin (3)); dcl lock$dir_unlock entry (ptr); dcl lock$unlock_ast entry; dcl pc_wired$unwire entry (ptr, fixed bin, fixed bin); dcl pc_wired$wire_wait entry (ptr, fixed bin, fixed bin); /* Misc */ dcl (fixed, ptr) builtin; %page; segptr = a_segptr; pathentry = "0"b; go to join; user_wire_file: entry (a_dn, a_en, a_wiring, a_fp, a_np, a_code); dn = a_dn; en = a_en; pathentry = "1"b; join: wiring = a_wiring; if wiring then do; fp = a_fp; np = a_np; end; else do; fp = 0; np = -1; end; if pathentry then call dc_find$obj_status_read_priv (dn, en, DC_FIND_CHASE, ep, code); else call dc_find$obj_status_read_priv_ptr (segptr, ep, code); if code = 0 then do; if level$get () > fixed (entry.ring_brackets (1), 3) then code = error_table_$bad_ring_brackets; else astep = activate (ep, code); if code = 0 then do; if aste.hc_sdw then code = error_table_$invalidsegno; else if fp >= fixed (aste.csl, 9) | (np ^= -1 & fp + np > fixed (aste.csl, 9)) | (np < 1 & np ^= -1) then code = error_table_$argerr; else do; aste.ehs = wiring; if wiring then call pc_wired$wire_wait (astep, fp, np); else call pc_wired$unwire (astep, fp, np); end; call lock$unlock_ast; end; call lock$dir_unlock (ptr (ep, 0)); if pathentry then call dc_find$finished (ep, "0"b); end; a_code = code; return; %page; %page; %include aste; %page; %include dc_find_dcls; %page; %include dir_entry; end; 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