control_point_manager_call.pl1 11/04/86 1558.6rew 11/04/86 1031.4 489825 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: off */ /* Command interface to the Multics Control Point Manager */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206): Written to support control point management in March 1985 by G. Palter. END HISTORY COMMENTS */ /* format: style3,linecom */ control_point_manager_call: cpmc: procedure () options (variable); dcl return_value character (return_value_lth) varying based (return_value_ptr); dcl return_value_ptr pointer; dcl return_value_lth fixed binary (21); dcl is_active_function bit (1) aligned; dcl argument character (argument_lth) based (argument_ptr); dcl argument_ptr pointer; dcl argument_lth fixed binary (21); dcl (n_arguments, argument_idx) fixed binary; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl 1 users_entry aligned based (users_entry_ptr), 2 entry entry (pointer) variable, 2 info_ptr pointer; dcl users_entry_ptr pointer; dcl command_line character (4 * sys_info$max_seg_size - 4) varying based (command_line_ptr); dcl command_line_ptr pointer; dcl pi_preferred bit (1) aligned based (pi_preferred_ptr); dcl pi_preferred_ptr pointer; dcl sci_ptr pointer; dcl 1 cpmc_info aligned, 2 ssu_arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)) variable, 2 operation_idx fixed binary; dcl i fixed binary; dcl code fixed binary (35); dcl CONTROL_POINT_MANAGER_CALL character (32) static options (constant) initial ("control_point_manager_call"); dcl CONTROL_POINT_MANAGER_CALL_VERSION character (32) static options (constant) initial ("1.0"); dcl SSU_ARG_PTR character (32) static options (constant) initial ("arg_ptr"); dcl SSU_GET_SUBSYSTEM_AND_REQUEST_NAME character (32) static options (constant) initial ("get_subsystem_and_request_name"); dcl WHITESPACE character (5) static options (constant) initial (" "); /* NL, HT, SP, VT, FF */ /* format: off */ dcl OPERATION_NAMES dimension (0:21, 2) character (20) varying static options (constant) initial ("", "", /* (the command itself) */ "enabled", "invoked", "id", "", "create", "cr", /* ENTRY {INFO_PTR} {-control_args} */ "destroy", "", /* ID */ "start", "sr", /* ID */ "wakeup", "", /* ID */ "stop", "", /* ID */ "scheduler", "", "generate_call", "gc", /* ID ENTRY {INFO_PTR} {-control_args} */ "list", "ls", /* {ID} {-control_args} */ "probe", "pb", /* ID */ "program_interrupt", "pi", /* ID {-control_arg} */ "run", "", /* {-control_args} COMMAND_LINE */ "cl_intermediary", "", /* ID */ "set_cl_intermediary", "", /* ID {ENTRY} {-control_args} */ "preferred", "", "set_preferred", "", /* ID */ "push_preferred", "", /* ID */ "pop_preferred", "", /* FLAG */ "enable", "invoke", "select", "sl"); /* ID */ dcl OPERATION_IS_COMMAND_ONLY dimension (21) bit (1) aligned static options (constant) initial (( 2) ("0"b), /* enabled, id */ (11) ("1"b), ( 1) ("0"b), /* cl_intermediary */ ( 1) ("1"b), ( 1) ("0"b), /* preferred */ ( 1) ("1"b), ( 1) ("0"b), /* push_preferred */ ( 3) ("1"b)); dcl OPERATION_ENTRIES dimension (21) entry () variable; dcl STATE_NAMES dimension (0:3) character (12) varying initial ("DESTROYED", "STOPPED", "BLOCKED", "READY"); /* format: on */ dcl ( MICROSECONDS_PER_HOUR initial (3600000000), MICROSECONDS_PER_MINUTE initial (60000000), MICROSECONDS_PER_SECOND initial (1000000) ) fixed binary (71) static options (constant); dcl ( cpm_et_$already_started, cpm_et_$control_point_not_found, error_table_$active_function, error_table_$bad_arg, error_table_$bad_conversion, error_table_$badopt, error_table_$inconsistent, error_table_$noarg, error_table_$too_many_args ) fixed binary (35) external; dcl sys_info$max_seg_size fixed binary (19) external; dcl active_fnc_err_$suppress_name entry () options (variable); dcl com_err_ entry () options (variable); dcl com_err_$suppress_name entry () options (variable); dcl cpm_initialize_ entry (); dcl cu_$cp entry (pointer, fixed binary (21), fixed binary (35)); dcl cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); dcl cv_entry_ entry (character (*), pointer, fixed binary (35)) returns (entry); dcl cv_oct_check_ entry (character (*), fixed binary (35)) returns (bit (36) aligned); dcl cv_ptr_ entry (character (*), fixed binary (35)) returns (pointer); dcl cv_ptr_$terminate entry (pointer); dcl get_system_free_area_ entry () returns (pointer); dcl get_entry_name_ entry (pointer, character (*), fixed binary (18), character (8) aligned, fixed binary (35)); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl hcs_$fs_get_path_name entry (pointer, character (*), fixed binary, character (*), fixed binary (35)); dcl ioa_ entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl ioa_$rsnpnnl entry () options (variable); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl probe$probe entry () options (variable); dcl program_interrupt$program_interrupt entry () options (variable); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl requote_string_ entry (character (*)) returns (character (*)); dcl ssu_$abort_subsystem entry () options (variable); dcl ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21)); dcl ssu_$destroy_invocation entry (pointer); dcl ssu_$get_info_ptr entry (pointer) returns (pointer); dcl ssu_$get_procedure entry (pointer, character (*), entry, fixed binary (35)); dcl ssu_$print_message entry () options (variable); dcl ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21)); dcl ssu_$set_info_ptr entry (pointer, pointer); dcl ssu_$set_procedure entry (pointer, character (*), entry, fixed binary (35)); dcl ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35)); dcl cleanup condition; dcl (addr, addwordno, baseptr, before, binary, codeptr, divide, environmentptr, float, hbound, index, lbound, length, mod, null, rtrim, stackbaseptr, string, substr) builtin; %page; /* control_point_manager_call: cpmc: entry () options (variable); */ call ssu_$standalone_invocation (sci_ptr, CONTROL_POINT_MANAGER_CALL, CONTROL_POINT_MANAGER_CALL_VERSION, null (), abort_control_point_manager_call, code); if code ^= 0 then do; call com_err_ (code, CONTROL_POINT_MANAGER_CALL, "Creating a standalone invocation."); return; end; on cleanup call ssu_$destroy_invocation (sci_ptr); cpmc_info.operation_idx = 0; /* see commentary before operation_arg_ptr for details */ cpmc_info.ssu_arg_ptr = cpm_$nulle; call ssu_$set_info_ptr (sci_ptr, addr (cpmc_info)); call ssu_$return_arg (sci_ptr, n_arguments, is_active_function, return_value_ptr, return_value_lth); if n_arguments = 0 then call display_usage_message_and_abort ("operation {operation_arguments}"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); do cpmc_info.operation_idx = lbound (OPERATION_ENTRIES, 1) to hbound (OPERATION_ENTRIES, 1); do i = lbound (OPERATION_NAMES, 2) to hbound (OPERATION_NAMES, 2); if argument = OPERATION_NAMES (cpmc_info.operation_idx, i) then go to KNOWN_OPERATION; end; end; call ssu_$abort_subsystem (sci_ptr, 0, "Unknown operation. ""^a""", argument); KNOWN_OPERATION: if is_active_function & OPERATION_IS_COMMAND_ONLY (cpmc_info.operation_idx) then call ssu_$abort_subsystem (sci_ptr, error_table_$active_function, "^/^-The ""^a"" keyword is not valid when used as an active function.", OPERATION_NAMES (cpmc_info.operation_idx, 1)); call prepare_for_operation (); call OPERATION_ENTRIES (cpmc_info.operation_idx) (); /* perform the requested operation */ RETURN_FROM_CONTROL_POINT_MANAGER_CALL: call ssu_$destroy_invocation (sci_ptr); return; /* Invoked by ssu_$abort_subsystem and ssu_$abort_line after printing an error message to terminate command execution */ abort_control_point_manager_call: procedure (); go to RETURN_FROM_CONTROL_POINT_MANAGER_CALL; end abort_control_point_manager_call; %page; /* Due to a bug in ssu_, the following procedures (operation_arg_ptr and get_command_and_operation_name) must be entrypoints directly into control_point_manager_call rather than internal procedures. Therefore, they can only reference data which is made available through the subsystem's info_ptr. */ dcl P_sci_ptr pointer parameter; /* common to both entrypoints */ dcl 1 based_cpmc_info like cpmc_info aligned based (cpmc_info_ptr); dcl cpmc_info_ptr pointer; /* ssu_$arg_ptr replacement used by the individual operations */ operation_arg_ptr: entry (P_sci_ptr, P_argument_idx, P_argument_ptr, P_argument_lth); dcl P_argument_idx fixed binary parameter; dcl P_argument_ptr pointer parameter; dcl P_argument_lth fixed binary (21) parameter; cpmc_info_ptr = ssu_$get_info_ptr (P_sci_ptr); call based_cpmc_info.ssu_arg_ptr (P_sci_ptr, (P_argument_idx + 1), P_argument_ptr, P_argument_lth); return; /* ssu_$get_subsystem_and_request_name replacement used by the individual operations */ get_command_and_operation_name: entry (P_sci_ptr) returns (character (72) varying); dcl command_and_operation_name character (72) varying; cpmc_info_ptr = ssu_$get_info_ptr (P_sci_ptr); command_and_operation_name = rtrim (CONTROL_POINT_MANAGER_CALL); if based_cpmc_info.operation_idx > 0 then do; /* there's an operation in control at present */ command_and_operation_name = command_and_operation_name || " ("; command_and_operation_name = command_and_operation_name || OPERATION_NAMES (based_cpmc_info.operation_idx, 1); command_and_operation_name = command_and_operation_name || ")"; end; return (command_and_operation_name); %page; /* This entrypoint is invoked by the create and generate_call operations in the other control point -- After invoking the user's entrypoint, this entrypint will then terminate the user's info_ptr as it was initiated by this command in the first place. */ run_users_entry: entry (P_users_entry_ptr); dcl P_users_entry_ptr pointer parameter; users_entry_ptr = P_users_entry_ptr; on cleanup begin; if users_entry.info_ptr ^= null () then do; call cv_ptr_$terminate (users_entry.info_ptr); users_entry.info_ptr = null (); end; end; call users_entry.entry (users_entry.info_ptr); if users_entry.info_ptr ^= null () then do; call cv_ptr_$terminate (users_entry.info_ptr); users_entry.info_ptr = null (); end; return; /* This entrypoint is invoked by the run operation in the new control point to invoke execute the command line and the release the temporary segment containing the command line. */ run_command_line: entry (P_command_line_ptr); dcl P_command_line_ptr pointer parameter; command_line_ptr = P_command_line_ptr; on cleanup begin; if command_line_ptr ^= null () then call release_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, (0)); end; call cu_$cp (addwordno (addr (command_line), 1), length (command_line), (0)); call release_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, (0)); return; %page; /* This entrypoint is invoked by the program_interrupt operation in the target control point to actually signal program_interrupt -- The user can request that the control point be made the preferred control point before actually signalling program_interrupt. Due to the interaction of cpm_$generate_call and the control point scheduler, setting the preferred control point must be deferred until we are running in the target control point. */ pi_signaller: entry (P_pi_preferred_ptr); dcl P_pi_preferred_ptr pointer parameter; system_area_ptr = get_system_free_area_ (); pi_preferred_ptr = P_pi_preferred_ptr; on cleanup begin; if pi_preferred_ptr ^= null () then free pi_preferred in (system_area); pi_preferred_ptr = null (); end; if pi_preferred then do; call cpm_$set_preferred_control_point (get_control_point_id_ (), code); if code ^= 0 then call com_err_ (code, CONTROL_POINT_MANAGER_CALL, "Trying to make the control point ^12.3b preferred.", get_control_point_id_ ()); end; free pi_preferred in (system_area); /* we don't need it anymore */ pi_preferred_ptr = null (); call program_interrupt$program_interrupt (); /* the command knows how to handle no handler */ return; %page; /* Prepare to perform a specific operation */ prepare_for_operation: procedure (); n_arguments = n_arguments - 1; /* operations don't count their name as an argument */ /* Replace ssu_$arg_ptr with a private procedure -- The private procedure will increment the requested argument index by one before calling the saved value of ssu_$arg_ptr. In this way, the individual operations can be coded as if they were standalone commands as the private ssu_$arg_ptr will, effectively, make them ignore the existence of our real first argument -- the operation keyword. */ call ssu_$get_procedure (sci_ptr, SSU_ARG_PTR, cpmc_info.ssu_arg_ptr, code); if code = 0 /* we have the reall ssu_$arg_ptr stashed away */ then call ssu_$set_procedure (sci_ptr, SSU_ARG_PTR, operation_arg_ptr, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Attempting to replace ssu_$arg_ptr."); /* Replace ssu_$get_subsystem_and_request_name with a private procedure -- The private procedure uses the operation's primary name as the "request" name. */ call ssu_$set_procedure (sci_ptr, SSU_GET_SUBSYSTEM_AND_REQUEST_NAME, get_command_and_operation_name, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Attempting to replace ssu_$get_subsystem_and_request_name."); /* Initialize the OPERATION_ENTRIES array -- Multics PL/I does not implement constant entry arrays. */ OPERATION_ENTRIES (1) = is_cpm_enabled; OPERATION_ENTRIES (2) = get_id; OPERATION_ENTRIES (3) = create_control_point$create; OPERATION_ENTRIES (4) = destroy; OPERATION_ENTRIES (5) = start; OPERATION_ENTRIES (6) = wakeup; OPERATION_ENTRIES (7) = stop; OPERATION_ENTRIES (8) = scheduler; OPERATION_ENTRIES (9) = generate_call; OPERATION_ENTRIES (10) = list; OPERATION_ENTRIES (11) = probe; OPERATION_ENTRIES (12) = program_interrupt; OPERATION_ENTRIES (13) = create_control_point$run; OPERATION_ENTRIES (14) = get_cl_intermediary; OPERATION_ENTRIES (15) = set_cl_intermediary; OPERATION_ENTRIES (16) = get_preferred; OPERATION_ENTRIES (17) = set_preferred; OPERATION_ENTRIES (18) = push_preferred; OPERATION_ENTRIES (19) = pop_preferred; OPERATION_ENTRIES (20) = enable_cpm; OPERATION_ENTRIES (21) = select; return; end prepare_for_operation; %page; /* Display a usage message for the command or one of its operations and then abort the command */ display_usage_message_and_abort: procedure (p_arguments_description); dcl p_arguments_description character (*) parameter; if is_active_function then call active_fnc_err_$suppress_name (0, CONTROL_POINT_MANAGER_CALL, "Usage: ^a^[ ^a^;^s^]^[ ^a^]", CONTROL_POINT_MANAGER_CALL, (cpmc_info.operation_idx > 0), OPERATION_NAMES (cpmc_info.operation_idx, 1), (length (p_arguments_description) > 0), p_arguments_description); else call com_err_$suppress_name (0, CONTROL_POINT_MANAGER_CALL, "Usage: ^a^[ ^a^;^s^]^[ ^a^]", CONTROL_POINT_MANAGER_CALL, (cpmc_info.operation_idx > 0), OPERATION_NAMES (cpmc_info.operation_idx, 1), (length (p_arguments_description) > 0), p_arguments_description); call abort_control_point_manager_call (); /* never returns */ end display_usage_message_and_abort; /* Abort the operation if it was given any arguments */ reject_any_arguments: procedure (); if n_arguments ^= 0 then call ssu_$abort_subsystem (sci_ptr, 0, "No arguments may be given for this operation."); return; end reject_any_arguments; /* Pickup a control argument's required argument */ fetch_next_argument: procedure (p_noarg_message); dcl p_noarg_message character (*) parameter; if argument_idx = n_arguments then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, p_noarg_message); argument_idx = argument_idx + 1; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); return; end fetch_next_argument; %page; /* Convert a character string into a control point ID -- Actually, this procedure sets cpd_ptr to locate the control point definition requested by the user. A control point ID can be specified in one of two ways. Either the entire ID must be given or only the first six digits (the stack segment number) must be supplied. In either case, the ID must always be supplied as an octal number. */ cv_string_to_control_point_id: procedure (); dcl 1 decoded_control_point_id /* internal representation of a control point ID */ aligned, 2 stack_segno bit (18) unaligned, 2 unique_bits bit (18) unaligned; dcl control_point_id bit (36) aligned; dcl check_unique_bits bit (1) aligned; control_point_id = cv_oct_check_ (argument, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, error_table_$bad_conversion, "Control point IDs must be given as octal strings; not ""^a"".", argument); if control_point_id > "000000777777"b3 /* full ID given */ then do; string (decoded_control_point_id) = control_point_id; check_unique_bits = "1"b; end; else do; string (decoded_control_point_id) = substr (control_point_id, 19, 18) || "000000"b3; check_unique_bits = "0"b; end; if cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) then do; /* the given ID does identify a valid stack */ cpd_ptr = baseptr (decoded_control_point_id.stack_segno) -> stack_header.cpm_data_ptr; if check_unique_bits then if control_point_data.id = control_point_id then return; else ; /* unique IDs don't match */ else return; /* caller only supplied the stack segno */ end; call ssu_$abort_subsystem (sci_ptr, cpm_et_$control_point_not_found, "^6.3b^[^6.3b^;xxxxxx^]", decoded_control_point_id.stack_segno, check_unique_bits, decoded_control_point_id.unique_bits); end cv_string_to_control_point_id; %page; /* Enable control point management */ enable_cpm: procedure (); call reject_any_arguments (); if stackbaseptr () -> stack_header.cpm_enabled then call ssu_$abort_subsystem (sci_ptr, 0, "Control point management is already enabled."); else call cpm_initialize_ (); return; end enable_cpm; /* Determine whether control point management is enabled */ is_cpm_enabled: procedure (); dcl cpm_is_enabled bit (1) aligned; call reject_any_arguments (); cpm_is_enabled = (stackbaseptr () -> stack_header.cpm_enabled ^= ""b); if is_active_function /* return it into the command line */ then if cpm_is_enabled then return_value = "true"; else return_value = "false"; else call ioa_ ("Control point management is^[ not^] enabled.", ^cpm_is_enabled); return; end is_cpm_enabled; /* Determine the current control point's unique ID */ get_id: procedure (); dcl id_string character (12); call reject_any_arguments (); call ioa_$rsnnl ("^12.3b", id_string, (0), get_control_point_id_ ()); if is_active_function /* return it into the command line */ then return_value = id_string; else call ioa_ ("Current control point ID is ^a.", id_string); return; end get_id; %page; /* The "create" and "run" operations */ create_control_point: procedure (); return; /* not used */ dcl 1 ccpi_header like create_control_point_info.header aligned; dcl atd_argument character (atd_argument_lth) based (atd_argument_ptr); dcl atd_argument_ptr pointer; dcl atd_argument_lth fixed binary (21); dcl control_point_id bit (36) aligned; dcl users_entry_entrypoint_name character (256); dcl users_entry_ename character (32); dcl (create_operation, run_operation, in_command_line, have_users_entry, have_users_info_ptr, display_the_id, start_the_control_point, prefer_the_control_point, prefer_the_control_point_given) bit (1) aligned; /* Create a new control point -- This operation is pratically a direct interface to cpm_$create. However, rather than invoking the user's initial procedure immediately in the new control point, we supply a private initial procedure whose sole purpose is to insure that the user's info_ptr is properly terminated. */ create_control_point$create: entry (); if n_arguments = 0 then call display_usage_message_and_abort ("ENTRY {INFO_PTR} {-control_args}"); create_operation = "1"b; run_operation = "0"b; go to CREATE_CONTROL_POINT; /* Create a new control point to execute the supplied command line */ create_control_point$run: entry (); if n_arguments = 0 then call display_usage_message_and_abort ("{-control_args} COMMAND_LINE"); create_operation = "0"b; run_operation = "1"b; go to CREATE_CONTROL_POINT; /* The actual code for both the "create" and "run" operations */ CREATE_CONTROL_POINT: system_area_ptr = get_system_free_area_ (); users_entry_ptr, /* for cleanup handler */ command_line_ptr, ccpi_ptr = null (); have_users_entry, have_users_info_ptr = "0"b; on cleanup begin; if create_operation then do; if users_entry_ptr ^= null () then do; if have_users_info_ptr then do; call cv_ptr_$terminate (users_entry.info_ptr); have_users_info_ptr = "0"b; end; free users_entry in (system_area); users_entry_ptr = null (); end; end; else /*** if run_operation then */ do; if command_line_ptr ^= null () then call release_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, (0)); end; if ccpi_ptr ^= null () then do; free create_control_point_info in (system_area); ccpi_ptr = null (); end; end; /* Setup appropriate defaults for the new control point */ display_the_id = "1"b; /* tell the user what happened */ if create_operation then do; allocate users_entry in (system_area) set (users_entry_ptr); ccpi_header.initproc.entry = run_users_entry; ccpi_header.initproc.info_ptr = users_entry_ptr; start_the_control_point = "0"b; /* the user must explicitly start this control point ... */ prefer_the_control_point = "0"b; /* ... and explicitly give it control */ end; else /*** if run_operation then */ do; call get_temp_segment_ (CONTROL_POINT_MANAGER_CALL, command_line_ptr, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Unable to obtain space for the command line."); command_line = ""; /* initialize the command line to empty */ ccpi_header.initproc.entry = run_command_line; ccpi_header.initproc.info_ptr = command_line_ptr; start_the_control_point = "1"b; /* have execution begin as soon as possible ... */ prefer_the_control_point = "1"b; /* ... and let it have real control */ end; ccpi_header.version = CREATE_CONTROL_POINT_INFO_VERSION_1; ccpi_header.comment = ""; ccpi_header.priority = 1; string (ccpi_header.flags) = ""b; ccpi_header.independent = "1"b; /* Parse the arguments which define the new control point */ in_command_line = "0"b; /* for run: we haven't seen the command line yet */ prefer_the_control_point_given = "0"b; do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if ^in_command_line & (index (argument, "-") = 1) then /* a control argument */ if (argument = "-long") | (argument = "-lg") then display_the_id = "1"b; else if (argument = "-brief") | (argument = "-bf") then display_the_id = "0"b; else if (argument = "-start") | (argument = "-sr") then start_the_control_point = "1"b; else if (argument = "-no_start") | (argument = "-nsr") then start_the_control_point = "0"b; else if argument = "-preferred" then prefer_the_control_point, prefer_the_control_point_given = "1"b; else if argument = "-not_preferred" then do; prefer_the_control_point = "0"b; prefer_the_control_point_given = "1"b; end; else if argument = "-priority" then do; call fetch_next_argument ("A number after ""-priority""."); ccpi_header.priority = cv_dec_check_ (argument, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, error_table_$bad_conversion, "-priority ""^a""", argument); end; else if (argument = "-comment") | (argument = "-com") then do; call fetch_next_argument ("A string after ""-comment""."); ccpi_header.comment = argument; end; else if argument = "-independent" then ccpi_header.independent = "1"b; else if argument = "-dependent" then ccpi_header.independent = "0"b; else if argument = "-cl_intermediary" then do; call fetch_next_argument ("An entry after ""-cl_intermediary""."); ccpi_header.user_cl_intermediary = cv_entry_ (argument, null (), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "-cl_intermediary ""^a""", argument); ccpi_header.user_cl_intermediary_given = "1"b; end; else if argument = "-default_cl_intermediary" then ccpi_header.user_cl_intermediary_given = "0"b; else if (argument = "-separate_io_switches") | (argument = "-sepios") then do; ccpi_header.separate_standard_iocbs = "1"b; ccpi_header.user_io_attach_desc_given = "0"b; if argument_idx < n_arguments then do; /* check for an optional attach description */ call ssu_$arg_ptr (sci_ptr, (argument_idx + 1), atd_argument_ptr, atd_argument_lth); if index (atd_argument, "-") ^= 1 then do; ccpi_header.user_io_attach_desc_given = "1"b; argument_idx = argument_idx + 1; end; end; end; else if (argument = "-shared_io_switches") | (argument = "-shios") then ccpi_header.separate_standard_iocbs, ccpi_header.user_io_attach_desc_given = "0"b; else if run_operation & ((argument = "-string") | (argument = "-str")) then do; if argument_idx = n_arguments then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A command line after ""-string""."); in_command_line = "1"b; end; else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument); else /* not a control argument: depends on the operation */ if create_operation then do; if ^have_users_entry then do; users_entry.entry = cv_entry_ (argument, null (), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument); have_users_entry = "1"b; end; else if ^have_users_info_ptr then do; users_entry.info_ptr = cv_ptr_ (argument, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument); have_users_info_ptr = "1"b; end; else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument); end; else /*** if run_operation then */ do; if length (command_line) > 0 then command_line = command_line || " "; command_line = command_line || argument; in_command_line = "1"b; end; end; if create_operation then do; if ^have_users_entry /* there must be an initial procedure */ then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "An initial procedure must be specified."); if ^have_users_info_ptr /* ... but its info_ptr is optional */ then users_entry.info_ptr = null (); end; else /*** if run_operation then */ do; if length (command_line) = 0 then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A command line to be executed."); end; if prefer_the_control_point_given & ^start_the_control_point then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-no_start"" and ""-^[not_^;^]preferred"".", ^prefer_the_control_point); if ccpi_header.comment = "" then do; /* supply a reasonable "name" for the control point */ if create_operation then do; call hcs_$fs_get_path_name (codeptr (users_entry.entry), ((168)" "), (0), users_entry_ename, (0)); call get_entry_name_ (codeptr (users_entry.entry), users_entry_entrypoint_name, (0), ((8)" "), (0)); ccpi_header.comment = rtrim (users_entry_ename) || "$" || users_entry_entrypoint_name; end; else /*** if run_operation then */ ccpi_header.comment = before (command_line, WHITESPACE); end; /* Create and, optionally, start the control point and mark it as preferred */ if ccpi_header.user_io_attach_desc_given then ccpi_user_io_attach_desc_length = atd_argument_lth; else ccpi_user_io_attach_desc_length = 1; /* PL/I abhors zero-length strings */ allocate create_control_point_info in (system_area) set (ccpi_ptr); create_control_point_info.header = ccpi_header; create_control_point_info.user_io_attach_desc_length = ccpi_user_io_attach_desc_length; if create_control_point_info.user_io_attach_desc_given then create_control_point_info.user_io_attach_desc = atd_argument; call cpm_$create (ccpi_ptr, control_point_id, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Creating the control point."); revert cleanup; /* it's the new control point's responsibility to cleanup */ free create_control_point_info in (system_area); /* we don't need it anymore */ if start_the_control_point then do; call cpm_$start (control_point_id, code); if code = 0 then /* it started: mark it preferred if requested */ if prefer_the_control_point then do; call cpm_$set_preferred_control_point (control_point_id, code); if code ^= 0 then call ssu_$print_message (sci_ptr, code, "Trying to make the control point ^12.3b preferred.", control_point_id); end; else ; else call ssu_$print_message (sci_ptr, code, "Trying to start the control point ^12.3b.", control_point_id); end; if display_the_id then call ioa_ ("Control point ^12.3b created^[^[, started, and marked preferred^; and started^]^].", control_point_id, start_the_control_point, prefer_the_control_point); return; end create_control_point; %page; /* Destroy the specified control point */ destroy: procedure (); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$destroy (control_point_data.id, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to destroy the control point ^12.3b.", control_point_data.id); return; end destroy; /* Start the specified control point if it is in the STOPPED state */ start: procedure (); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$start (control_point_data.id, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to start the control point ^12.3b.", control_point_data.id); return; end start; %page; /* Wakeup the specified control point if it is in the BLOCKED state */ wakeup: procedure (); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$wakeup (control_point_data.id, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to wakeup the control point ^12.3b.", control_point_data.id); return; end wakeup; /* Stop the specified control point if it is in the READY or BLOCKED state */ stop: procedure (); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$stop (control_point_data.id, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to stop the control point ^12.3b.", control_point_data.id); return; end stop; %page; /* Select the specified control point for preferred treatment -- If the control point is STOPPED, start it. In any event, try to make it the preferred control point. */ select: procedure (); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$start (control_point_data.id, code); if (code ^= 0) & (code ^= cpm_et_$already_started) then call ssu_$abort_subsystem (sci_ptr, code, "Trying to start the control point ^12.3b.", control_point_data.id); call cpm_$set_preferred_control_point (control_point_data.id, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to make the control point ^12.3b preferred.", control_point_data.id); return; end select; /* Block the current control point and invoke the control point scheduler */ scheduler: procedure (); call reject_any_arguments (); call cpm_$block (); call cpm_$scheduler (); return; end scheduler; %page; /* Generate a call to the given entrypoint in another control point */ generate_call: procedure (); dcl (have_control_point_id, have_users_entry, have_users_info_ptr, immediate, preferred, preferred_given) bit (1) aligned; if n_arguments = 0 then call display_usage_message_and_abort ("ID ENTRY {INFO_PTR} {-control_args}"); system_area_ptr = get_system_free_area_ (); users_entry_ptr = null (); /* for cleanup handler */ have_control_point_id, have_users_entry, have_users_info_ptr = "0"b; on cleanup begin; if users_entry_ptr ^= null () then do; if have_users_info_ptr then do; call cv_ptr_$terminate (users_entry.info_ptr); have_users_info_ptr = "0"b; end; free users_entry in (system_area); users_entry_ptr = null (); end; end; allocate users_entry in (system_area) set (users_entry_ptr); /* Parse our arguments */ immediate = "1"b; /* run the other control point right away */ preferred, preferred_given = "0"b; /* ... but do not make it the preferred control point */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-immediate") | (argument = "-im") then immediate = "1"b; else if (argument = "-defer_until_ready") | (argument = "-dur") then immediate = "0"b; else if argument = "-preferred" then preferred, preferred_given = "1"b; else if argument = "-not_preferred" then do; preferred = "0"b; preferred_given = "1"b; end; else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument); else /* a non-control argument */ if ^have_control_point_id then do; call cv_string_to_control_point_id (); have_control_point_id = "1"b; end; else if ^have_users_entry then do; users_entry.entry = cv_entry_ (argument, null (), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument); have_users_entry = "1"b; end; else if ^have_users_info_ptr then do; users_entry.info_ptr = cv_ptr_ (argument, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument); have_users_info_ptr = "1"b; end; else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument); end; if ^have_control_point_id /* we must have someplace to execute the entrypoint */ then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A control point ID must be specified."); if ^have_users_entry /* ... and there must be an entrypoint */ then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "An entrypoint must be specified."); if ^have_users_info_ptr /* ... but its info_ptr is optional */ then users_entry.info_ptr = null (); if ^immediate & preferred_given then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-defer_until_ready"" and ""-^[not_^]preferred"".", ^preferred); /* Make the call */ if immediate then if preferred then call cpm_$generate_call_preferred (control_point_data.id, run_users_entry, users_entry_ptr, code); else call cpm_$generate_call (control_point_data.id, run_users_entry, users_entry_ptr, code); else call cpm_$generate_call (control_point_data.id, run_users_entry, users_entry_ptr, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to generate a call into the control point ^12.3b.", control_point_data.id); return; end generate_call; %page; /* List the specified (or all) control points with optional metering data */ list: procedure (); dcl cpd_ptr_list dimension (n_arguments) pointer based (cpd_ptr_list_ptr); dcl cpd_ptr_list_ptr pointer; dcl n_control_points fixed binary; dcl (list_all, display_meters) bit (1) aligned; dcl i fixed binary; if n_arguments = 0 then call display_usage_message_and_abort ("{IDs} {-control_args}"); if stackbaseptr () -> stack_header.cpm_enabled = ""b then call ssu_$abort_subsystem (sci_ptr, 0, "Control point management is not enabled."); system_area_ptr = get_system_free_area_ (); cpd_ptr_list_ptr = null (); /* for cleanup handler */ on cleanup begin; if cpd_ptr_list_ptr ^= null () then do; free cpd_ptr_list in (system_area); cpd_ptr_list_ptr = null (); end; end; allocate cpd_ptr_list in (system_area) set (cpd_ptr_list_ptr); /* Parse our arguments */ list_all = "0"b; /* caller must either supply IDs or "-all" */ n_control_points = 0; display_meters = "0"b; /* no meters unless explicitly requested */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-all") | (argument = "-a") then list_all = "1"b; else if argument = "-meters" then display_meters = "1"b; else if argument = "-no_meters" then display_meters = "0"b; else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument); else /* a non-control argument: must be a control point ID */ do; call cv_string_to_control_point_id (); do i = 1 to n_control_points; /* ... don't list a control point more than once */ if cpd_ptr_list (i) = cpd_ptr then go to PARSE_NEXT_ARGUMENT; end; n_control_points = n_control_points + 1; cpd_ptr_list (n_control_points) = cpd_ptr; end; PARSE_NEXT_ARGUMENT: end; if list_all & (n_control_points > 0) then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-all"" and control point IDs."); else if ^list_all & (n_control_points = 0) then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "At least one control point ID or ""-all"" must be specified."); /* Now display the requested control points */ if display_meters & (list_all | (n_control_points > 1)) then do; /* display scheduler meters if multiple control points */ call ioa_ ("Scheduler overhead:"); call display_metering_data (addr (cpm_data_$global_meters.overhead)); end; if list_all | (n_control_points > 1) then do; /* display a header for multiple control points */ call ioa_ ("^4tID^12t(Long ID)^25tDepth^33tState^51tComment"); call ioa_ (""); end; if list_all /* list all control points */ then call list_all_control_points (addr (cpm_data_$root_control_point_data), 0); else /* list only the ones specificly requested */ do i = 1 to n_control_points; call list_control_point (cpd_ptr_list (i), -1); end; free cpd_ptr_list in (system_area); /* cleanup */ cpd_ptr_list_ptr = null (); return; /* List all control points recursively */ list_all_control_points: procedure (p_cpd_ptr, p_depth) recursive; dcl 1 p_cpd like control_point_data aligned based (p_cpd_ptr); dcl p_cpd_ptr pointer; dcl p_depth fixed binary parameter; dcl 1 child_cpd like control_point_data aligned based (child_cpd_ptr); dcl child_cpd_ptr pointer; call list_control_point (p_cpd_ptr, p_depth); /* display this control point's definition */ do child_cpd_ptr = p_cpd.first_child repeat (child_cpd.next_peer) while (child_cpd_ptr ^= null ()); call list_all_control_points (child_cpd_ptr, (p_depth + 1)); end; return; end list_all_control_points; /* List a single control point */ list_control_point: procedure (p_cpd_ptr, p_depth); dcl 1 p_cpd like control_point_data aligned based (p_cpd_ptr); dcl p_cpd_ptr pointer; dcl p_depth fixed binary parameter; dcl 1 parent_cpd like control_point_data aligned based (parent_cpd_ptr); dcl parent_cpd_ptr pointer; dcl depth fixed binary; dcl 1 cpma like control_point_meters_argument aligned; if p_depth = -1 then do; /* caller has asked us to compute it */ depth = 0; do parent_cpd_ptr = p_cpd.parent repeat (parent_cpd.parent) while (parent_cpd_ptr ^= null ()); depth = depth + 1; end; end; else depth = p_depth; /* caller has supplied it */ call ioa_ ("^[*^; ^]^6.3b^9t(^12.3b)^27t^3d^33t^a^46t^a", (p_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr), p_cpd.id, p_cpd.id, depth, STATE_NAMES (p_cpd.state), p_cpd.comment); if display_meters & (p_cpd.state > CPM_DESTROYED) then do; /* ask cpm_ for the meters to insure they're up-to-date */ cpma.version = CONTROL_POINT_METERS_ARGUMENT_VERSION_1; call cpm_$get_control_point_meters (p_cpd.id, addr (cpma), (0)); call display_metering_data (addr (cpma.meters)); end; return; end list_control_point; /* Display the supplied metering data */ display_metering_data: procedure (p_meters_ptr); dcl 1 p_meters like control_point_meters aligned based (p_meters_ptr); dcl p_meters_ptr pointer; call ioa_ ("^11tRuns - ^6d^46tElapsed time - ^a", p_meters.n_schedules, format_time (p_meters.real_time)); call ioa_ ("^11tCPU time - ^a^46tPage Faults - ^6d", format_time (p_meters.virtual_cpu_time), p_meters.page_faults); call ioa_ ("^11tSegment Faults - ^6d^46tBounds Faults - ^6d", p_meters.segment_faults, p_meters.bounds_faults); call ioa_ ("^11tVTOC reads - ^6d^46tVTOC writes - ^6d", p_meters.vtoc_reads, p_meters.vtoc_writes); call ioa_ (""); return; end display_metering_data; /* Format an elapsed time reading as HHH:MM:SS.SSSSSS */ format_time: procedure (p_time) returns (character (16)); dcl p_time fixed binary (71) parameter; dcl 1 formatted_time aligned, 2 hours picture "999" unaligned, 2 colon_1 character (1) unaligned, 2 minutes picture "99" unaligned, 2 colon_2 character (1) unaligned, 2 seconds picture "99v.999999" unaligned; dcl (hours_value, minutes_value, seconds_value) fixed binary (71); seconds_value = mod (p_time, MICROSECONDS_PER_MINUTE); minutes_value = mod ((p_time - seconds_value), MICROSECONDS_PER_HOUR); hours_value = p_time - (minutes_value + seconds_value); string (formatted_time) = "000:00:00.000000"; formatted_time.hours = divide (hours_value, MICROSECONDS_PER_HOUR, 10, 0); formatted_time.minutes = divide (minutes_value, MICROSECONDS_PER_MINUTE, 7, 0); formatted_time.seconds = float (seconds_value) / float (MICROSECONDS_PER_SECOND); return (string (formatted_time)); end format_time; end list; %page; /* Invoke probe in the specified control point */ probe: procedure (); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$generate_call_preferred (control_point_data.id, probe_caller, null (), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to invoke probe in the control point ^12.3b.", control_point_data.id); return; end probe; /* Invoked by the above internal procedure in the desired control point to actually invoke probe */ probe_caller: entry (); call probe$probe (); return; %page; /* Signal program_interrupt in the specified control point */ program_interrupt: procedure (); if n_arguments = 0 then call display_usage_message_and_abort ("ID {-control_arg}"); system_area_ptr = get_system_free_area_ (); pi_preferred_ptr = null (); /* for cleanup handler */ on cleanup begin; if pi_preferred_ptr ^= null () then free pi_preferred in (system_area); pi_preferred_ptr = null (); end; allocate pi_preferred in (system_area) set (pi_preferred_ptr); /* Parse our arguments */ cpd_ptr = null (); /* no ID yet */ pi_preferred = "1"b; /* the target should become preferred */ do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if argument = "-preferred" then pi_preferred = "1"b; else if argument = "-not_preferred" then pi_preferred = "0"b; else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument); else /* a non-control argument: must be a control point ID */ if cpd_ptr = null () then call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument); end; if cpd_ptr = null () then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A control point ID must be specified."); /* Push a call to signal program_interrupt onto the target control point's stack */ revert cleanup; /* pi_preferred now belongs to the other control point */ call cpm_$generate_call (control_point_data.id, pi_signaller, pi_preferred_ptr, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to signal program_interrupt in the control point ^12.3b.", control_point_data.id); return; end program_interrupt; %page; /* Determine the user CL intermediary for a specific control point */ get_cl_intermediary: procedure (); dcl cl_intermediary entry (bit (1) aligned) variable; dcl cl_intermediary_name character (1024) varying; dcl cl_intermediary_entrypoint_name character (256); dcl cl_intermediary_dirname character (168); dcl cl_intermediary_ename character (32); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$get_user_cl_intermediary (control_point_data.id, cl_intermediary, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to get the CL intermediary of the control point ^12.3b", control_point_data.id); call hcs_$fs_get_path_name (codeptr (cl_intermediary), cl_intermediary_dirname, (0), cl_intermediary_ename, (0)) ; call get_entry_name_ (codeptr (cl_intermediary), cl_intermediary_entrypoint_name, (0), ((8)" "), (0)); call ioa_$rsnpnnl ("(^a$^a, ^p)", cl_intermediary_name, (0), pathname_ (cl_intermediary_dirname, cl_intermediary_ename), cl_intermediary_entrypoint_name, environmentptr (cl_intermediary)); if is_active_function /* return it into the command line */ then return_value = requote_string_ ((cl_intermediary_name)); else call ioa_ ("The CL intermediary for the control point ^12.3b is ^a.", control_point_data.id, cl_intermediary_name); return; end get_cl_intermediary; %page; /* Set the user CL intermediary for a specific control point */ set_cl_intermediary: procedure (); dcl cl_intermediary entry (bit (1) aligned) variable; dcl cl_intermediary_name character (1024) varying; dcl (have_control_point_id, have_cl_intermediary, use_default_cl_intermediary) bit (1) aligned; if n_arguments = 0 then call display_usage_message_and_abort ("ID {ENTRY} {-control_arg}"); have_control_point_id, have_cl_intermediary, use_default_cl_intermediary = "0"b; do argument_idx = 1 to n_arguments; call ssu_$arg_ptr (sci_ptr, argument_idx, argument_ptr, argument_lth); if index (argument, "-") = 1 then /* a control argument */ if (argument = "-default") | (argument = "-dft") then use_default_cl_intermediary = "1"b; else call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument); else /* a non-control argument */ if ^have_control_point_id then do; call cv_string_to_control_point_id (); have_control_point_id = "1"b; end; else if ^have_cl_intermediary then do; cl_intermediary = cv_entry_ (argument, null (), code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, """^a""", argument); have_cl_intermediary = "1"b; cl_intermediary_name = argument; end; else call ssu_$abort_subsystem (sci_ptr, error_table_$too_many_args, """^a""", argument); end; if ^have_control_point_id then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "A control point ID must be specified."); if have_cl_intermediary & use_default_cl_intermediary then call ssu_$abort_subsystem (sci_ptr, error_table_$inconsistent, """-default"" and ""^a"".", cl_intermediary_name); else if ^have_cl_intermediary & ^use_default_cl_intermediary then call ssu_$abort_subsystem (sci_ptr, error_table_$noarg, "An entrypoint or ""-default"" must be specified.") ; if have_cl_intermediary then call cpm_$set_user_cl_intermediary (control_point_data.id, cl_intermediary, code); else /*** if use_default_cl_intermediary then */ call cpm_$set_user_cl_intermediary (control_point_data.id, cpm_$nulle, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to set the CL intermediary of the control point ^12.3b to ^[""^a""^;its default value^].", control_point_data.id, have_cl_intermediary, cl_intermediary_name); return; end set_cl_intermediary; %page; /* Determine the unique ID of the preferred control point (if any) */ get_preferred: procedure (); dcl preferred_control_point_id bit (36) aligned; dcl id_string character (12); call reject_any_arguments (); preferred_control_point_id = cpm_$get_preferred_control_point (); if is_active_function /* return it into the command line */ then if preferred_control_point_id = ""b then return_value = "none"; else do; call ioa_$rsnnl ("^12.3b", id_string, (0), preferred_control_point_id); return_value = id_string; end; else if preferred_control_point_id = ""b then call ioa_ ("There is no preferred control point."); else call ioa_ ("Preferred control point ID is ^12.3b.", preferred_control_point_id); return; end get_preferred; /* Set the preferred control point */ set_preferred: procedure (); if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$set_preferred_control_point (control_point_data.id, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to make the control point ^12.3b preferred.", control_point_data.id); return; end set_preferred; %page; /* Set the preferred control point and push the previous one onto the preferred control point stack */ push_preferred: procedure (); dcl pushed_ok bit (1) aligned; if n_arguments ^= 1 then call display_usage_message_and_abort ("ID"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); call cv_string_to_control_point_id (); /* sets cpd_ptr or aborts */ call cpm_$push_preferred_control_point (control_point_data.id, pushed_ok, code); if code ^= 0 then call ssu_$abort_subsystem (sci_ptr, code, "Trying to push the preferred stack and make the control point ^12.3b preferred.", control_point_data.id); if is_active_function /* return an indication of success into the command line */ then if pushed_ok then return_value = "true"; else return_value = "false"; return; end push_preferred; %page; /* Pop the top entry off the preferred control point stack and make it preferred */ pop_preferred: procedure (); dcl was_pushed bit (1) aligned; if n_arguments ^= 1 then call display_usage_message_and_abort ("FLAG"); call ssu_$arg_ptr (sci_ptr, 1, argument_ptr, argument_lth); if index (argument, "-") = 1 then call ssu_$abort_subsystem (sci_ptr, error_table_$badopt, """^a""", argument); else if argument = "true" then was_pushed = "1"b; else if argument = "false" then was_pushed = "0"b; else call ssu_$abort_subsystem (sci_ptr, error_table_$bad_arg, """^a""", argument); call cpm_$pop_preferred_control_point (was_pushed); return; end pop_preferred; /* format: off */ %page; %include cpm_entries; %page; %include cpm_internal_data; %page; %include cpm_control_point_data; %include cpm_ctrl_pt_meters; %include process_usage; %page; %include cpm_create_ctrl_pt_info; %page; %include stack_header; /* format: on */ end control_point_manager_call;  cpm_.pl1 11/04/86 1557.5rew 11/04/86 1031.4 506115 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: off */ /* Multics Control Point Manager -- The control point manager provides a simple form of mulitasking within a process. Each control point is given a separate stack and, optionally, a separate of set the standard I/O switches. Once given control, a control point will continue to run until it either kills itself or attempts to block on an IPC event channel. This module implements the primitive operations of the control point manager. */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206): Written to support control point management in March 1985 by G. Palter based on C. Hornig's task_ctl_. END HISTORY COMMENTS */ /* format: style3,linecom */ cpm_: procedure (); ERROR_RETURN_FROM_CPM_: return; /* not an entrypoint */ /* Parameters */ dcl P_control_point_id bit (36) aligned parameter; dcl P_code fixed binary (35) parameter; dcl P_ccpi_ptr pointer parameter; /* create: -> description of the new control point */ dcl P_user_cl_intermediary /* *user_cl_intermediary: the user's CL intermediary */ entry (bit (1) aligned) variable parameter; dcl P_userproc /* generate_call*: the entrypoint to be called */ entry (pointer) variable parameter; dcl P_userproc_info_ptr pointer parameter; /* generate_call*: the argument to the user's entrypoint */ dcl P_pushed_preferred_control_point /* (push pop)_preferred_control_point: set ON => we ... */ bit (1) aligned parameter; /* ... pushed the preferred control point */ dcl P_cpma_ptr pointer parameter; /* get_*_meters: -> the meters */ dcl P_cpd_ptr pointer parameter; /* update_state_caller: -> the control point */ dcl P_new_state fixed binary parameter; /* update_state_caller: new state for the control point */ dcl P_mask bit (36) aligned parameter; /* *mask_ips_interrupts_caller: the current IPS mask */ /* Remaining declarations */ dcl 1 current_control_point_data /* the current control point's definition */ like control_point_data aligned based (current_cpd_ptr); dcl current_cpd_ptr pointer; dcl 1 parent_control_point_data /* the identified control point's parent's definition */ like control_point_data aligned based (control_point_data.parent); dcl 1 io_switches like control_point_data.io_switches aligned based (ios_ptr); dcl ios_ptr pointer; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl 1 decoded_control_point_id aligned, 2 stack_segno bit (18) unaligned, 2 unique_bits bit (18) unaligned; dcl 1 userproc_arg_list aligned, 2 header like arg_list.header, 2 arg_ptrs (1) pointer; dcl generate_call_flags bit (36) aligned; dcl prior_state fixed binary; dcl target_cpd_ptr pointer; dcl stack_idx fixed binary; dcl mask bit (36) aligned; dcl ( cpm_et_$already_started, cpm_et_$already_stopped, cpm_et_$cant_destroy_root, cpm_et_$cant_stop_root, cpm_et_$cant_wakeup_when_stopped, cpm_et_$control_point_not_found, cpm_et_$preferred_cant_be_stopped, cpm_et_$preferred_stack_overflow, cpm_et_$wakeup_ignored, error_table_$badcall, error_table_$out_of_sequence, error_table_$unimplemented_version ) fixed binary (35) external; dcl ( sys_info$all_valid_ips_mask, sys_info$comm_privilege, sys_info$dir_privilege, sys_info$ipc_privilege, sys_info$rcp_privilege, sys_info$ring1_privilege, sys_info$seg_privilege, sys_info$soos_privilege ) bit (36) aligned external; dcl continue_to_signal_ entry (fixed binary (35)); dcl ( cpm_alm_$call_overseer, cpm_alm_$call_generate_call ) entry (); dcl cpm_alm_$switch_stacks entry (pointer); dcl cpm_initialize_ entry (); dcl cpm_overseer_$cl_intermediary entry (bit (36) aligned); dcl cpm_overseer_$generate_call entry (pointer, entry (pointer), pointer); dcl ( cu_$get_cl_intermediary, cu_$set_cl_intermediary ) entry (entry (bit (36) aligned)); dcl get_privileges_ entry () returns (bit (36) aligned); dcl get_system_free_area_ entry () returns (pointer); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl hcs_$get_process_usage entry (pointer, fixed binary (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_stack_ptr entry (pointer); dcl ioa_$rsnnl entry () options (variable); dcl ipc_$reassign_call_channels entry (bit (36) aligned, bit (36) aligned); dcl ipc_$wait_for_an_event entry (); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl sub_err_ entry () options (variable); dcl ( system_privilege_$comm_priv_on, system_privilege_$comm_priv_off, system_privilege_$dir_priv_on, system_privilege_$dir_priv_off, system_privilege_$ipc_priv_on, system_privilege_$ipc_priv_off, system_privilege_$rcp_priv_on, system_privilege_$rcp_priv_off, system_privilege_$ring1_priv_on, system_privilege_$ring1_priv_off, system_privilege_$seg_priv_on, system_privilege_$seg_priv_off, system_privilege_$soos_priv_on, system_privilege_$soos_priv_off ) entry (fixed binary (35)); dcl (addr, addwordno, baseno, baseptr, binary, bit, bool, clock, codeptr, currentsize, hbound, length, mod, null, stackbaseptr, string, substr, unspec) builtin; dcl (any_other, cleanup) condition; %page; /* Create a new control point which is left in the STOPPED state */ create: entry (P_ccpi_ptr, P_control_point_id, P_code); if stackbaseptr () -> stack_header.cpm_enabled = ""b then do; /* first time in the process */ call cpm_initialize_ (); current_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr; end; ccpi_ptr = P_ccpi_ptr; /* copy input parameter for the internal procedure */ system_area_ptr = get_system_free_area_ (); mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); cpd_ptr = null (); /* for cleanup handler */ on cleanup begin; if cpd_ptr ^= null () then call destroy_control_point (cpd_ptr); end; call create_control_point (); /* does most of the work */ call push_call_frame (cpm_alm_$call_overseer, unspec (create_control_point_info), create_control_point_info.initproc.entry, create_control_point_info.initproc.info_ptr); P_control_point_id = control_point_data.id; P_code = 0; /* success */ return; /* Control arrives here iff an error occured while creating the control point */ ERROR_RETURN_FROM_CPM_$CREATE: if cpd_ptr ^= null () then call destroy_control_point (cpd_ptr); return; /* create_failure procedure has already set P_code */ %page; /* Destroy the specified control point -- This entrypoint queues a call to cpm_$call_self_destruct onto the target control point's stack and then forces the scheduler to run that control point. */ destroy: entry (P_control_point_id, P_code); call check_initialization ("cpm_$destroy"); /* aborts if not initialized */ call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the call entirely */ if cpd_ptr = addr (cpm_data_$root_control_point_data) then do; /* the root control point is sacred */ P_code = cpm_et_$cant_destroy_root; return; end; call generate_call (P_control_point_id, call_self_destruct, null (), P_code); return; /* This entrypoint is called by cpm_$destroy on the stack of the control point which is to be destroyed. It does a non-local goto to the control point's destroy label which has been initialized to cpm_$self_destruct. The non-local goto will unwind the entire stack allowing any cleanup handlers to be run. */ call_self_destruct: entry (); cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr; if codeptr (control_point_data.destroy) = codeptr (self_destruct) then go to control_point_data.destroy; /* transfer to the self_destruct entrypoint */ else call sub_err_ (cpm_et_$cant_destroy_root, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0); /* This entrypoint is not actually called but, rather, is the target of the non-local goto performed above by cpm_$call_self_destruct. This entrypoint will update the control point's state to DEAD and then invoke the scheduler to find something else to do. */ self_destruct: entry (); current_cpd_ptr, cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr; mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call update_state (CPM_DESTROYED); /* this control point is ready for destruction */ do while ("1"b); /* find something else to do */ call scheduler$find_runnable (); end; %page; /* Start the specified control point -- Places the control point into the READY state if it was STOPPED */ start: entry (P_control_point_id, P_code); call check_initialization ("cpm_$start"); call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the call entirely */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if control_point_data.state = CPM_STOPPED then do; call update_state (CPM_READY); P_code = 0; /* success */ end; else P_code = cpm_et_$already_started; /* it's already running or blocked */ return; /* Stop the specified control point -- Places the control point into the STOPPED state if it was READY or BLOCKED */ stop: entry (P_control_point_id, P_code); call check_initialization ("cpm_$stop"); call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the call entirely */ if cpd_ptr = addr (cpm_data_$root_control_point_data) then do; /* the root control point is sacred */ P_code = cpm_et_$cant_stop_root; return; end; mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if (control_point_data.state = CPM_READY) | (control_point_data.state = CPM_BLOCKED) then do; call update_state (CPM_STOPPED); P_code = 0; /* success */ end; else P_code = cpm_et_$already_stopped; /* it was stopped earlier */ return; %page; /* Block the current control point */ block: entry (); call check_initialization ("cpm_$block"); /* sets current_cpd_ptr */ cpd_ptr = current_cpd_ptr; mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if control_point_data.state = CPM_READY then call update_state (CPM_BLOCKED); return; /* Wakeup the specified control point -- Places the control point into the READY state if it was BLOCKED */ wakeup: entry (P_control_point_id, P_code); call check_initialization ("cpm_$wakeup"); call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the call entirely */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if control_point_data.state = CPM_BLOCKED then do; call update_state (CPM_READY); P_code = 0; /* success */ end; else if control_point_data.state = CPM_READY /* it's already awake */ then P_code = cpm_et_$wakeup_ignored; else P_code = cpm_et_$cant_wakeup_when_stopped; /* it's stopped and must be started first */ return; %page; /* Run the scheduler to find the highest priority ready control point and give control to said control point */ scheduler: entry (); call check_initialization ("cpm_$scheduler"); mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call scheduler$find_runnable (); return; %page; /* Return the user CL intermediary for a given control point -- The user CL intermediary is invoked by cpm_cl_intermediary_ (the control point CL intermediary) before actually establishing a new command level or stopping the control point. The user's intermediary can take whatever actions it desires and then inform the control point's intermediary either to return to the caller of cu_$cl (i.e., a "start" command) or to continue with the standard CL intermediary operation. */ get_user_cl_intermediary: entry (P_control_point_id, P_user_cl_intermediary, P_code); call check_initialization ("cpm_$get_user_cl_intermediary"); call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the call entirely */ P_user_cl_intermediary = control_point_data.user_cl_intermediary; P_code = 0; /* success */ return; /* Set the user CL intermediary for a given control point -- See the get_user_cl_intermediary entrypoint for a description of this feature. */ set_user_cl_intermediary: entry (P_control_point_id, P_user_cl_intermediary, P_code); call check_initialization ("cpm_$set_user_cl_intermediary"); call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the call entirely */ control_point_data.user_cl_intermediary = P_user_cl_intermediary; P_code = 0; /* success */ return; /* A "null" entry variable which should never be called -- Used as the initial value for user's CL intermediarys */ nulle: entry () options (variable); call sub_err_ (error_table_$badcall, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0, "The ""null"" entry value can not be invoked."); %page; /* Generate a call to the supplied user program in another control point */ generate_call: /* ... run it immediately */ entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code); generate_call_flags = CPM_GC_FORCE_READY; go to BEGIN_GENERATE_CALL; generate_call_preferred: /* ... run it immediately as the preferred control point */ entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code); generate_call_flags = CPM_GC_FORCE_READY | CPM_GC_PUSH_PREFERRED; go to BEGIN_GENERATE_CALL; generate_call_when_ready: /* ... run it when it next becomes READY */ entry (P_control_point_id, P_userproc, P_userproc_info_ptr, P_code); generate_call_flags = ""b; go to BEGIN_GENERATE_CALL; BEGIN_GENERATE_CALL: call check_initialization ("cpm_$generate_call"); call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the call entirely */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if current_cpd_ptr = cpd_ptr then do; /* The call is to take place in this control point -- Invoke the user's program directly but first place the control point into the same state as it would be in after releasing control via the scheduler. This action is necessary to insure that cpm_overseer_$generate_call will operate correctly. See the internal procedure switch_control_points for an explanation of the various operations performed here. */ call mask_ips_interrupts (mask); /* can't be interrupted */ current_control_point_data.ips_mask = mask; current_control_point_data.privileges = get_privileges_ (); call cu_$get_cl_intermediary (current_control_point_data.cl_intermediary); if current_control_point_data.swapped_switches | different_switches (current_cpd_ptr, cpm_data_$previous_control_point) then call save_io_switches (); /* save when cpm_overseer_$generate_call expects to restore */ if trace_$transaction_begin (1) /* disable tracing temporarily */ then ; unspec (userproc_arg_list.header) = ""b;/* setup the argument list for the user's procedure */ userproc_arg_list.header.call_type = Interseg_call_type; userproc_arg_list.header.arg_count = 1; userproc_arg_list.arg_ptrs (1) = addr (P_userproc_info_ptr); call cpm_overseer_$generate_call (addr (generate_call_flags), P_userproc, addr (userproc_arg_list)); /* make the call */ if trace_$transaction_end (1) /* turn tracing back on */ then ; if current_control_point_data.swapped_switches | different_switches (current_cpd_ptr, cpm_data_$previous_control_point) then call restore_io_switches (); /* restore our switches if we saved them above */ call cu_$set_cl_intermediary (current_control_point_data.cl_intermediary); call restore_privileges (); /* put our privileges and CL intermediary back */ mask = current_control_point_data.ips_mask; call unmask_ips_interrupts (mask); /* allow IPS interrupts again */ end; else do; /* The call is to take place in some other control point -- Push the necessary frame on its stack and run it immediately if requested. If we do schedule it immediately, we must also temporarily change this control point's state to READY so that, after the other control point finishes or blocks, this control point will be able to run and clean up the stack frames associated with this generate_call. */ call push_call_frame (cpm_alm_$call_generate_call, generate_call_flags, P_userproc, P_userproc_info_ptr); if generate_call_flags & CPM_GC_FORCE_READY then do; /* run the other control point right now */ prior_state = current_control_point_data.state; if current_control_point_data.state ^= CPM_READY then do; /* ... must make the current control point READY */ target_cpd_ptr = cpd_ptr; cpd_ptr = current_cpd_ptr; call update_state (CPM_READY); cpd_ptr = target_cpd_ptr; end; /*** A cleanup handler to restore the current control point state isn't necessary because, if a non-local goto occurs, it can only have happened while this control point was ready and, if we were blocked, we are about to punt the call to ipc_$block which put us into that state. */ call scheduler$run_specific_control_point (); if prior_state ^= CPM_READY then do; /* ... put the current control point back */ cpd_ptr = current_cpd_ptr; call update_state (prior_state); end; end; end; P_code = 0; /* success */ return; %page; /* Return the identity of the currently preferred control point -- The preferred control point is always given priority over all others whenever it is ready. In addition, cu_$cl will actually only invoke a new control point when called in the preferred control point. */ get_preferred_control_point: entry () returns (bit (36) aligned); call check_initialization ("cpm_$get_preferred_control_point"); if cpm_data_$preferred_control_point ^= null () then return (cpm_data_$preferred_control_point -> control_point_data.id); else return ((36)"0"b); /* none at present */ /* Set the preferred control point to the specified control point iff it isn't STOPPED */ set_preferred_control_point: entry (P_control_point_id, P_code); call check_initialization ("cpm_$set_preferred_control_point"); call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the entire call */ if control_point_data.state = CPM_STOPPED then do; P_code = cpm_et_$preferred_cant_be_stopped; return; end; mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if cpm_data_$preferred_control_point ^= cpd_ptr then do; /* actually switching control points */ call mask_ips_interrupts (mask); call switch_preferred_control_points (); call unmask_ips_interrupts (mask); end; P_code = 0; /* success */ return; %page; /* Push the preferred control point -- Saves the current preferred control point on the top of the stack and makes the specified control point preferred. If a control point is actually pushed, the P_pushed_preferred_control_point parameter will be set. That parameter must be used in subsequent calls to pop the stack. */ push_preferred_control_point: entry (P_control_point_id, P_pushed_preferred_control_point, P_code); call check_initialization ("cpm_$push_preferred_control_point"); P_pushed_preferred_control_point = "0"b; /* initialize this parameter for cleanup handlers */ call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the entire call */ if control_point_data.state = CPM_STOPPED then do; P_code = cpm_et_$preferred_cant_be_stopped; return; end; if cpm_data_$preferred_control_point_stack.stack_depth = hbound (cpm_data_$preferred_control_point_stack.cpd_ptr_stack, 1) then do; /* the stack is already full */ P_code = cpm_et_$preferred_stack_overflow; return; end; mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if cpm_data_$preferred_control_point ^= cpd_ptr then do; /* we're actually switching preferred control points */ call mask_ips_interrupts (mask); cpm_data_$preferred_control_point_stack.stack_depth, stack_idx = cpm_data_$preferred_control_point_stack.stack_depth + 1; cpm_data_$preferred_control_point_stack.cpd_ptr_stack (stack_idx) = cpm_data_$preferred_control_point; call switch_preferred_control_points (); P_pushed_preferred_control_point = "1"b; call unmask_ips_interrupts (mask); end; P_code = 0; /* success */ return; %page; /* Pop the preferred control point stack by making the top of the stack the new preferred control point if and only if the P_pushed_preferred_control_point parameter is "1"b. */ pop_preferred_control_point: entry (P_pushed_preferred_control_point); call check_initialization ("cpm_$pop_preferred_control_point"); mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); if P_pushed_preferred_control_point /* the caller did push it */ then do; call mask_ips_interrupts (mask); P_pushed_preferred_control_point = "0"b;/* once is enough, thank you */ if cpm_data_$preferred_control_point_stack.stack_depth > 0 then do; /* and there's something on the stack */ stack_idx = cpm_data_$preferred_control_point_stack.stack_depth; cpm_data_$preferred_control_point_stack.stack_depth = stack_idx - 1; cpd_ptr = cpm_data_$preferred_control_point_stack.cpd_ptr_stack (stack_idx); call switch_preferred_control_points (); end; call unmask_ips_interrupts (mask); end; return; %page; /* Return the usage meters recorded for a given control point */ get_control_point_meters: entry (P_control_point_id, P_cpma_ptr, P_code); call check_initialization ("cpm_$get_control_point_meters"); cpma_ptr = P_cpma_ptr; if control_point_meters_argument.version ^= CONTROL_POINT_METERS_ARGUMENT_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; call find_control_point (P_control_point_id); /* sets cpd_ptr or aborts the entire call */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call update_meters (current_control_point_data.meters, (0)); /* insure that all usage values are up-to-date */ control_point_meters_argument.meters = control_point_data.meters; control_point_meters_argument.number_wanted, control_point_meters_argument.number_can_return = MAX_NUMBER_OF_METERS; P_code = 0; /* success */ return; /* Return the usage meters recorded for the control point scheduler */ get_scheduler_meters: entry (P_cpma_ptr, P_code); call check_initialization ("cpm_$get_scheduler_meters"); cpma_ptr = P_cpma_ptr; if control_point_meters_argument.version ^= CONTROL_POINT_METERS_ARGUMENT_VERSION_1 then do; P_code = error_table_$unimplemented_version; return; end; control_point_meters_argument.meters = cpm_data_$global_meters.overhead; control_point_meters_argument.number_wanted, control_point_meters_argument.number_can_return = MAX_NUMBER_OF_METERS; P_code = 0; /* success */ return; %page; /* Validate that control point management is enabled */ check_initialization: procedure (p_entrypoint_name); dcl p_entrypoint_name character (*) parameter; if stackbaseptr () -> stack_header.cpm_enabled /* we are on: find the current control point's definition */ then current_cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr; else call sub_err_ (error_table_$out_of_sequence, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0, "At least one call to cpm_$create must preceed any call to ^a.", p_entrypoint_name); return; end check_initialization; /* Find the control_point_data for the request control point or abort the call completely */ find_control_point: procedure (p_control_point_id); dcl p_control_point_id bit (36) aligned parameter; string (decoded_control_point_id) = p_control_point_id; if cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) then do; /* the given ID does identify a valid stack */ cpd_ptr = baseptr (decoded_control_point_id.stack_segno) -> stack_header.cpm_data_ptr; if control_point_data.id = p_control_point_id then return; /* and the stack does indeed belong to that control point */ end; /*** Control arrives here iff the supplied control point ID is invalid */ P_code = cpm_et_$control_point_not_found; go to ERROR_RETURN_FROM_CPM_; end find_control_point; %page; /* Mask all IPS interrupts */ mask_ips_interrupts: procedure (p_mask); dcl p_mask bit (36) aligned parameter; call hcs_$set_ips_mask (""b, p_mask); end mask_ips_interrupts; /* Invoke mask_ips_interrupts -- This entrypoint exists to prevent making the mask_ips_interrupts internal procedure non-quick by invoking it from within an on unit or other non-quick procedure. */ mask_ips_interrupts_caller: entry (P_mask); call mask_ips_interrupts (P_mask); return; /* Restore the IPS mask to its state prior to calling mask_ips_interrupts */ unmask_ips_interrupts: procedure (p_mask); dcl p_mask bit (36) aligned parameter; if substr (p_mask, 36, 1) = "1"b then call hcs_$reset_ips_mask (p_mask, p_mask); end unmask_ips_interrupts; /* Invoke unmask_ips_interrupts -- This entrypoint exists to prevent making the unmask_ips_interrupts internal procedure non-quick by invoking it from within an on unit or other non-quick procedure. */ unmask_ips_interrupts_caller: entry (P_mask); call unmask_ips_interrupts (P_mask); return; /* The any_other handler established whenever we have masked IPS signals */ any_other_handler: procedure (); call unmask_ips_interrupts_caller (mask); call continue_to_signal_ ((0)); /* be sure the error gets through */ end any_other_handler; %page; /* Restore the current control point's system privileges -- We need not worry about access to system_privilege_ as we only call it when we actually discover that a privilege has changed and the only way to change privileges is to use the system_privilege_ gate itself. */ restore_privileges: procedure (); dcl current_privileges bit (36) aligned; current_privileges = get_privileges_ (); if current_control_point_data.privileges = current_privileges then return; /* privileges are already correct */ if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$comm_privilege then if current_control_point_data.privileges & sys_info$comm_privilege then call system_privilege_$comm_priv_on ((0)); else call system_privilege_$comm_priv_off ((0)); if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$dir_privilege then if current_control_point_data.privileges & sys_info$dir_privilege then call system_privilege_$dir_priv_on ((0)); else call system_privilege_$dir_priv_off ((0)); if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$ipc_privilege then if current_control_point_data.privileges & sys_info$ipc_privilege then call system_privilege_$ipc_priv_on ((0)); else call system_privilege_$ipc_priv_off ((0)); if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$rcp_privilege then if current_control_point_data.privileges & sys_info$rcp_privilege then call system_privilege_$rcp_priv_on ((0)); else call system_privilege_$rcp_priv_off ((0)); if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$ring1_privilege then if current_control_point_data.privileges & sys_info$ring1_privilege then call system_privilege_$ring1_priv_on ((0)); else call system_privilege_$ring1_priv_off ((0)); if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$seg_privilege then if current_control_point_data.privileges & sys_info$seg_privilege then call system_privilege_$seg_priv_on ((0)); else call system_privilege_$seg_priv_off ((0)); if bool (current_control_point_data.privileges, current_privileges, "0110"b) & sys_info$soos_privilege then if current_control_point_data.privileges & sys_info$soos_privilege then call system_privilege_$soos_priv_on ((0)); else call system_privilege_$soos_priv_off ((0)); return; end restore_privileges; %page; /* Save the current control point's standard I/O switches -- Always called with all IPS signals masked */ save_io_switches: procedure (); if current_control_point_data.swapped_switches then ios_ptr = addr (cpm_data_$root_control_point_data.io_switches); else ios_ptr = addr (current_control_point_data.io_switches); call iox_$move_attach (iox_$user_io, io_switches.user_io, (0)); call iox_$move_attach (iox_$user_input, io_switches.user_input, (0)); call iox_$move_attach (iox_$user_output, io_switches.user_output, (0)); call iox_$move_attach (iox_$error_output, io_switches.error_output, (0)); return; end save_io_switches; /* Restore the current control point's standard I/O switches -- Always called with all IPS signals masked */ restore_io_switches: procedure (); if current_control_point_data.swapped_switches then ios_ptr = addr (cpm_data_$root_control_point_data.io_switches); else ios_ptr = addr (current_control_point_data.io_switches); call iox_$move_attach (io_switches.user_io, iox_$user_io, (0)); call iox_$move_attach (io_switches.user_input, iox_$user_input, (0)); call iox_$move_attach (io_switches.user_output, iox_$user_output, (0)); call iox_$move_attach (io_switches.error_output, iox_$error_output, (0)); return; end restore_io_switches; /* Determines if the two specified control points use different sets of standard I/O switches */ different_switches: procedure (p_cpd_1_ptr, p_cpd_2_ptr) returns (bit (1) aligned); dcl 1 cpd_1 like control_point_data aligned based (p_cpd_1_ptr); dcl 1 cpd_2 like control_point_data aligned based (p_cpd_2_ptr); dcl (p_cpd_1_ptr, p_cpd_2_ptr) pointer parameter; if cpd_1.swapped_switches & cpd_2.swapped_switches then return ("0"b); /* both control points are using the root's switches */ else if cpd_1.group_id = cpd_2.group_id /* same group: they use the same switches ... */ then return (cpd_1.swapped_switches ^= cpd_2.swapped_switches); /* ... unless one is using the root's but not the other */ else if (cpd_1.swapped_switches & (cpd_2.group_id = cpm_data_$root_control_point_data.group_id)) | (cpd_2.swapped_switches & (cpd_1.group_id = cpm_data_$root_control_point_data.group_id)) then return ("0"b); /* different groups: but one is swapped to the other */ else return ("1"b); /* different groups really using different switches */ end different_switches; %page; /* The control point scheduler */ scheduler: procedure (); return; /* not used */ /* Run the control point at the top of the ready queue -- If there are no ready control points, wait for an IPC event to make one or more control points eligible. */ scheduler$find_runnable: entry (); call update_meters (current_control_point_data.meters, cpm_data_$global_meters.overhead.n_schedules); if cpm_data_$ready_queue.first = null () then do; /* nothing ready at present */ if (current_cpd_ptr ^= cpm_data_$preferred_control_point) & (cpm_data_$preferred_control_point ^= null ()) then if cpm_data_$preferred_control_point -> control_point_data.state = CPM_BLOCKED then do; /* ... preferred is blocked: better to hcs_$block in it */ cpd_ptr = cpm_data_$preferred_control_point; call switch_control_points (); end; do while (cpm_data_$ready_queue.first = null ()); call ipc_$wait_for_an_event (); /* ... we are preferred or he's not blocked: hcs_$block */ end; end; cpd_ptr = cpm_data_$ready_queue.first; /* run whoever's on top */ call switch_control_points (); /* THUNK! */ if cpm_data_$gc_control_points /* there are control points we can eliminate */ then call gc_dead_control_points (); call update_meters (cpm_data_$global_meters.overhead, current_control_point_data.meters.n_schedules); return; /* Run the selected control point */ scheduler$run_specific_control_point: entry (); call update_meters (current_control_point_data.meters, cpm_data_$global_meters.overhead.n_schedules); call switch_control_points (); /* THUNK! */ if cpm_data_$gc_control_points /* there are control points we can eliminate */ then call gc_dead_control_points (); call update_meters (cpm_data_$global_meters.overhead, current_control_point_data.meters.n_schedules); return; %page; /* Actual code to switch from one control point to another */ switch_control_points: procedure (); if current_cpd_ptr = cpd_ptr /* asked to run ourselves -- nothing to do */ then return; call mask_ips_interrupts (mask); /* can't be interrupted during this process */ /* Save the present IPS mask, system privileges, and CL intermediary in the control point's definition -- Each control point is permitted to manipulate these per-process values as if it were the only control point in the process. Therefore, we must save and restore these values whenever we switch control points to insure that each control point's settings of these mechansims will be undisturbed by other control points */ current_control_point_data.ips_mask = mask; current_control_point_data.privileges = get_privileges_ (); call cu_$get_cl_intermediary (current_control_point_data.cl_intermediary); /* Save our standard I/O switches if they are not the same set as used by the control point about to be run */ if different_switches (current_cpd_ptr, cpd_ptr) then call save_io_switches (); /* Switch Stacks -- We must inform inform ring-0 of the change so it will properly signal faults, IPS interrupts, etc. */ cpm_data_$previous_control_point = current_cpd_ptr; if trace_$transaction_begin (1) /* disable tracing -- let the new control point ... */ then ; /* ... reenable it if appropriate */ call hcs_$set_stack_ptr (control_point_data.stack_ptr); call cpm_alm_$switch_stacks (control_point_data.stack_ptr); /*** Immediately after the above call, control returns to this point in the new control point we chose to run. Consequently, current_control_point_data now refers to the control point referenced above as control_point_data and the control point referenced above as current_control_point_data is now referenced through cpm_data_$previous_control_point. */ if trace_$transaction_end (1) /* reenable tracing if it was running in this control point */ then ; /* Restore our I/O switches */ if different_switches (current_cpd_ptr, cpm_data_$previous_control_point) then call restore_io_switches (); /* Restore our saved CL intermediary, system privileges, and IPS mask */ call cu_$set_cl_intermediary (current_control_point_data.cl_intermediary); call restore_privileges (); mask = current_control_point_data.ips_mask; call unmask_ips_interrupts (mask); /* let IPS through again */ return; end switch_control_points; %page; /* Finish the destruction of any dead control points */ gc_dead_control_points: procedure (); system_area_ptr = get_system_free_area_ (); /* needed by destroy_control_point */ call gc_worker (addr (cpm_data_$root_control_point_data)); cpm_data_$gc_control_points = "0"b; /* we've done all we can for now */ return; /* Actually walks the tree of control points looking for those which can be eliminated */ gc_worker: procedure (p_cpd_ptr) recursive; dcl 1 p_control_point_data like control_point_data aligned based (p_cpd_ptr); dcl p_cpd_ptr pointer parameter; dcl 1 a_control_point_data like control_point_data aligned based (a_cpd_ptr); dcl a_cpd_ptr pointer; dcl next_cpd_ptr pointer; /*** Walk the control point's list of children and flush any of them that are dead */ do a_cpd_ptr = p_control_point_data.first_child repeat (next_cpd_ptr) while (a_cpd_ptr ^= null ()); next_cpd_ptr = a_control_point_data.next_peer; call gc_worker (a_cpd_ptr); end; /*** If this control point is dead and has no children, eliminate it */ if (p_control_point_data.state = CPM_DESTROYED) & (p_control_point_data.first_child = null ()) then call destroy_control_point (p_cpd_ptr); return; end gc_worker; end gc_dead_control_points; end scheduler; %page; /* Update the meters for a given control point or for the scheduler itself */ update_meters: procedure (p_meters, p_n_schedules); dcl 1 p_meters like control_point_meters aligned parameter; dcl p_n_schedules fixed binary parameter; dcl 1 local_usage like process_usage aligned; dcl local_real_time fixed binary (71); local_real_time = clock (); /* to compute real-time change */ local_usage.number_wanted = MAX_NUMBER_OF_METERS; /* get all the meters */ call hcs_$get_process_usage (addr (local_usage), (0)); call mask_ips_interrupts (mask); /* update them uniterruptably */ p_n_schedules = p_n_schedules + 1; /* count the scheduling */ p_meters.real_time = p_meters.real_time + local_real_time - cpm_data_$global_meters.last_meters.real_time; p_meters.usage = p_meters.usage + local_usage - cpm_data_$global_meters.last_meters.usage; cpm_data_$global_meters.last_meters.real_time = local_real_time; cpm_data_$global_meters.last_meters.usage = local_usage; call unmask_ips_interrupts (mask); return; end update_meters; %page; /* Changes the state of a control point */ update_state: procedure (p_new_state); dcl p_new_state fixed binary parameter; if p_new_state = control_point_data.state /* the control point is already in the requested state */ then return; call mask_ips_interrupts (mask); if control_point_data.preferred & ((p_new_state = CPM_DESTROYED) | (p_new_state = CPM_STOPPED)) then do; /* only READY or BLOCKED control points can be preferred */ call set_preferred_control_point (cpm_data_$root_control_point_data.id, (0)); end; /* ... so try to switch it to the root control point */ if control_point_data.state = CPM_READY /* it's about to become not ready: remove it from the queue */ then call remove_from_ready_queue (); control_point_data.state = p_new_state; if control_point_data.state = CPM_READY /* it's been made ready: stick it into the ready queue */ then call insert_into_ready_queue (); else if control_point_data.state = CPM_DESTROYED /* it's been killed */ then do; call ipc_$reassign_call_channels (control_point_data.id, parent_control_point_data.id); string (decoded_control_point_id) = control_point_data.id; cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) = "0"b; cpm_data_$gc_control_points = "1"b; /* ... we need to cleanup when next possible */ cpm_data_$n_control_points = cpm_data_$n_control_points - 1; end; call unmask_ips_interrupts (mask); return; end update_state; /* Invoke update_state -- Called by cpm_overseer_$generate_call */ update_state_caller: entry (P_cpd_ptr, P_new_state); mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); cpd_ptr = P_cpd_ptr; call update_state (P_new_state); return; %page; /* Sets the preferred control point -- Rethreads the ready queue to reflect the change in priority of the old and new preferred control points */ switch_preferred_control_points: procedure (); dcl old_preferred_cpd_ptr pointer; control_point_data.preferred = "1"b; /* this control point is now preferred */ if control_point_data.state = CPM_READY then do; /* it's ready: rethread it to the top of the queue */ call remove_from_ready_queue (); call insert_into_ready_queue (); end; /* Actually switch preferred control points */ old_preferred_cpd_ptr = cpm_data_$preferred_control_point; cpm_data_$preferred_control_point = cpd_ptr; /* establish the new preferred control point */ cpd_ptr = old_preferred_cpd_ptr; /* control_point_data now refers to the old preferred control point */ control_point_data.preferred = "0"b; /* it's no longer special */ if control_point_data.state = CPM_READY then do; /* rethread to reflect its lowered priority */ call remove_from_ready_queue (); call insert_into_ready_queue (); end; return; end switch_preferred_control_points; %page; /* Inserts a control point into the ready queue -- This procedure expects its caller to have masked IPS interrupts. */ insert_into_ready_queue: procedure (); dcl (prev_cpd_ptr, next_cpd_ptr) pointer; prev_cpd_ptr = null (); /* assume it goes at the beginning of the queue */ next_cpd_ptr = cpm_data_$ready_queue.first; if control_point_data.preferred /* it should always have first priority */ then go to INSERT_INTO_THE_LIST; do next_cpd_ptr = cpm_data_$ready_queue.first repeat (next_cpd_ptr -> control_point_data.next_ready) while (next_cpd_ptr ^= null ()); if (next_cpd_ptr -> control_point_data.priority > control_point_data.priority) & ^next_cpd_ptr -> control_point_data.preferred then go to INSERT_INTO_THE_LIST; /* next one is lower priority and not preferred */ else prev_cpd_ptr = next_cpd_ptr; end; /* add to the end of the queue if we fall through */ INSERT_INTO_THE_LIST: if prev_cpd_ptr = null () /* put it at the top of the queue */ then cpm_data_$ready_queue.first = cpd_ptr; else prev_cpd_ptr -> control_point_data.next_ready = cpd_ptr; if next_cpd_ptr = null () /* put it at the end of the queue */ then cpm_data_$ready_queue.last = cpd_ptr; else next_cpd_ptr -> control_point_data.prev_ready = cpd_ptr; control_point_data.prev_ready = prev_cpd_ptr; control_point_data.next_ready = next_cpd_ptr; return; end insert_into_ready_queue; /* Removes a control point from the ready queue -- This procedure expects its caller to have masked IPS interrupts. */ remove_from_ready_queue: procedure (); if control_point_data.prev_ready = null () /* we are at the top of the queue */ then cpm_data_$ready_queue.first = control_point_data.next_ready; else control_point_data.prev_ready -> control_point_data.next_ready = control_point_data.next_ready; if control_point_data.next_ready = null () /* we are at the bottom of the queue */ then cpm_data_$ready_queue.last = control_point_data.prev_ready; else control_point_data.next_ready -> control_point_data.prev_ready = control_point_data.prev_ready; control_point_data.ready_queue = null (); /* complete the removal process */ return; end remove_from_ready_queue; %page; /* Creates a new control point */ create_control_point: procedure () options (non_quick); dcl code fixed binary (35); if create_control_point_info.version ^= CREATE_CONTROL_POINT_INFO_VERSION_1 then call create_failure (error_table_$unimplemented_version); call mask_ips_interrupts_caller (mask); /* avoid interrupts until we can clean up properly */ allocate control_point_data in (system_area) set (cpd_ptr); control_point_data.stack_ptr, control_point_data.parent, control_point_data.peers = null (); call unmask_ips_interrupts_caller (mask); /* the cleanup handler will now work OK */ call get_temp_segment_ (cpm_data_$subsystem_name, control_point_data.stack_ptr, code); if code ^= 0 then call create_failure (code); /* Setup most of the control point's data */ decoded_control_point_id.stack_segno = baseno (control_point_data.stack_ptr); decoded_control_point_id.unique_bits = substr (bit (clock (), 71), 54, 18); control_point_data.id = string (decoded_control_point_id); control_point_data.state = CPM_STOPPED; /* the user must start it */ control_point_data.priority = create_control_point_info.priority; control_point_data.preferred = "0"b; /* it's an ordinary control point */ control_point_data.last_frame_ptr = null (); /* cpm_alm_$switch_stacks hasn't been used yet */ if create_control_point_info.independent then control_point_data.parent = addr (cpm_data_$root_control_point_data); else control_point_data.parent = stackbaseptr () -> stack_header.cpm_data_ptr; control_point_data.peers, /* we haven't threaded it into any lists yet */ control_point_data.children, control_point_data.ready_queue = null (); if create_control_point_info.user_cl_intermediary_given then control_point_data.user_cl_intermediary = create_control_point_info.user_cl_intermediary; else control_point_data.user_cl_intermediary = nulle; control_point_data.comment = create_control_point_info.comment; control_point_data.ips_mask = sys_info$all_valid_ips_mask; substr (control_point_data.ips_mask, 36) = "1"b; /* start with all IPS interrupts enabled */ control_point_data.privileges = ""b; /* start with no privileges */ control_point_data.cl_intermediary = cpm_overseer_$cl_intermediary; /* start with the "standard" CL intermediary */ control_point_data.io_switches = parent_control_point_data.io_switches; control_point_data.group_id = parent_control_point_data.group_id; /* we'll share our parent's switches until we've run once */ control_point_data.meters = 0; /* hasn't been used yet */ /* Initialize the new control point's stack by copying its parent's stack header */ call mask_ips_interrupts_caller (mask); /* the rest of this operation must not be interrupted */ if trace_$transaction_begin (1) then ; /* new stack should have standard operator pointers */ control_point_data.stack_ptr -> stack_header = parent_control_point_data.stack_ptr -> stack_header; control_point_data.stack_ptr -> stack_header.stack_begin_ptr, control_point_data.stack_ptr -> stack_header.stack_end_ptr = addwordno (control_point_data.stack_ptr, currentsize (control_point_data.stack_ptr -> stack_header)); control_point_data.stack_ptr -> stack_header.cpm_data_ptr = cpd_ptr; control_point_data.stack_ptr -> stack_header.cpm_enabled = substr(control_point_data.id,1,length(stack_header.cpm_enabled)); unspec (control_point_data.stack_ptr -> stack_header.trace) = ""b; if trace_$transaction_end (1) then ; control_point_data.destroy = cv_entry_to_label_ (self_destruct); /* Thread this control point into its parent's children chain */ if parent_control_point_data.first_child = null () then do; /* new control point is the parent's first child */ parent_control_point_data.first_child = cpd_ptr; control_point_data.prev_peer = null (); end; else do; /* parent has several other children already */ parent_control_point_data.last_child -> control_point_data.next_peer = cpd_ptr; control_point_data.prev_peer = parent_control_point_data.last_child; end; control_point_data.next_peer = null (); parent_control_point_data.last_child = cpd_ptr; cpm_data_$valid_control_points.map (binary (decoded_control_point_id.stack_segno, 18, 0)) = "1"b; cpm_data_$n_control_points = cpm_data_$n_control_points + 1; call unmask_ips_interrupts_caller (mask); return; /* Reports an error during control point creation to our caller */ create_failure: procedure (p_code); dcl p_code fixed binary (35) parameter; P_code = p_code; go to ERROR_RETURN_FROM_CPM_$CREATE; end create_failure; /* Converts an entry variable into a label variable which will unwind the stack */ cv_entry_to_label_: procedure (p_entry) returns (label variable); dcl p_entry entry variable parameter; dcl a_label label variable; dcl 1 a_label_decoded aligned based (addr (a_label)), 2 code_ptr pointer, 2 environment_ptr pointer; a_label_decoded.code_ptr = codeptr (p_entry); a_label_decoded.environment_ptr = control_point_data.stack_ptr -> stack_header.stack_begin_ptr; /* will unwind the stack to its first frame */ return (a_label); end cv_entry_to_label_; end create_control_point; %page; /* Destroys an old control point -- This procedure is only called after all the control point's children have been destroyed. It is also called during the creation of a control point if an error occurs after the control point is partially created. */ destroy_control_point: procedure (p_cpd_ptr); dcl p_cpd_ptr pointer parameter; dcl 1 p_control_point_data like control_point_data aligned based (p_cpd_ptr); dcl 1 p_parent_control_point_data like control_point_data aligned based (p_control_point_data.parent); /* Remove the dead control point from its parent's children chain */ if p_control_point_data.parent ^= null () then do; /* there's a parent defined */ p_parent_control_point_data.meters = p_parent_control_point_data.meters + p_control_point_data.meters; call mask_ips_interrupts_caller (mask); /* prevent interrupts while rechaining */ /*** Check that the parent knows of the control point before rechaining -- This check is only necessary if the control point's peer chain pointers are null as this could indicate that the control point hadn't been chained before it was destroyed. */ if p_control_point_data.prev_peer = null () then do; /* it might be the parent's first child */ if p_parent_control_point_data.first_child = p_cpd_ptr then p_parent_control_point_data.first_child = p_control_point_data.next_peer; end; else p_control_point_data.prev_peer -> control_point_data.next_peer = p_control_point_data.next_peer; if p_control_point_data.next_peer = null () then do; /* it might be the parent's last child */ if p_parent_control_point_data.last_child = p_cpd_ptr then p_parent_control_point_data.last_child = p_control_point_data.prev_peer; end; else p_control_point_data.next_peer -> control_point_data.prev_peer = p_control_point_data.prev_peer; p_control_point_data.parent, p_control_point_data.peers = null (); call unmask_ips_interrupts_caller (mask); end; /* the parent no longers knows about us */ /* Destroy the dead control point's stack */ if p_control_point_data.stack_ptr ^= null () then do; /* its stack exists */ call release_temp_segment_ (cpm_data_$subsystem_name, p_control_point_data.stack_ptr, (0)); p_control_point_data.stack_ptr = null (); end; /* Complete the destruction of the control point */ free p_control_point_data in (system_area); p_cpd_ptr = null (); /* its destroyed */ return; end destroy_control_point; %page; /* Creates a stack frame on the given stack to call the specified entrypoint -- The stack frame is initialized appropriately so that, when cpm_alm_$switch_stacks returns on the new stack, the entrypoint specified by the p_caller parameter will be invoked. As this entrypoint is invoked by a return with its stack frame already extant, it must be an ALM routine which then calls the actual PL/I caller entrypoint. The correspondence between the ALM and PL/I procedures follows: ALM entrypoint PL/I entrypoint cpm_alm_$call_overseer cpm_overseer_$overseer cpm_alm_$call_generate_call cpm_overseer_$generate_call The PL/I entrypoint prepares the environment according to the data in the p_caller_info parameter and then invokes the entrypoint specified as the p_callee parameter passing it the p_callee_info_ptr parameter as its single parameter. When the callee entrypoint returns, the PL/I entrypoint returns to the ALM entrypoint. The cpm_alm_$call_cpm_overseer_ entrypoint will then transfer to cpm_$self_destruct to destroy the control point; the cpm_alm_$call_cpm_generate_call_ entrypoint will then return to the prior stack frame on the stack which is normally a frame owned by cpm_$scheduler. */ push_call_frame: procedure (p_caller, p_caller_info, p_callee, p_callee_info_ptr) options (non_quick); dcl p_caller entry () variable parameter; dcl p_caller_info bit (*) aligned parameter; dcl p_callee entry (pointer) variable parameter; dcl p_callee_info_ptr pointer parameter; dcl 1 call_frame aligned based (sp), /* the stack frame for p_caller */ 2 header like stack_frame aligned, /* ... standard stack frame header */ 2 arguments, /* ... arguments to either p_callee or p_caller's PL/I */ 3 caller_info_ptr pointer, 3 callee entry (pointer) variable, 3 callee_arg_list_ptr pointer, 3 callee_info_ptr pointer, 2 caller_arg_list, /* ... the argument list for p_caller's PL/I counterpart */ 3 header like arg_list.header, 3 arg_ptrs (3) pointer, 2 callee_arg_list, /* ... the argument list for p_callee */ 3 header like arg_list.header, 3 arg_ptrs (1) pointer, 2 caller_info bit (length (p_caller_info)) aligned; call mask_ips_interrupts_caller (mask); /* creating the frame must not be interrupted */ sb = control_point_data.stack_ptr; /* find the target stack ... */ sp = stack_header.stack_end_ptr; /* ... and the place to lay down the caller frame */ stack_frame.return_ptr = codeptr (p_caller); /* where to begin execution after cpm_alm_$switch_stacks */ stack_frame.translator_id = TRANSLATOR_ID_ALM; call_frame.caller_info = p_caller_info; /* copy the parameters into the frame */ call_frame.caller_info_ptr = addr (call_frame.caller_info); call_frame.callee = p_callee; call_frame.callee_info_ptr = p_callee_info_ptr; stack_frame.arg_ptr = addr (call_frame.caller_arg_list); /* record where this frame's argument list may be found */ unspec (call_frame.caller_arg_list.header) = ""b; /* setup the caller's argument list */ call_frame.caller_arg_list.header.call_type = Interseg_call_type; call_frame.caller_arg_list.header.arg_count = 3; /* caller_flags, callee, callee_info_ptr */ call_frame.caller_arg_list.arg_ptrs (1) = addr (call_frame.caller_info_ptr); call_frame.caller_arg_list.arg_ptrs (2) = addr (call_frame.callee); call_frame.caller_arg_list.arg_ptrs (3) = addr (call_frame.callee_arg_list_ptr); call_frame.callee_arg_list_ptr = addr (call_frame.callee_arg_list); /* record where the callee's argument list can be found */ unspec (call_frame.callee_arg_list.header) = ""b; /* setup the callee's argument list */ call_frame.callee_arg_list.header.call_type = Interseg_call_type; call_frame.callee_arg_list.header.arg_count = 1; call_frame.callee_arg_list.arg_ptrs (1) = addr (call_frame.callee_info_ptr); stack_frame.prev_sp = control_point_data.last_frame_ptr; /* when this call is done: return to the scheduler */ control_point_data.last_frame_ptr = sp; /* have cpm_alm_$switch_stacks return to this new frame */ stack_frame.next_sp, /* "push" the frame into existence */ /* Note that we guarantee that the next stack frame */ /* goes on a mod 16-word boundary. */ stack_header.stack_end_ptr = addwordno (sp, (currentsize (call_frame) + 16 - mod (currentsize (call_frame), 16))); call unmask_ips_interrupts_caller (mask); return; end push_call_frame; /* format: off */ %page; %include cpm_data_; %page; %include cpm_internal_data; %page; %include cpm_control_point_data; %include cpm_ctrl_pt_meters; %include process_usage; %page; %include cpm_create_ctrl_pt_info; %page; %include cpm_generate_call_flags; %page; %include stack_header; %page; %include stack_frame; %page; %include arg_list; %page; %include iox_dcls; %page; %include sub_err_flags; %page; %include trace_interface; /* format: on */ end cpm_;  cpm_alm_.alm 11/04/86 1557.5rew 11/04/86 1031.4 33966 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " ALM utilities used by the Control Point Manager " HISTORY COMMENTS: " 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), " audit(86-10-22,Fawcett), install(86-11-03,MR12.0-1206): " Written to support control point management in March 1985 by G. Palter " based on C. Hornig's task_alm_. " END HISTORY COMMENTS name cpm_alm_ " Switch execution to the specified stack -- Control on the new stack is given " to the program which owns the last frame of said stack as saved in " its control_point_data at the point identified in the frame's return_ptr " dcl cpm_alm_$switch_stacks entry (pointer); " call cpm_alm_$switch_stacks (new_stack_base_ptr); segdef switch_stacks switch_stacks: inhibit on "<+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+><+> epbp7 pr6|0 " pr7 <- stackbaseptr () epp2 pr7|stack_header.cpm_data_ptr,* " pr2 <- addr (current control_point_data) spri6 pr2|cpd.last_frame_ptr " remember where to resume control later epp2 pr0|2,* " pr7 <- new_stack_base_ptr epbp7 pr2|0,* " ... epp2 pr7|stack_header.cpm_data_ptr,* " pr2 <- addr (new control_point_data) epp6 pr2|cpd.last_frame_ptr,* " pr6 <- addr (last frame in new ctrl pt) inhibit off "<-><-><-><-><-><-><-><-><-><-><-><-><-><-><-><-><-> short_return " and give up control to the new stack " " Invoke cpm_overseer_$overseer -- This entrypoint is the first one invoked in a new control " point. It completes the setup of this stack frame and then calls cpm_overseer_ to " complete the setup of the control point's environment and to start the user's initial " procedure. When the user's initial procedure returns to cpm_overseer_$overseer, it " returns to this entrypoint which then transfers to cpm_$self_destruct to destroy this " control point. entry overseer segdef call_overseer overseer: call_overseer: getlp " save our linkage pointer spri4 pr6|stack_frame.lp_ptr epp2 overseer " claim that we are cpm_alm_$overseer spri2 pr6|stack_frame.entry_ptr epp0 pr6|stack_frame.arg_ptr,* " find cpm_caller_'s argument list epbp7 pr6|0 " set the stack base short_call cpm_overseer_$overseer " run the initial procedure tra cpm_$self_destruct " kill this control point " " Invoke cpm_overseer_$generate_call -- This entrypoint is the first one invoked to execute " an entrypoint in this control point as requested by another control point. This " entrypoint completes the setup of this stack frame and then calls " cpm_overseer_$generate_call to actually invoke the user's entrypoint. When the user's " entrypoint returns to cpm_overseer_$generate_call, it returns to this entrypoint which " then returns to the previous frame on this stack. That frame usually belongs to " cpm_$scheduler which causes the scheduling of control points to continue. entry generate_call segdef call_generate_call generate_call: call_generate_call: getlp " save our linkage pointer spri4 pr6|stack_frame.lp_ptr epp2 generate_call " claim that we are cpm_alm_$generate_call spri2 pr6|stack_frame.entry_ptr epp0 pr6|stack_frame.arg_ptr,* " find cpm_caller_'s argument list epbp7 pr6|0 " set the stack base short_call cpm_overseer_$generate_call " invoke the procedure return " return to the scheduler (most likely) " include stack_header " include stack_frame " include cpm_control_point_data end  cpm_data_.cds 11/04/86 1557.5rew 11/04/86 1031.4 29700 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: off */ /* Control Point Manager constants and static data */ /* HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206): Written to support control point management in March 1985 by G. Palter based on C. Hornig's task_init_. END HISTORY COMMENTS */ /* format: style3,linecom */ cpm_data_: procedure () options (variable); dcl 1 cds_arguments like cds_args aligned; dcl code fixed binary (35); dcl CPM_DATA_ character (32) static options (constant) initial ("cpm_data_"); dcl com_err_ entry () options (variable); dcl create_data_segment_ entry (pointer, fixed binary (35)); dcl (addr, currentsize, null, string, unspec) builtin; /* Constants (see cpm_internal_data.incl.pl1 for explanations) */ dcl 1 cpm_constants aligned, 2 subsystem_name character (32) unaligned; /* Static data (see cpm_internal_data.incl.pl1 for explanations) */ dcl 1 cpm_static aligned, 2 root_control_point_data like control_point_data aligned, 2 n_control_points fixed binary, 2 gc_control_points bit (1) aligned, 2 saved_cl_intermediary entry (bit (36) aligned) variable, 2 preferred_control_point pointer, 2 preferred_control_point_stack aligned, 3 stack_depth fixed binary, 3 pad bit (36) aligned, 3 cpd_ptr_stack (16) pointer, 2 ready_queue aligned, 3 first pointer, 3 last pointer, 2 previous_control_point pointer, 2 valid_control_points aligned, 3 map (0:4095) bit (1) unaligned, 2 global_meters aligned, 3 overhead like control_point_data.meters, 3 last_meters like control_point_data.meters; %page; /* Define the constants */ cpm_constants.subsystem_name = "Control point manager"; /* Initialize the static data as best as possible */ unspec (cpm_static) = ""b; /* cpm_initialize_ will actually set this stuff up */ cpm_static.n_control_points = 1; /* ... except this value should always be valid */ /* Invoke create_data_segment_ */ cds_arguments.sections (1).p = addr (cpm_constants); cds_arguments.sections (1).len = currentsize (cpm_constants); cds_arguments.sections (1).struct_name = "cpm_constants"; cds_arguments.sections (2).p = addr (cpm_static); cds_arguments.sections (2).len = currentsize (cpm_static); cds_arguments.sections (2).struct_name = "cpm_static"; cds_arguments.seg_name = CPM_DATA_; cds_arguments.num_exclude_names = 0; cds_arguments.exclude_array_ptr = null (); string (cds_arguments.switches) = ""b; cds_arguments.have_text = "1"b; cds_arguments.have_static = "1"b; call create_data_segment_ (addr (cds_arguments), code); if code ^= 0 then call com_err_ (code, CPM_DATA_); return; /* format: off */ %page; %include cpm_control_point_data; %include cpm_ctrl_pt_meters; %include process_usage; %page; %include cds_args; /* format: on */ end cpm_data_;  cpm_et_.alm 11/04/86 1557.6rew 11/04/86 1031.4 13941 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1985 * " * * " *********************************************************** " Error table for control point management " HISTORY COMMENTS: " 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), " audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206): " Written to support control point management in March 1985 by G. Palter. " END HISTORY COMMENTS name cpm_et_ include et_macros et cpm_et_ ec already_started,started, (The specified control point has already been started.) ec already_stopped,stopped, (The specified control point has already been stopped.) ec cant_destroy_root,rootctpt, (The root control point can not be destroyed.) ec cant_stop_root,rootctpt, (The root control point can not be stopped.) ec cant_wakeup_when_stopped,stopped, (A wakeup can not be sent to a stopped control point.) ec control_point_not_found,noctrlpt, (The requested control point does not exist in this process.) ec preferred_cant_be_stopped,stopped, (A stopped control point can not be selected to be the preferred control point.) ec preferred_stack_overflow,nopush, (The stack of preferred control points is full.) ec wakeup_ignored,started, (The wakeup was ignored as the control point is currently ready.) end  cpm_initialize_.pl1 07/05/88 1441.2rew 07/05/88 1426.2 91413 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: off */ /* Per-process initialization of the Multics Control Point Manager (cpm_) */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206): Written to support control point management in March 1985 by G. Palter based on C. Hornig's task_init_. 2) change(88-04-25,Farley), approve(88-05-26,MCR7901), audit(88-06-07,GWMay), install(88-07-05,MR12.2-1053): Changed RNT area expansion code to use stack_header.rnt_ptr directly, instead of copying to the automatic rntp variable. The RNT area can move and using the stack_header is the only sure way of referencing the correct location. Also inhibit interrupts during this period. END HISTORY COMMENTS */ /* format: style3,linecom */ cpm_initialize_: procedure (); dcl 1 local_ai aligned like area_info; dcl control_point_id_string character (12); dcl code fixed binary (35); dcl new_rnt_area area (local_ai.size) based (local_ai.areap); dcl old_rnt_area area (old_area_size) based (old_areap); dcl rnt_area area (stack_header.rnt_ptr -> rnt.rnt_area_size) based (stack_header.rnt_ptr -> rnt.areap); dcl new_rntp pointer; dcl old_areap pointer; dcl old_area_size fixed bin (18); dcl old_mask bit (36) aligned; dcl system_area area based (system_area_ptr); dcl system_area_ptr pointer; dcl sys_info$max_seg_size fixed binary (19) external; dcl cpm_$nulle entry () options (variable); dcl cpm_overseer_$cl_intermediary entry (bit (36) aligned); dcl ( cu_$get_cl_intermediary, cu_$set_cl_intermediary ) entry (entry (bit (36) aligned)); dcl define_area_ entry (pointer, fixed binary (35)); dcl get_privileges_ entry () returns (bit (36) aligned); dcl get_ring_ entry () returns (fixed binary (3)); dcl get_system_free_area_ entry () returns (pointer); dcl hcs_$get_ips_mask entry (bit (36) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$grow_lot entry (fixed binary (3)); dcl ioa_$rsnnl entry () options (variable); dcl sub_err_ entry () options (variable); dcl user_info_$usage_data entry (fixed binary, fixed binary (71), fixed binary (71), fixed binary (71), fixed binary (71), fixed binary (71)); dcl (addr, addwordno, baseno, binary, empty, length, null, stackbaseptr, string, substr, unspec, wordno) builtin; dcl cleanup condition; %page; /* cpm_initialize_: entry (); */ sb = stackbaseptr (); system_area_ptr = get_system_free_area_ (); /* Grow the LOT to its maximum size -- Otherwise, when ring 0 grows the LOT, it will only update the LOT and ISOT pointers in the header of the stack which happens to be running at the time. The stacks of the other control points would, as a result, contain incorrect LOT and ISOT pointers and the process would not be long for the world */ if stack_header.cur_lot_size < stack_header.max_lot_size then call hcs_$grow_lot (get_ring_ ()); /* Grow the RNT to a full segment for the same reasons as above */ if stack_header.rnt_ptr -> rnt.rnt_area_size < sys_info$max_seg_size then do; old_mask = "0"b; on cleanup begin; if old_mask then call hcs_$reset_ips_mask (old_mask, old_mask); end; call hcs_$set_ips_mask ("0"b, old_mask); local_ai.version = area_info_version_1; string (local_ai.control) = ""b; local_ai.zero_on_free = "1"b; /* set control flags expected by ring 0 */ local_ai.system = "1"b; local_ai.owner = "RNT"; local_ai.size = sys_info$max_seg_size; local_ai.areap = null (); /* let define_area_ find us a segment */ call define_area_ (addr (local_ai), code); if code ^= 0 then call sub_err_ (code, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0, "Growing the RNT."); old_area_size = stack_header.rnt_ptr -> rnt.rnt_area_size; new_rnt_area = rnt_area; /* copy the RNT contents to its new area */ if old_area_size ^= stack_header.rnt_ptr -> rnt.rnt_area_size then do; /* Ooops, the RNT grew/moved while copying */ new_rnt_area = empty; new_rnt_area = rnt_area; end; new_rntp = addwordno (local_ai.areap, relwordno (stack_header.rnt_ptr, stack_header.rnt_ptr -> rnt.areap)); new_rntp -> rnt.srulep = addwordno (local_ai.areap, relwordno (stack_header.rnt_ptr -> rnt.srulep, stack_header.rnt_ptr -> rnt.areap)); new_rntp -> rnt.areap = local_ai.areap; new_rntp -> rnt.rnt_area_size = local_ai.size; old_areap = stack_header.rnt_ptr -> rnt.areap; old_area_size = stack_header.rnt_ptr -> rnt.rnt_area_size; stack_header.rnt_ptr = new_rntp; /* switch to the new RNT ... */ free old_rnt_area in (system_area); /* ... and get rid of the old one */ call hcs_$reset_ips_mask (old_mask, old_mask); revert cleanup; end; /* Setup the definition of the root control point -- The root control point is the control point which uses the "normal" stack in the current ring */ cpd_ptr = addr (cpm_data_$root_control_point_data); control_point_data.id, /* generate the standard unique ID */ control_point_data.group_id = baseno (sb); control_point_data.state = CPM_READY; /* it must be ready -- we're using it now */ string (control_point_data.flags) = ""b; control_point_data.preferred = "1"b; /* this control point "owns" the terminal, etc. */ control_point_data.priority = 1; /* "standard" priority */ control_point_data.stack_ptr = sb; /* the current stack belongs to the root */ control_point_data.last_frame_ptr = null (); /* no place for control to resume as we haven't left yet */ CANT_DESTROY_ROOT: control_point_data.destroy = CANT_DESTROY_ROOT; /* a label which prevents destruction */ control_point_data.parent, /* this is the only control point */ control_point_data.peers, control_point_data.children, control_point_data.ready_queue = null (); control_point_data.user_cl_intermediary = cpm_$nulle; control_point_data.comment = "Root Control Point"; call hcs_$get_ips_mask (control_point_data.ips_mask); substr (control_point_data.ips_mask, 36) = "1"b; /* construct a mask suitable for use by hcs_$reset_ips_mask */ control_point_data.privileges = get_privileges_ (); control_point_data.cl_intermediary = cpm_overseer_$cl_intermediary; call ioa_$rsnnl ("^12.3b", control_point_id_string, (0), control_point_data.id); call find_iocb ("user_i/o", control_point_data.user_io); call find_iocb ("user_input", control_point_data.user_input); call find_iocb ("user_output", control_point_data.user_output); call find_iocb ("error_output", control_point_data.error_output); control_point_data.meters = 0; control_point_data.meters.n_schedules = 1; /* it's been scheduled to run once when the process started */ stack_header.cpm_data_ptr = cpd_ptr; /* the definition is now complete */ /* Setup global data */ cpm_data_$n_control_points = 1; /* there's just one active control point */ cpm_data_$gc_control_points = "0"b; /* ...and there's no garbage to be cleaned up */ cpm_data_$preferred_control_point = cpd_ptr; /* this is the prefeered control point ... */ cpm_data_$preferred_control_point_stack.stack_depth = 0; /* ... and the stack of prior ones is empty */ cpm_data_$ready_queue.first, /* this is the only ready control point */ cpm_data_$ready_queue.last = cpd_ptr; cpm_data_$previous_control_point = cpd_ptr; /* claim we ran previously to make cpm_$generate_call happy */ unspec (cpm_data_$valid_control_points) = ""b; /* only this control point is valid */ cpm_data_$valid_control_points.map (binary (baseno (sb), 18, 0)) = "1"b; cpm_data_$global_meters = 0; /* no meters yet but make sure real time computed OK */ call user_info_$usage_data ((0), (0), (0), cpm_data_$global_meters.last_meters.real_time, (0), (0)); /* Control point management is now enabled */ stack_header.cpm_enabled = substr (control_point_data.id, 1, length (stack_header.cpm_enabled)); /* Place the stack number from the upper half of the id into stack_header.cpm_enabled (non-zero) */ call cu_$get_cl_intermediary (cpm_data_$saved_cl_intermediary); call cu_$set_cl_intermediary (cpm_overseer_$cl_intermediary); /* switch to our special CL intermediary */ return; %page; /* Creates an unattached I/O switch which can be used to save one of the control point's standard attachments when it stops running */ find_iocb: procedure (p_switch_name, p_switch_iocb); dcl p_switch_name character (*) parameter; dcl p_switch_iocb pointer parameter; dcl switch_name character (32) varying; switch_name = control_point_id_string; switch_name = switch_name || "."; switch_name = switch_name || p_switch_name; call iox_$find_iocb ((switch_name), p_switch_iocb, code); if code ^= 0 then call sub_err_ (code, cpm_data_$subsystem_name, ACTION_CANT_RESTART, null (), 0, "Creating an IOCB for ^a.", switch_name); return; end find_iocb; /* Returns the word offset of one pointer relative to another */ relwordno: procedure (p_ptr, p_base_ptr) returns (fixed binary (18)); dcl p_ptr pointer parameter; dcl p_base_ptr pointer parameter; return (wordno (p_ptr) - wordno (p_base_ptr)); end relwordno; /* format: off */ %page; %include cpm_data_; %page; %include cpm_internal_data; %page; %include cpm_control_point_data; %include cpm_ctrl_pt_meters; %include process_usage; %page; %include stack_header; %page; %include rnt; %page; %include area_info; %page; %include sub_err_flags; %page; %include iox_dcls; /* format: on */ end cpm_initialize_;  cpm_overseer_.pl1 11/04/86 1557.6rew 11/04/86 1031.4 330129 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1985 * * * *********************************************************** */ /* format: off */ /* Control Point Management -- Entrypoints which manage the environment of a control point */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206): Written to support control point management in March 1985 by G. Palter. END HISTORY COMMENTS */ /* format: style3,linecom */ cpm_overseer_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl P_ccpi_ptr pointer parameter; /* overseer: -> describes how to create the control point */ dcl P_initproc /* overseer: first user program to run in the control point */ entry (pointer) variable parameter; dcl P_initproc_arg_list_ptr /* overseer: -> the above program's argument list */ pointer parameter; dcl P_gcf_ptr pointer parameter; /* generate_call: -> generate_call_flags (see include file) */ dcl P_userproc /* generate_call: the user program to be executed */ entry (pointer) variable parameter; dcl P_userproc_arg_list_ptr /* generate_call: -> the above program's argument list */ pointer parameter; dcl P_cl_flags bit (36) aligned parameter; /* cl_intermediary: flags which control new command level */ /* Parameters for entrypoints used to prevent non-quick procedures */ dcl P_cpd_ptr pointer parameter; dcl P_old_cpd_ptr pointer parameter; dcl P_new_cpd_ptr pointer parameter; dcl P_cpd_swapped_switches bit (1) unaligned parameter; dcl P_new_swapped_switches_setting bit (1) aligned parameter; dcl P_new_mask bit (36) aligned parameter; dcl P_old_mask bit (36) aligned parameter; /* Remaining declarations */ dcl 1 parent_control_point_data like control_point_data aligned based (control_point_data.parent); dcl based_generate_call_flags bit (36) aligned based; dcl old_mask bit (36) aligned; dcl generate_call_flags bit (36) aligned; dcl pushed_preferred_state bit (1) aligned; dcl prior_state fixed binary; dcl return_from_intermediary bit (1) aligned; dcl saved_swapped_switches bit (1) aligned; dcl ( sys_info$comm_privilege, sys_info$dir_privilege, sys_info$ipc_privilege, sys_info$rcp_privilege, sys_info$ring1_privilege, sys_info$seg_privilege, sys_info$soos_privilege ) bit (36) aligned external; dcl continue_to_signal_ entry (fixed binary (35)); dcl cpm_$call_self_destruct entry (); dcl cpm_$update_state_caller entry (pointer, fixed binary); dcl cu_$arg_list_ptr entry () returns (pointer); dcl cu_$generate_call entry (entry, pointer); dcl ( cu_$get_cl_intermediary, cu_$set_cl_intermediary ) entry (entry (bit (36) aligned)); dcl default_error_handler_$wall entry (); dcl default_error_handler_$wall_ignore_pi entry (); dcl get_privileges_ entry () returns (bit (36) aligned); dcl hcs_$get_ips_mask entry (bit (36) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl ioa_$ioa_switch entry () options (variable); dcl ioa_$rsnnl entry () options (variable); dcl sub_err_ entry () options (variable); dcl ( system_privilege_$comm_priv_on, system_privilege_$comm_priv_off, system_privilege_$dir_priv_on, system_privilege_$dir_priv_off, system_privilege_$ipc_priv_on, system_privilege_$ipc_priv_off, system_privilege_$rcp_priv_on, system_privilege_$rcp_priv_off, system_privilege_$ring1_priv_on, system_privilege_$ring1_priv_off, system_privilege_$seg_priv_on, system_privilege_$seg_priv_off, system_privilege_$soos_priv_on, system_privilege_$soos_priv_off ) entry (fixed binary (35)); dcl any_other condition; dcl cleanup condition; dcl (addr, bool, null, stackbaseptr, substr) builtin; %page; /* The initial procedure for a new control point -- This entrypoint is responsible for completing the creation of an environment for the new control point. This responsibility includes establishing the standard I/O switches for this control point if they are to be different from our parent's control point. */ /* NOTE: This entrypoint is always called with all IPS signals masked. */ overseer: entry (P_ccpi_ptr, P_initproc, P_initproc_arg_list_ptr); on any_other call error_handler$catch_all (); /* setup our unclaimed signal handler */ cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;/* get our definitions */ ccpi_ptr = P_ccpi_ptr; if trace_$transaction_end (1) /* setup tracing according to our stack */ then ; call cu_$set_cl_intermediary (control_point_data.cl_intermediary); /* set our initial CL intermediary ($cl_intermediary below) */ call restore_privileges (); /* set our initial privileges (all OFF) */ call mask_ips_interrupts (control_point_data.ips_mask, old_mask); /* unmask all IPS interrupts (most likely) */ on cleanup call issue_root_start_order_caller (cpd_ptr); if create_control_point_info.separate_standard_iocbs then do; /* setup our I/O switches */ call create_control_point_switches (); on cleanup begin; /* ... and be sure to get rid of them on explicit destroy */ call destroy_control_point_switches_caller (cpd_ptr, ccpi_ptr, old_mask); call issue_root_start_order_caller (cpd_ptr); end; end; call cu_$generate_call (P_initproc, P_initproc_arg_list_ptr); /* start the control point running */ if create_control_point_info.separate_standard_iocbs then call destroy_control_point_switches (old_mask); /* we're done with these switches */ /*** We must leave all IPS signals unmasked when we return. Otherwise, cpm_$self_destruct will call the scheduler with all IPS signals masked and, if there are no ready control points, we will call hardcore to block with all signals masked which is clearly wrong. */ RETURN_FROM_OVERSEER: call issue_root_start_order (); /* kick the root */ return; /* complete the control point's destruction */ %page; /* The portion of cpm_$generate_call which executes in the target control point -- This entrypoint is responsible for readying the control point's environment before executing the user program requested by the call to cu_$generate_call. If cpm_$generate_call or cpm_$generate_call_preferred were used, this entrypoint will force the control point into the READY state and restore it to its prior state when execution is completed. If cpm_$generate_call_preferred was used, this entrypoint will push the preferred control point, make this control point preferred, and restore the preferred control point when execution is completed. In addition, if this control point uses a different set of standard I/O switches than the previously executing control point, this entrypoint must restore the switches before executing the user's program and then save them upon completion. This action is required as the scheduler will have saved our switches before running any control point with different switches and will expect to restore them when it regains control in this control point which will occur after we return. */ /* NOTE: This entrypoint is always invoked with all IPS signals masked. */ generate_call: entry (P_gcf_ptr, P_userproc, P_userproc_arg_list_ptr); cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr;/* get our definition */ generate_call_flags = P_gcf_ptr -> based_generate_call_flags; if trace_$transaction_end (1) /* setup tracing according to our stack */ then ; pushed_preferred_state = "0"b; /* for cleanup handler */ on cleanup /* in case the user's program aborts */ begin; /*** On a non-local goto, we must not restore the IPS mask. If we did, the control point would continue execution with all IPS signals masked which would, eventually, cause problems when it tries to block. In addition, we do not restore the prior state as, if we were blocked, we are about to release past the scheduler and the ipc_$block call which caused us to become blocked in the first place. If we had been stopped, we are about to release past the cu_$cl call which place us in that state. Finally, we do not save our I/O switches as we are not going to return to our caller (the scheduler) which would restore them. */ call cpm_$pop_preferred_control_point (pushed_preferred_state); call issue_start_orders_caller (cpd_ptr); end; if generate_call_flags & CPM_GC_FORCE_READY /* cpm_$generate_call or cpm_$generate_call_preferred ... */ then do; /* ... so make sure this control point is READY */ prior_state = control_point_data.state; if control_point_data.state ^= CPM_READY then call cpm_$update_state_caller (cpd_ptr, CPM_READY); end; if generate_call_flags & CPM_GC_PUSH_PREFERRED /* cpm_$generate_call_preferred: make us temporarily "it" */ then call cpm_$push_preferred_control_point (control_point_data.id, pushed_preferred_state, (0)); saved_swapped_switches = control_point_data.swapped_switches; control_point_data.swapped_switches = "0"b; /* don't use the root's switches during a generate_call */ if different_switches (cpd_ptr, cpm_data_$previous_control_point) then call restore_io_switches (); /* we need to get our switches back */ call cu_$set_cl_intermediary (control_point_data.cl_intermediary); /* restore our control point's CL intermediary */ call restore_privileges (); /* restore our system privileges */ call mask_ips_interrupts (control_point_data.ips_mask, old_mask); /* restore our control point's IPS mask */ call cu_$generate_call (P_userproc, P_userproc_arg_list_ptr); /* run the user's procedure */ call issue_start_orders (); /* in case the user's procedure did I/O */ call hcs_$get_ips_mask (control_point_data.ips_mask); substr (control_point_data.ips_mask, 36) = "1"b; /* construct possible new IPS mask for this control point */ call unmask_ips_interrupts (old_mask); /* restore the IPS mask */ control_point_data.privileges = get_privileges_ (); /* preceeding call may permanently affect our privileges */ call cu_$get_cl_intermediary (control_point_data.cl_intermediary); /* it may also permanently change the CL intermediary */ if different_switches (cpd_ptr, cpm_data_$previous_control_point) then call save_io_switches (); /* put our switches back where the scheduler will find them */ control_point_data.swapped_switches = saved_swapped_switches; call cpm_$pop_preferred_control_point (pushed_preferred_state); /* restore the previous preferred control point if pushed */ if generate_call_flags & CPM_GC_FORCE_READY /* cpm_$generate_call or cpm_$generate_call_preferred ... */ then if prior_state ^= CPM_READY /* ... so reset our state if it wasn't READY */ then call cpm_$update_state_caller (cpd_ptr, prior_state); if trace_$transaction_begin (1) /* disbale tracing until we're in another control point */ then ; return; /* return to the scheduler ... */ %page; /* The command level intermediary used by Control Point Management */ cl_intermediary: entry (P_cl_flags); cpd_ptr = stackbaseptr () -> stack_header.cpm_data_ptr; /* If we were invoked by default_error_handler_, our standard I/O switches will have been swapped with those belonging to the root control point. Before reaching command level, we must be sure to be using the proper set of switches. */ saved_swapped_switches = control_point_data.swapped_switches; /* we must remember whether to restore the switches */ old_mask = ""b; /* used by swap_switches */ on cleanup begin; /* in case of a release ... */ call issue_start_orders_caller (cpd_ptr); if saved_swapped_switches & ^control_point_data.swapped_switches then call swap_switches_caller (cpd_ptr, addr (cpm_data_$root_control_point_data), control_point_data.swapped_switches, "1"b); end; /* ... put things back the way the error_handler expects them */ if control_point_data.swapped_switches /* restore the control point's native switches */ then call swap_switches (addr (cpm_data_$root_control_point_data), cpd_ptr, control_point_data.swapped_switches, "0"b, "0"b); /* Invoke the user's CL intermediary if defined for this control point -- On return, if it requests, simply return without getting a new command level as if a "start" command had been issued. */ if control_point_data.user_cl_intermediary ^= cpm_$nulle then do; return_from_intermediary = "0"b; /* in case the user's CL intermediary doesn't set it */ call control_point_data.user_cl_intermediary (return_from_intermediary); if return_from_intermediary then go to RETURN_FROM_CL_INTERMEDIARY; end; /* Now get to command level -- If we are the root control point, we can invoke the saved intermediary to get a new listener level. Otherwise, we must stop this control point and let some other control point run; however, before we stop, we will try to print a message that we have stopped this control point. */ if cpd_ptr = addr (cpm_data_$root_control_point_data) then call cpm_data_$saved_cl_intermediary (P_cl_flags); else do; on any_other /* fault occured trying to write the following message ... */ call cpm_$call_self_destruct (); call ioa_$ioa_switch (iox_$error_output, "^a: Control point ^12.3b^[ (^a)^] stopped.", cpm_data_$subsystem_name, control_point_data.id, (control_point_data.comment ^= ""), control_point_data.comment); on any_other call error_handler$ignore_pi (); /* setup a condition wall */ call issue_root_start_order (); /* kick the root */ call cpm_$stop (control_point_data.id, (0)); call cpm_$scheduler (); /* find something to do */ revert any_other; /* we've been restarted ... */ end; /* Return to the caller of cu_$cl -- Reswap the standard switches if needed and issue a "start" control order on both our own user_i/o and the root's user_i/o to avoid possible lost wakeups. */ RETURN_FROM_CL_INTERMEDIARY: call issue_start_orders (); if saved_swapped_switches /* put things back the way the error_handler expects them */ then call swap_switches (cpd_ptr, addr (cpm_data_$root_control_point_data), control_point_data.swapped_switches, "1"b, "0"b); return; %page; /* The unclaimed signal (any_other) handler for any control point other than the root -- Before actually processing the signal, we first swap the current control point's I/O switches with those belonging to the root control point. Thus, any messages printed by default_error_handler_ will be displayed on the original login terminal as opposed to whatever connection the control point might be using. Of course, we must be certain to put things back after processing is completed. */ error_handler: procedure (); return; /* not used */ dcl real_error_handler entry () variable; dcl must_swap_switches bit (1) aligned; dcl our_arg_list_ptr pointer; error_handler$catch_all: /* catch everything including program_interrupt */ entry (); real_error_handler = default_error_handler_$wall; go to ERROR_HANDLER; error_handler$ignore_pi: /* catch everything but program_interrupt and a few others */ entry (); real_error_handler = default_error_handler_$wall_ignore_pi; go to ERROR_HANDLER; ERROR_HANDLER: our_arg_list_ptr = cu_$arg_list_ptr (); must_swap_switches = ^control_point_data.swapped_switches; on cleanup begin; if must_swap_switches & control_point_data.swapped_switches then call swap_switches_caller (addr (cpm_data_$root_control_point_data), cpd_ptr, control_point_data.swapped_switches, "0"b); end; if must_swap_switches then call swap_switches_caller (cpd_ptr, addr (cpm_data_$root_control_point_data), control_point_data.swapped_switches, "1"b); call cu_$generate_call (real_error_handler, our_arg_list_ptr); if must_swap_switches & control_point_data.swapped_switches then call swap_switches_caller (addr (cpm_data_$root_control_point_data), cpd_ptr, control_point_data.swapped_switches, "0"b); return; end error_handler; %page; /* Setup the control point's I/O switches when separate switches are requested -- Four uniquely named switches are created to represent the new control point's standard switches. If an attach description for user_i/o is provided, it is used to create an independent attachment for the new control point; otherwise, the new control point's user_i/o is syn_'ed to its parent's user_i/o. If any switch can not be setup, sub_err_ is used to inform the user. */ create_control_point_switches: procedure (); dcl 1 local_io_switches like control_point_data.io_switches aligned; dcl an_iocb_ptr pointer; dcl id_string character (12); dcl parents_user_io character (21); dcl our_user_io character (21); dcl code fixed binary (35); local_io_switches = null (); /* for proper error recovery */ call ioa_$rsnnl ("^12.3b", id_string, (0), control_point_data.id); our_user_io = id_string || ".user_i/o"; /* construct the name of our user_i/o switch */ if create_control_point_info.user_io_attach_desc_given then do; /* new control point has its own user_i/o */ call iox_$attach_name (our_user_io, local_io_switches.user_io, create_control_point_info.user_io_attach_desc, null (), code); if code ^= 0 then call attach_failure (our_user_io, create_control_point_info.user_io_attach_desc, code); call iox_$open (local_io_switches.user_io, Stream_input_output, "0"b, code); if code ^= 0 then call open_failure (our_user_io, code); end; else do; /* new control point is to share its parent's user_i/o */ call ioa_$rsnnl ("^12.3b.user_i/o", parents_user_io, (0), parent_control_point_data.id); call attach_syn ("user_i/o", parents_user_io, "", local_io_switches.user_io); end; /*** Attach user_input, user_output, and error_output as synonyms of user_i/o. These switches are not syn_'ed to the control point's private user_i/o because, if they were, they will always be syn_'ed to that switch even after it is moved to the real user_i/o. */ call attach_syn ("user_input", "user_i/o", "put_chars", local_io_switches.user_input); call attach_syn ("user_output", "user_i/o", "get_chars get_line", local_io_switches.user_output); call attach_syn ("error_output", "user_i/o", "get_chars get_line", local_io_switches.error_output); call unmask_ips_interrupts (old_mask); /* prevent interrupts while updating control_point_data */ control_point_data.io_switches = local_io_switches; control_point_data.group_id = control_point_data.id; /* we've now created the switches */ if cpm_data_$previous_control_point -> control_point_data.swapped_switches then call swap_switches (addr (cpm_data_$root_control_point_data), cpd_ptr, control_point_data.swapped_switches, "0"b, "1"b); else call swap_switches (cpm_data_$previous_control_point, cpd_ptr, control_point_data.swapped_switches, "0"b, "1"b); call mask_ips_interrupts (control_point_data.ips_mask, old_mask); return; /* Control arrives here iff an error occurs while trying to create the control point's standard switches */ ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES: do an_iocb_ptr = local_io_switches.user_input, local_io_switches.user_output, local_io_switches.error_output; if an_iocb_ptr ^= null () then do; call iox_$detach_iocb (an_iocb_ptr, (0)); call iox_$destroy_iocb (an_iocb_ptr, (0)); end; end; if local_io_switches.user_io ^= null () then do; if create_control_point_info.user_io_attach_desc_given then call iox_$close (local_io_switches.user_io, (0)); call iox_$detach_iocb (local_io_switches.user_io, (0)); call iox_$destroy_iocb (local_io_switches.user_io, (0)); end; go to RETURN_FROM_OVERSEER; /* Attaches an I/O switch as a synonym to the supplied target switch */ attach_syn: procedure (p_switch_name, p_target_switch_name, p_inhibits, p_switch_iocb); dcl p_switch_name character (*) parameter; dcl p_target_switch_name character (*) parameter; dcl p_inhibits character (*) parameter; dcl p_switch_iocb pointer parameter; dcl switch_name character (32) varying; dcl attach_description character (128) varying; switch_name = id_string; /* construct the switch's name */ switch_name = switch_name || "."; switch_name = switch_name || p_switch_name; attach_description = "syn_ "; /* now construct the attach description */ attach_description = attach_description || p_target_switch_name; attach_description = attach_description || " -inhibit close "; if p_inhibits ^= "" then attach_description = attach_description || p_inhibits; call iox_$attach_name ((switch_name), p_switch_iocb, (attach_description), null (), code); if code ^= 0 then call attach_failure (switch_name, attach_description, code); return; end attach_syn; /* Reports an error while attaching one of the control point's standard I/O switches */ /* format: off */ dcl attach_failure generic ( attach_failure_nonvarying when (character (*) nonvarying, character (*) nonvarying, fixed binary (35)), attach_failure_varying when (character (*) varying, character (*) varying, fixed binary (35))); /* format: on */ attach_failure_nonvarying: /* ... with nonvarying parameters */ procedure (p_switch_name, p_attach_desc, p_code); dcl p_switch_name character (*) parameter; dcl p_attach_desc character (*) parameter; dcl p_code fixed binary (35) parameter; call sub_err_ (p_code, cpm_data_$subsystem_name, ACTION_DEFAULT_RESTART, null (), 0, "Trying to attach ^a using the attach description -^/^-^a", p_switch_name, p_attach_desc); go to ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES; end attach_failure_nonvarying; attach_failure_varying: /* ... with varying parameters */ procedure (p_switch_name, p_attach_desc, p_code); dcl p_switch_name character (*) varying parameter; dcl p_attach_desc character (*) varying parameter; dcl p_code fixed binary (35) parameter; call sub_err_ (p_code, cpm_data_$subsystem_name, ACTION_DEFAULT_RESTART, null (), 0, "Trying to attach ^a using the attach description -^/^-^a", p_switch_name, p_attach_desc); go to ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES; end attach_failure_varying; /* Reports an error while trying to open one of the control point's standard I/O switches */ open_failure: /* ... while trying to open a switch */ procedure (p_switch_name, p_code); dcl p_switch_name character (*) parameter; dcl p_code fixed binary (35) parameter; call sub_err_ (p_code, cpm_data_$subsystem_name, ACTION_DEFAULT_RESTART, null (), 0, "Trying to open ^a.", p_switch_name); go to ERROR_RETURN_FROM_CREATE_CONTROL_POINT_SWITCHES; end open_failure; end create_control_point_switches; %page; /* Destroy the control point's standard I/O switches setup by a prior call to create_control_point_switches */ destroy_control_point_switches: procedure (p_old_mask); dcl p_old_mask bit (36) aligned parameter; dcl 1 local_io_switches like control_point_data.io_switches aligned; dcl an_iocb_ptr pointer; call unmask_ips_interrupts (p_old_mask); /* prevent interrupts while updating control_point_data */ if parent_control_point_data.swapped_switches /* revert to our parent's switches or the root's if swapped */ then call swap_switches (cpd_ptr, addr (cpm_data_$root_control_point_data), control_point_data.swapped_switches, "1"b, "1"b); else call swap_switches (cpd_ptr, control_point_data.parent, control_point_data.swapped_switches, "0"b, "1"b); local_io_switches = control_point_data.io_switches; /* work on local copies so we're never without switches */ control_point_data.group_id = parent_control_point_data.group_id; control_point_data.io_switches = parent_control_point_data.io_switches; /* switch back to our parent's switches */ call mask_ips_interrupts (control_point_data.ips_mask, p_old_mask); do an_iocb_ptr = local_io_switches.user_input, local_io_switches.user_output, local_io_switches.error_output; if an_iocb_ptr ^= null () then do; /* one of the always syn_'ed switches exists */ call iox_$detach_iocb (an_iocb_ptr, (0)); call iox_$destroy_iocb (an_iocb_ptr, (0)); end; end; if local_io_switches.user_io ^= null () then do; /* it's user_i/o switch exists */ if create_control_point_info.user_io_attach_desc_given then call iox_$close (local_io_switches.user_io, (0)); call iox_$detach_iocb (local_io_switches.user_io, (0)); call iox_$destroy_iocb (local_io_switches.user_io, (0)); end; return; end destroy_control_point_switches; /* Invoke destroy_control_point_switches -- This entrypoint exists to prevent making destroy_control_point_switches non-quick by invoking it from within an on unit or other non-quick procedure. */ destroy_control_point_switches_caller: entry (P_cpd_ptr, P_ccpi_ptr, P_old_mask); cpd_ptr = P_cpd_ptr; ccpi_ptr = P_ccpi_ptr; call destroy_control_point_switches (P_old_mask); return; %page; /* Swap the standard I/O switches in force from the old control point's switches to those of a new control point */ swap_switches: procedure (p_old_cpd_ptr, p_new_cpd_ptr, p_cpd_swapped_switches, p_new_swapped_switches_setting, p_caller_is_masked); dcl 1 old_cpd like control_point_data aligned based (p_old_cpd_ptr); dcl p_old_cpd_ptr pointer parameter; dcl 1 new_cpd like control_point_data aligned based (p_new_cpd_ptr); dcl p_new_cpd_ptr pointer parameter; dcl p_cpd_swapped_switches /* a control point's swapped_switches flag ... */ bit (1) unaligned parameter; dcl p_new_swapped_switches_setting /* ... and the above flag's new setting */ bit (1) aligned parameter; dcl p_caller_is_masked bit (1) aligned parameter; /* ON => the caller has already masked IPS interrupts */ if old_cpd.group_id = new_cpd.group_id /* they are using the same switches: this is a no-op */ then return; if ^p_caller_is_masked /* prevent interrupts while playing with the switches */ then call mask_ips_interrupts (""b, old_mask); call iox_$move_attach (iox_$user_io, old_cpd.io_switches.user_io, (0)); call iox_$move_attach (iox_$user_input, old_cpd.io_switches.user_input, (0)); call iox_$move_attach (iox_$user_output, old_cpd.io_switches.user_output, (0)); call iox_$move_attach (iox_$error_output, old_cpd.io_switches.error_output, (0)); call iox_$move_attach (new_cpd.io_switches.user_io, iox_$user_io, (0)); call iox_$move_attach (new_cpd.io_switches.user_input, iox_$user_input, (0)); call iox_$move_attach (new_cpd.io_switches.user_output, iox_$user_output, (0)); call iox_$move_attach (new_cpd.io_switches.error_output, iox_$error_output, (0)); p_cpd_swapped_switches = p_new_swapped_switches_setting; if ^p_caller_is_masked /* it's safe now */ then call unmask_ips_interrupts (old_mask); return; end swap_switches; /* Invoke swap_switches -- This entrypoint exists to prevent making swap_switches non-quick by invoking it from an on unit or other non-quick procedure. */ swap_switches_caller: entry (P_new_cpd_ptr, P_old_cpd_ptr, P_cpd_swapped_switches, P_new_swapped_switches_setting); old_mask = ""b; /* for any_other handler */ on any_other begin; if substr (old_mask, 36, 1) = "1"b then call unmask_ips_interrupts_caller (old_mask); call continue_to_signal_ ((0)); /* ... let the error get through */ end; call swap_switches (P_new_cpd_ptr, P_old_cpd_ptr, P_cpd_swapped_switches, P_new_swapped_switches_setting, "0"b); return; %page; /* Issue "start" control orders on the appropriate user_i/o switches -- This procedure is invoked after any operation which may have caused asynchronous I/O to prevent lost wakeups. A "start" order is issued on the current control point's user_i/o and also on the user_i/o associated with the root control point (i.e., the user's terminal) if it is different from the current control point's user_i/o. */ issue_start_orders: procedure (); call iox_$control (iox_$user_io, "start", null (), (0)); if control_point_data.swapped_switches /* user_i/o above is the root's: must also start our's */ then call iox_$control (control_point_data.user_io, "start", null (), (0)); else /* user_i/o above was our's: check the root's */ if control_point_data.group_id ^= cpm_data_$root_control_point_data.group_id then call iox_$control (cpm_data_$root_control_point_data.user_io, "start", null (), (0)); return; end issue_start_orders; /* Invoke issue_start_orders -- This entrypoint exists to prevent making the issue_start_orders internal procedure non-quick by invoking it from within an on unit or other non-quick procedure. */ issue_start_orders_caller: entry (P_cpd_ptr); cpd_ptr = P_cpd_ptr; call issue_start_orders (); return; %page; /* Issue a "start" control order on the root control point's user_i/o switch -- This procedure is invoked whenever the current control point is about to be stopped or destroyed. If the root control point was blocked for input on its user_i/o, any I/O performed to that switch by another control point would be considered asynchronous I/O and, without a "start" order, could leave the root control point blocked forever for an event that will never occur. */ issue_root_start_order: procedure (); if different_switches (cpd_ptr, addr (cpm_data_$root_control_point_data)) then call iox_$control (cpm_data_$root_control_point_data.user_io, "start", null (), (0)); else call iox_$control (iox_$user_io, "start", null (), (0)); /* this control point shares its switches with the root */ return; end issue_root_start_order; /* Invoke issue_root_start_order -- This entrypoint exists to prevent making the issue_root_start_order internal procedure non-quick by invoking it from within an on unit or other non-quick procedure. */ issue_root_start_order_caller: entry (P_cpd_ptr); cpd_ptr = P_cpd_ptr; call issue_root_start_order (); return; %page; /* Restore the standard I/O switches assigned to this control point */ restore_io_switches: procedure (); call iox_$move_attach (control_point_data.user_io, iox_$user_io, (0)); call iox_$move_attach (control_point_data.user_input, iox_$user_input, (0)); call iox_$move_attach (control_point_data.user_output, iox_$user_output, (0)); call iox_$move_attach (control_point_data.error_output, iox_$error_output, (0)); return; end restore_io_switches; /* Save the standard I/O switches assigned to this control point */ save_io_switches: procedure (); call iox_$move_attach (iox_$user_io, control_point_data.user_io, (0)); call iox_$move_attach (iox_$user_input, control_point_data.user_input, (0)); call iox_$move_attach (iox_$user_output, control_point_data.user_output, (0)); call iox_$move_attach (iox_$error_output, control_point_data.error_output, (0)); return; end save_io_switches; /* Determines if the two specified control points use different sets of standard I/O switches */ different_switches: procedure (p_cpd_1_ptr, p_cpd_2_ptr) returns (bit (1) aligned); dcl 1 cpd_1 like control_point_data aligned based (p_cpd_1_ptr); dcl 1 cpd_2 like control_point_data aligned based (p_cpd_2_ptr); dcl (p_cpd_1_ptr, p_cpd_2_ptr) pointer parameter; if cpd_1.swapped_switches & cpd_2.swapped_switches then return ("0"b); /* both control points are using the root's switches */ else if cpd_1.group_id = cpd_2.group_id /* same group: they use the same switches ... */ then return (cpd_1.swapped_switches ^= cpd_2.swapped_switches); /* ... unless one is using the root's but not the other */ else if (cpd_1.swapped_switches & (cpd_2.group_id = cpm_data_$root_control_point_data.group_id)) | (cpd_2.swapped_switches & (cpd_1.group_id = cpm_data_$root_control_point_data.group_id)) then return ("0"b); /* different groups: but one is swapped to the other */ else return ("1"b); /* different groups really using different switches */ end different_switches; %page; /* Restore the current control point's system privileges -- We need not worry about access to system_privilege_ as we only call it when we actually discover that a privilege has changed and the only way to change privileges is to use the system_privilege_ gate itself. */ restore_privileges: procedure (); dcl current_privileges bit (36) aligned; current_privileges = get_privileges_ (); if control_point_data.privileges = current_privileges then return; /* privileges are already correct */ if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$comm_privilege then if control_point_data.privileges & sys_info$comm_privilege then call system_privilege_$comm_priv_on ((0)); else call system_privilege_$comm_priv_off ((0)); if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$dir_privilege then if control_point_data.privileges & sys_info$dir_privilege then call system_privilege_$dir_priv_on ((0)); else call system_privilege_$dir_priv_off ((0)); if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$ipc_privilege then if control_point_data.privileges & sys_info$ipc_privilege then call system_privilege_$ipc_priv_on ((0)); else call system_privilege_$ipc_priv_off ((0)); if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$rcp_privilege then if control_point_data.privileges & sys_info$rcp_privilege then call system_privilege_$rcp_priv_on ((0)); else call system_privilege_$rcp_priv_off ((0)); if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$ring1_privilege then if control_point_data.privileges & sys_info$ring1_privilege then call system_privilege_$ring1_priv_on ((0)); else call system_privilege_$ring1_priv_off ((0)); if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$seg_privilege then if control_point_data.privileges & sys_info$seg_privilege then call system_privilege_$seg_priv_on ((0)); else call system_privilege_$seg_priv_off ((0)); if bool (control_point_data.privileges, current_privileges, "0110"b) & sys_info$soos_privilege then if control_point_data.privileges & sys_info$soos_privilege then call system_privilege_$soos_priv_on ((0)); else call system_privilege_$soos_priv_off ((0)); return; end restore_privileges; %page; /* Mask the specified IPS interrupts */ mask_ips_interrupts: procedure (p_new_mask, p_old_mask); dcl p_new_mask bit (36) aligned parameter; dcl p_old_mask bit (36) aligned parameter; call hcs_$set_ips_mask (p_new_mask, p_old_mask); end mask_ips_interrupts; /* Invoke mask_ips_interrupts -- This entrypoint exists to prevent making the mask_ips_interrupts internal procedure non-quick by invoking it from within an on unit or other non-quick procedure. */ mask_ips_interrupts_caller: entry (P_new_mask, P_old_mask); call mask_ips_interrupts (P_new_mask, P_old_mask); return; /* Restore the IPS mask to its state prior to calling mask_ips_interrupts */ unmask_ips_interrupts: procedure (p_old_mask); dcl p_old_mask bit (36) aligned parameter; if substr (p_old_mask, 36, 1) = "1"b then call hcs_$reset_ips_mask (p_old_mask, p_old_mask); end unmask_ips_interrupts; /* Invoke unmask_ips_interrupts -- This entrypoint exists to prevent making the unmask_ips_interrupts internal procedure non-quick by invoking it from within an on unit or other non-quick procedure. */ unmask_ips_interrupts_caller: entry (P_old_mask); call unmask_ips_interrupts (P_old_mask); return; /* format: off */ %page; %include cpm_internal_data; %page; %include cpm_control_point_data; %include cpm_ctrl_pt_meters; %include process_usage; %page; %include cpm_create_ctrl_pt_info; %page; %include cpm_entries; %page; %include cpm_generate_call_flags; %page; %include stack_header; %page; %include iox_dcls; %page; %include iox_modes; %page; %include sub_err_flags; %page; %include trace_interface; /* format: on */ end cpm_overseer_; 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