create_ips_mask_.pl1 11/11/89 1144.0rew 11/11/89 0803.3 19404 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3 */ /* DESCRIPTION: Creates an IPS mask given the names of the ips interrupts to be masked. */ /* HISTORY: Written by Dan Bricklin, October 1970. Modified: 06/08/72 by D. M. Wells: To make it properly respect an invocation with lng = 0; that is, no mask is wanted. 07/16/84 by R. Michael Tague: Make it use the include file ips_mask_data. */ create_ips_mask_: proc (p, lng, mask); %include ips_mask_data; dcl p ptr, lng fixed bin (17), mask bit (36) aligned, ips_names (1) char (32) aligned based (p), create_ips_mask_err condition, (i, j) fixed bin (17); mask = "0"b; /* Initialize the mask */ if lng <= 0 then goto ret; /* allow for the mask none case */ if p -> ips_names (1) = "-all" then do; /* return a mask of everything */ do i = 1 to sys_info$ips_mask_data.count; mask = mask | sys_info$ips_mask_data.mask.mask (i); end; go to ret; end; do i = 1 to lng; /* Look for each signal type in list */ do j = 1 to sys_info$ips_mask_data.count; /* Look through all possible names */ if p -> ips_names (i) = sys_info$ips_mask_data.mask.name (j) then do; mask = mask | sys_info$ips_mask_data.mask.mask (j); go to next; /* when found, or in bit */ end; end; signal condition (create_ips_mask_err); return; next: end; ret: mask = ^mask; /* Mask is now an enable mask, so ^ it for a disable mask */ return; end;  get_control_point_id_.alm 11/11/89 1144.0rew 11/11/89 0803.3 22788 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1986 * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(86-09-19,Fawcett), approve(86-09-19,MCR7473), " audit(86-10-22,Farley), install(86-11-03,MR12.0-1206): " Written to support control point management. This was actually done in " March 1985 by G. Palter in pl1 with 5 statements. Rewritten in alm to " eliminate the cost of pushing and popping the stack frame for such a " trivial task. " END HISTORY COMMENTS name get_control_point_id_ " This short routine is used by bound_cpm_ and bound_ipc_. It's " function is to return the control point id, this is defined as the " baseno of the stack that control point runs on. If control point " management is not enabled then the baseno of the current stack is " returned. " " USAGE: " " dcl get_control_point_id_ entry () returns (bit (36) aligned); " " ID = get_control_point_id_ (); " entry get_control_point_id_ get_control_point_id_: " First check to see if control point management is enabled. " If stack_header.cpm_enabled is not zero then it is enabled. lxl7 sb|stack_header.cpm_enabled " Lower half of word " transfer if control point is enabled (not zero) tnz real_cp " not enabled (zero), the ID is this stack baseno placed in the A " register by the Effective Pointer in the AQ register. epaq sb|0 " AND a mask to the upper half of the A register. Thats where the epaq " placed the segment number, in bits 3-17. ana =o077777,du sta ap|2,* " return the ID to the caller. short_return " short_return because no stack frame " was pushed. real_cp: " Now that we KNOW that control point management is enabled, load the " ID in the A register and return it to the caller. eax7 cpd.id lda sb|stack_header.cpm_data_ptr,*7 sta ap|2,* " return the ID to the caller. short_return " short_return because no stack frame " was pushed. %include cpm_control_point_data; %include stack_header; end  ipc_.alm 11/11/89 1144.0rew 11/11/89 0803.3 27729 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name ipc_ """""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " This procedure is a transfer vector for the several pieces of IPC. " " Originally coded by R. J. Feiertag on May 13, 1972. " Changed by E. Donner Jan 1981 for new ipc from rest_of_ipc_.alm " Modified by J. Bongiovanni Septemper 1981 for name ipc_, macro " """""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " HISTORY COMMENTS: " 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), " audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206): " Modified to support control point management. This change was actually " made in February 1985 by G. Palter. " 2) change(86-08-12,Kissel), approve(86-08-12,MCR7479), " audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206): " Added the create_event_channel and run_event_calls entries to support " asynch event channels. " END HISTORY COMMENTS " The following is the normal transfer-vector macro " " ipc_tv , macro ipc_tv segdef &1 &1: tsx0 getlp tra &2 &end " " The following subroutine calculate the lp for this procedure. " getlp: epaq * get ptr to ourselves lprplp sb|stack_header.lot_ptr,*au get ptr to linkage from packed ptr tra 0,0 return " %include stack_header " ipc_tv block,ipc_fast_$block ipc_tv create_ev_chn,ipc_real_$create_ev_chn ipc_tv create_event_channel,ipc_real_$create_event_channel ipc_tv cutoff,ipc_real_$cutoff ipc_tv decl_ev_call_chn,ipc_real_$decl_ev_call_chn ipc_tv decl_ev_wait_chn,ipc_real_$decl_ev_wait_chn ipc_tv decl_event_call_chn,ipc_real_$decl_event_call_chn ipc_tv delete_ev_chn,ipc_real_$delete_ev_chn ipc_tv drain_chn,ipc_real_$drain_chn ipc_tv mask_ev_calls,ipc_real_$mask_ev_calls ipc_tv read_ev_chn,ipc_real_$read_ev_chn ipc_tv reassign_call_channels,ipc_real_$reassign_call_channels ipc_tv reconnect,ipc_real_$reconnect ipc_tv reset_ev_call_chn,ipc_real_$reset_ev_call_chn ipc_tv run_event_calls,ipc_real_$run_event_calls ipc_tv set_call_prior,ipc_real_$set_call_prior ipc_tv set_wait_prior,ipc_real_$set_wait_prior ipc_tv unmask_ev_calls,ipc_real_$unmask_ev_calls ipc_tv wait_for_an_event,ipc_real_$wait_for_an_event " This is an obsolete entry, from the days before IPC " used standard error codes. It is a no-op segdef convert_ipc_code_ convert_ipc_code_: short_return end  ipc_data_.cds 11/11/89 1144.0r w 11/11/89 0803.3 19539 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3 */ ipc_data_: proc; /* Static values needed by user ring ipc - replaces an alm version */ /* These are used to implement fast channels efficiently by making it */ /* inexpensive to detect if a process has pending wakeups. */ /* Coded by E Donner Jan 1981 */ /* Modified September 1983 by Chris Jones to only count event calls pending */ /* automatic */ dcl 1 cds_arguments aligned like cds_args; dcl code fixed bin (35); /* constants */ dcl MOI char (9) static init ("ipc_data_") options (constant); /* Builtins */ dcl addr builtin; dcl null builtin; dcl size builtin; dcl string builtin; dcl unspec builtin; /* entries */ dcl com_err_ entry options (variable); dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl 1 ipc_data_ aligned, 2 event_calls_pending fixed bin, /* count of call events pending */ 2 fast_channel_events bit (36); /* special events pending */ unspec (ipc_data_) = ""b; /* Fill in arguments to cds before creating data base */ cds_arguments.sections (2).p = addr (ipc_data_); cds_arguments.sections (2).len = size (ipc_data_); cds_arguments.sections (2).struct_name = MOI; cds_arguments.seg_name = MOI; cds_arguments.exclude_array_ptr = null; string (cds_arguments.switches) = "0"b; cds_arguments.switches.have_static = "1"b; cds_arguments.switches.separate_static = "1"b; call create_data_segment_ (addr (cds_arguments), code); if code ^= 0 then call com_err_ (MOI, code); return; %include cds_args; end ipc_data_;  ipc_fast_.pl1 11/11/89 1144.0rew 11/11/89 0803.3 56700 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3 */ ipc_fast_$block: procedure (a_event_wait_list_ptr, a_event_wait_info_ptr, a_code); /* This procedure is a fast call to block a process and is called as ipc_$block. It handles fast ipc channels only and calls the full ipc mechanism if channels other than fast channels are supplied. */ /* Rewritten for new ipc by E Donner Jan 1981 */ /* Modified September 1983 by Chris Jones to call the full IPC mechanism when there are call events pending, not when there are any events pending. */ /* Modified 1984-11-02 by E. Swenson for new ipc validation */ /****^ 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): Changed to support control point management. These changes were actually done in February 1985 by G. Palter. END HISTORY COMMENTS */ /* parameters */ dcl a_event_wait_list_ptr ptr parameter; dcl a_event_wait_info_ptr ptr parameter; dcl a_code fixed bin (35); /* automatic */ dcl call_regular bit (1) aligned; /* indicates if full ipc should be called */ dcl cur_ring fixed bin (3); /* current ring */ dcl 1 ev_chn_name aligned like event_channel_name automatic; dcl loop fixed bin; /* index */ dcl validation_level fixed bin (3); /* current validation level */ /* constants */ dcl OFF bit (1) aligned static options (constant) init ("0"b); dcl ON bit (1) aligned static options (constant) init ("1"b); dcl TRUE bit (1) aligned static options (constant) init ("1"b); /* external static */ dcl ipc_data_$event_calls_pending fixed bin ext; /* number of event call wakeups pending */ dcl ipc_data_$fast_channel_events bit (36) aligned ext; /* fast events pending */ dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$invalid_channel fixed bin (35) ext; /* external entries */ dcl cu_$level_get entry returns (fixed bin (3)); dcl cu_$level_set entry (fixed bin (3)); dcl ipc_real_$full_block entry (ptr, ptr, fixed bin (35)); dcl get_ring_ entry returns (fixed bin (3)); dcl hcs_$fblock entry (bit (36) aligned, bit (1) aligned); /* Conditions */ dcl cleanup condition; /* Builtin */ dcl length builtin; dcl stackbaseptr builtin; dcl substr builtin; dcl unspec builtin; %page; /* Program */ event_wait_list_ptr = a_event_wait_list_ptr; event_wait_info_ptr = a_event_wait_info_ptr; event_wait_list_n_channels = event_wait_list.n_channels; if event_wait_list_n_channels <= 0 then do; a_code = error_table_$bad_arg; return; end; if ipc_data_$event_calls_pending ^= 0 /* we have some call wakeups pending */ then go to INVOKE_FULL_BLOCK; /* call full block mechanism */ cur_ring = get_ring_ (); validation_level = cu_$level_get (); /* get validation level */ do while (TRUE); if have_multiple_control_points () /* more than one cotnrol point can be waiting ... */ then go to INVOKE_FULL_BLOCK; /* ... on one of these channels */ do loop = 1 to event_wait_list_n_channels; /* look for each channel */ unspec (ev_chn_name) = unspec (event_wait_list.channel_id (loop)); /* copy channel name into structured format */ if ev_chn_name.type = REGULAR_CHANNEL_TYPE | ev_chn_name.ring ^= cur_ring then go to INVOKE_FULL_BLOCK; /* if regular event channel or from another ring */ /* do validity check on channel name */ if ev_chn_name.mbz ^= "0"b | ev_chn_name.unique_id <= 0 | ev_chn_name.unique_id > length (ipc_data_$fast_channel_events) then do; a_code = error_table_$invalid_channel; return; end; /* ascertained that this is fast channel in current ring */ if substr (ipc_data_$fast_channel_events, ev_chn_name.unique_id, 1) = ON then do; /* wakeup pending */ substr (ipc_data_$fast_channel_events, ev_chn_name.unique_id, 1) = OFF; /* turn off event cell */ unspec (event_wait_info) = "0"b; event_wait_info.channel_id = event_wait_list.channel_id (loop); /* return messge - channel name */ event_wait_info.channel_index = loop; /* and index in input list */ a_code = 0; /* no error */ return; end; end; /* no fast events already processed */ on condition (cleanup) call cu_$level_set (validation_level); if validation_level ^= cur_ring /* set validation level to current ring */ then call cu_$level_set (cur_ring); call hcs_$fblock (ipc_data_$fast_channel_events, call_regular); /* get events from ring 0 */ if validation_level ^= cur_ring /* reset validation level */ then call cu_$level_set (validation_level); revert cleanup; if call_regular /* wakeups for regular channels must be checked ... */ then go to INVOKE_FULL_BLOCK; /* ... as they could be wakeups for call channels */ end; /* Control arrives here iff we must invoke the full blocking mechanism */ INVOKE_FULL_BLOCK: call ipc_real_$full_block (event_wait_list_ptr, event_wait_info_ptr, a_code); return; %page; /* Determines if more than one control point is defined in this process */ have_multiple_control_points: procedure () returns (bit (1) aligned); if stackbaseptr () -> stack_header.cpm_enabled then return (cpm_data_$n_control_points > 1); else return ("0"b); end have_multiple_control_points; /* format: off */ %page; %include ect_structures; %page; %include event_channel_name; %page; %include event_wait_info; %page; %include event_wait_list; %page; %include stack_header; %page; %include cpm_data_; /* format: on */ end ipc_fast_$block;  ipc_real_.pl1 11/11/89 1144.0rew 11/11/89 0803.3 591327 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3 */ /**** THE INTERPROCESS COMMUNICATION FACILITY. This procedure is resident in all non-hardcore rings (1:7) to manipulate the event channels of those rings. Every ring has its own Event Channel Table (ECT) and Event Channel Index Table (ECIT) which is created dynamically when ipc_$create_ev_chn is invoked for the first time in that ring. IPC manipulates the ECT pointed to either by the validation ring number or by the event channel name. Only ipc_$block refers to its current-ring's ECT for event-call interrogation, all other calls to IPC manipulate the ECT in which the event channel given as argument is located, provided that it is not an inner ring. */ /* format: off */ /* IPC may return one of the following error codes: 0 = no error error_table_$wrong_channel_ring = ring access violation (event channel resides in other than current ring) error_table_$invalid_channel = event channel not found in ECT (incorrect event channel name) error_table_$not_a_wait_channel = attempting to wait for event call channel error_table_$event_calls_not_masked = attempting to unmask event calls when event call already unmasked error_table_$event_channel_cutoff = attempting to read a channel or go blocked on a group of channels all of which have been cutoff error_table_$event_channel_not_cutoff = attempting to reconnect a channel which has not been cutoff error_table_$bad_arg = erroneous argument */ /* format: on */ /* Initially coded by the very hands of Michael J. Spier, August 26, 1968 Rewritten for new ipc by Eleanor Donner Jan 1981 Modified September 1981 by J. Bongiovanni to fix the most obscure bug I've ever seen Modified September 1983 by Chris Jones to count event calls pending, not all events pending. Modified 1984-11-02 by E. Swenson for new IPC event channel validation. */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206): Changed to support control point management. These changes were actually done in February 1985 by G. Palter. 2) change(86-08-12,Kissel), approve(86-08-12,MCR7479), audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206): Changed to add the create_event_channel and run_event_calls entries to support async event channels. END HISTORY COMMENTS */ ipc_real_: procedure (); return; /* not an entry */ /* Parameters */ dcl P_create_arg_ptr ptr parameter; dcl P_event_channel_name fixed bin (71) parameter; dcl P_event_channel_type fixed bin parameter; dcl P_code fixed bin (35) parameter; dcl P_fast_channel_id fixed binary (18) parameter; dcl P_procedure_ptr ptr parameter; dcl P_event_wait_list_ptr ptr parameter; dcl P_datap ptr parameter; dcl P_priority fixed bin (17) parameter; dcl P_procedure_entry entry (ptr) variable parameter; dcl P_old_control_point_id bit (36) aligned parameter; dcl P_new_control_point_id bit (36) aligned parameter; dcl P_found_event fixed bin (17) parameter; dcl P_event_wait_info_ptr ptr parameter; dcl P_mask bit (36) aligned parameter; /* External Entries */ dcl continue_to_signal_ entry (fixed bin (35)); dcl cu_$level_get entry returns (fixed bin (3)); dcl cu_$level_set entry (fixed bin (3)); dcl cu_$make_entry_value entry (ptr, entry); dcl get_ring_ entry returns (fixed bin (3)); dcl hcs_$assign_channel entry (fixed bin (71), fixed bin (35)); dcl hcs_$delete_channel ext entry (fixed bin (71), fixed bin (35)); dcl hcs_$fblock entry (bit (36) aligned, bit (1) aligned); dcl hcs_$read_events entry (bit (36) aligned, bit (1) 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 ipc_util_$create_ect entry (ptr); dcl ipc_util_$delete_entry entry (ptr, ptr); dcl ipc_util_$ect_error_handler entry (fixed bin (35)); dcl ipc_util_$make_entry entry (ptr, fixed bin (8), ptr, fixed bin (15)); dcl ipc_util_$verify_channel entry (fixed bin (71), ptr, bit (1) aligned, fixed bin (35)); dcl ipc_util_$verify_regular_channel entry (fixed bin (71), ptr, fixed bin (35)); dcl ipc_validate_$encode_event_channel_name entry (fixed bin (18), fixed bin (35), bit (3) aligned, fixed bin (15), fixed bin (3), bit (1) aligned, fixed bin (18), fixed bin (71)); /* External Static */ dcl error_table_$bad_arg fixed bin (35) ext; dcl error_table_$event_calls_not_masked fixed bin (35) ext; dcl error_table_$event_channel_cutoff fixed bin (35) ext; dcl error_table_$event_channel_not_cutoff fixed bin (35) ext; dcl error_table_$inconsistent_ect fixed bin (35) ext; dcl error_table_$not_a_wait_channel fixed bin (35) ext; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl ipc_data_$fast_channel_events bit (36) aligned ext; dcl ipc_data_$event_calls_pending fixed bin ext; /* Automatic */ dcl added_to_waiting_lists bit (1) aligned; dcl block_val fixed bin (3); dcl call_channel_procedure entry (ptr) variable; dcl 1 call_info aligned like event_call_info; dcl check_channels bit (1) aligned; dcl cur_ring fixed bin (3); dcl current_control_point_id bit (36) aligned; dcl ecit_idx fixed bin (15); dcl entry_type fixed bin (8); dcl 1 entry_value aligned, 2 ep_ptr ptr, 2 env_ptr ptr; dcl event_call_in_progress bit (1) aligned; dcl ev_chn_flags bit (3) aligned; dcl event_channel_type fixed bin; dcl fb71 fixed bin (71); dcl found_call_event bit (1) aligned; dcl found_event fixed bin; dcl found_wait_event bit (1) aligned; dcl inhibit_count fixed bin; dcl is_fast bit (1) aligned; dcl last_ectep ptr; dcl loop fixed bin; dcl mask bit (36) aligned; dcl msg_ptr ptr; dcl saved_message_thread pointer; dcl temp_found_event fixed bin; /* Builtins */ dcl addr builtin; dcl codeptr builtin; dcl environmentptr builtin; dcl null builtin; dcl stackbaseptr builtin; dcl substr builtin; dcl unspec builtin; /* Conditions */ dcl any_other condition; dcl cleanup condition; /* Constants */ dcl (ON, YES, TRUE) bit (1) aligned static options (constant) init ("1"b); dcl (OFF, NO) bit (1) aligned static options (constant) init ("0"b); %page; create_ev_chn: entry (P_event_channel_name, P_code); /**** This entry creates an event wait channel and returns the channel name. */ call find_ectp; /* get pointer to ECT header for current ring */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call mask_ips_interrupts (mask); call ipc_util_$make_entry (ect_ptr, WAIT, ectep, ecit_idx); /* set message and control point queue pointers to null values */ wait_channel.first_ev_msgp, wait_channel.last_ev_msgp = null (); wait_channel.first_wcpp, wait_channel.last_wcpp = null (); ev_chn_flags = ""b; /* we don't support anything else yet. */ cur_ring = get_ring_ (); call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags, ecit_idx, cur_ring, REGULAR_CHANNEL_TYPE, (ect_header.seed), fb71); ect_header.seed = ect_header.seed + 1; /* put name in channel entry and return arg */ wait_channel.name, unspec (P_event_channel_name) = unspec (fb71); /* thread into list of wait channels */ call thread_channel (WAIT); call unmask_ips_interrupts (mask); P_code = 0; return; %page; create_event_channel: entry (P_create_arg_ptr, P_event_channel_name, P_code); /**** This entry creates an event channel of the specified type. The procedure entry, data pointer, and priority arguments are ignored for wait type channels and used for call type channels. */ ipc_create_arg_structure_ptr = P_create_arg_ptr; P_event_channel_name = 0; /* Initialize the outputs. */ P_code = 0; if ipc_create_arg_structure.version ^= ipc_create_arg_structure_v1 then do; P_code = error_table_$unimplemented_version; return; end; /* Set up to create the event channel. */ call find_ectp; /* get pointer to ECT header for current ring */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call mask_ips_interrupts (mask); /*** Create a fast event wait channel. */ if ipc_create_arg_structure.channel_type = FAST_EVENT_CHANNEL_TYPE then do; call hcs_$assign_channel (P_event_channel_name, P_code); end; /*** Create a normal event wait channel. */ else if ipc_create_arg_structure.channel_type = WAIT_EVENT_CHANNEL_TYPE then do; call ipc_util_$make_entry (ect_ptr, WAIT, ectep, ecit_idx); /*** Set message and control point queue pointers to null values. */ wait_channel.first_ev_msgp, wait_channel.last_ev_msgp = null (); wait_channel.first_wcpp, wait_channel.last_wcpp = null (); ev_chn_flags = NORMAL_CHANNEL_FLAGS; cur_ring = get_ring_ (); call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags, ecit_idx, cur_ring, REGULAR_CHANNEL_TYPE, (ect_header.seed), fb71); ect_header.seed = ect_header.seed + 1; /*** Put the name in the channel entry and the return argument. */ wait_channel.name = unspec (fb71); unspec (P_event_channel_name) = unspec (fb71); /*** Thread into the list of wait channels. */ call thread_channel (WAIT); end; /*** Create a normal or IPS wkp_ event call channel. */ else if ipc_create_arg_structure.channel_type = CALL_EVENT_CHANNEL_TYPE | ipc_create_arg_structure.channel_type = ASYNC_CALL_EVENT_CHANNEL_TYPE then do; call ipc_util_$make_entry (ect_ptr, CALL, ectep, ecit_idx); /*** Set up the call channel structure. */ call_channel.type = CALL; call_channel.first_ev_msgp, call_channel.last_ev_msgp = null (); call_channel.data_ptr = ipc_create_arg_structure.call_data_ptr; call_channel.procedure_ptr = codeptr (ipc_create_arg_structure.call_entry); call_channel.environment_ptr = environmentptr (ipc_create_arg_structure.call_entry); call_channel.priority = ipc_create_arg_structure.call_priority; call_channel.control_point_id = get_control_point_id_ (); call_channel.call_inhibit = OFF; /*** Set the flag that indicates what type of call channel this is. */ /*** Since this information is also encoded in the channel name */ /*** we only set this flag here and it remains the way we set it */ /*** for the life of this entry. */ if ipc_create_arg_structure.channel_type = CALL_EVENT_CHANNEL_TYPE then do; call_channel.flags.async_call = "0"b; ev_chn_flags = NORMAL_CHANNEL_FLAGS; end; else do; call_channel.flags.async_call = "1"b; ev_chn_flags = SEND_IPS_WKP_CHANNEL_FLAGS; end; cur_ring = get_ring_ (); call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags, ecit_idx, cur_ring, REGULAR_CHANNEL_TYPE, (ect_header.seed), fb71); ect_header.seed = ect_header.seed + 1; /*** Put the name in the channel entry and the return argument. */ call_channel.name = unspec (fb71); unspec (P_event_channel_name) = unspec (fb71); /*** Thread into the list of call channels. */ call thread_channel (CALL); end; /*** He wants some type we have never heard of. */ else P_code = error_table_$bad_arg; /* All done, unmask and return, the channel name and the code have been set. */ call unmask_ips_interrupts (mask); return; %page; create_fast_ev_chn: entry (P_fast_channel_id, P_code); /**** This entry creates a wait channel definition for a fast event channel. This wait channel definition is only used when control point management is enabled to track the control points which have blocked on the fast channel. */ call find_ectp; /* get pointer to ECT header for current ring */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call mask_ips_interrupts (mask); call ipc_util_$make_entry (ect_ptr, WAIT, ectep, ecit_idx); if P_fast_channel_id ^= ecit_idx then do; /* fast channel's ECT index must match its ID */ call ipc_util_$delete_entry (ect_ptr, ectep); call inconsistent_ect (); /* ... will never return */ end; wait_channel.fast_channel = YES; /* this is a fast channel ECT entry */ wait_channel.fast_channel_id = P_fast_channel_id; wait_channel.first_ev_msgp, wait_channel.last_ev_msgp = null (); wait_channel.first_wcpp, wait_channel.last_wcpp = null (); /* Create the channel's name */ ev_chn_flags = NORMAL_CHANNEL_FLAGS; cur_ring = get_ring_ (); call ipc_validate_$encode_event_channel_name (ect_header.r_offset, ect_header.r_factor, ev_chn_flags, ecit_idx, cur_ring, FAST_CHANNEL_TYPE, (P_fast_channel_id), fb71); wait_channel.name = unspec (fb71); /* Thread into list of wait channels */ call thread_channel (WAIT); call unmask_ips_interrupts (mask); P_code = 0; return; %page; decl_ev_call_chn: entry (P_event_channel_name, P_procedure_ptr, P_datap, P_priority, P_code); call find_ectp; mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call cu_$make_entry_value (P_procedure_ptr, call_channel_procedure); call MAKE_EVENT_CALL (call_channel_procedure); return; %page; decl_event_call_chn: entry (P_event_channel_name, P_procedure_entry, P_datap, P_priority, P_code); call find_ectp; mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call MAKE_EVENT_CALL (P_procedure_entry); return; %page; decl_ev_wait_chn: entry (P_event_channel_name, P_code); /**** This entry turns an event channel into a wait channel. It works on asynchronous call channels as well as normal call channels. If the channel was asynchronous, then the IPS "wkp_" will still be sent, but will essentially be a no-op. ****/ call find_ectp; call ipc_util_$verify_channel (P_event_channel_name, ectep, is_fast, P_code); /* return if unable to locate channel or if already a wait channel */ /* fast channels are considered to be wait channels */ if (P_code ^= 0) | (is_fast = YES) then return; if (wait_channel.type = WAIT) then return; /* On with the show. */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call mask_ips_interrupts (mask); /* Save the list of pending messages */ call save_channel_message_thread (saved_message_thread); /* Remove last vestiges of this channel being a call channel, but leave the flags alone just in case it becomes a call channel again. */ call_channel.priority = 0; call_channel.call_inhibit = OFF; call unthread_channel; /* Complete conversion into a wait channel */ wait_channel.type = WAIT; wait_channel.first_wcpp, wait_channel.last_wcpp = null (); wait_channel.fast_channel_id, wait_channel.unused2 = 0; call thread_channel (WAIT); /* Rethread any pending messages saved above */ call rethread_channel_message_thread (saved_message_thread); call unmask_ips_interrupts (mask); return; %page; reset_ev_call_chn: entry (P_event_channel_name, P_code); /**** This entry resets a call channel's inhibit flag */ call find_ectp; call ipc_util_$verify_regular_channel (P_event_channel_name, ectep, P_code); if P_code ^= 0 then return; if call_channel.type = CALL then call_channel.call_inhibit = OFF; return; %page; /* Reassigns ownership of all event call channels from one control point to another -- This entrypoint is called by the control point manager whenever it destroys a control point. */ reassign_call_channels: entry (P_old_control_point_id, P_new_control_point_id); call find_ectp (); mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call mask_ips_interrupts (mask); do ectep = ect_header.firstp (CALL) repeat (call_channel.next_chanp) while (ectep ^= null ()); if call_channel.type ^= CALL then call inconsistent_ect (); if call_channel.control_point_id = P_old_control_point_id then call_channel.control_point_id = P_new_control_point_id; end; call unmask_ips_interrupts (mask); return; %page; delete_ev_chn: entry (P_event_channel_name, P_code); /**** This entry deletes an event channel */ call find_ectp; call ipc_util_$verify_channel (P_event_channel_name, ectep, is_fast, P_code); if P_code ^= 0 then return; call decl_ev_wait_chn (P_event_channel_name, P_code); /* make it event-wait channel */ if P_code ^= 0 then return; call drain_chn (P_event_channel_name, P_code); /* reset channel to zero */ mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call mask_ips_interrupts (mask); call reset_channel_wcps (); /* any waiting control points should now get an error */ if is_fast = YES then call hcs_$delete_channel (P_event_channel_name, P_code); else do; call unthread_channel; call ipc_util_$delete_entry (ect_ptr, ectep); P_code = 0; end; call unmask_ips_interrupts (mask); return; %page; drain_chn: entry (P_event_channel_name, P_code); /**** Drains all currently waiting event messages from the channel. */ found_event = 1; /* set default values */ P_code = 0; do loop = 1 to 2; do while (found_event = 1 & P_code = 0); /* read events until channel empty */ call read_ev_chn (P_event_channel_name, found_event, addr (call_info), P_code); end; if loop = 1 /* drain channel even if it has been cutoff */ then if P_code ^= 0 then if P_code = error_table_$event_channel_cutoff then do; call reconnect (P_event_channel_name, (0)); P_code = 0; end; end; return; %page; cutoff: entry (P_event_channel_name, P_code); /**** Sets a flag to temporarily disable the channel for reading purposes. */ call find_ectp; call set_inhibit_switch (1); return; %page; reconnect: entry (P_event_channel_name, P_code); /**** Resets the inhibit flag reactivating the channel. */ call find_ectp; call set_inhibit_switch (-1); return; %page; set_call_prior: entry (P_code); /**** For this ring, set priority so that event call channels are interrogated before event wait channels. */ call find_ectp; call set_priority_switch (ON); return; %page; set_wait_prior: entry (P_code); /**** For this ring, set priority so that event wait channels are interrogated before event call channels. */ call find_ectp; call set_priority_switch (OFF); return; %page; mask_ev_calls: entry (P_code); /**** Cause calls to ipc_$block ignore event call channels in this ring. */ call find_ectp; call set_mask (1); return; %page; unmask_ev_calls: entry (P_code); /**** Cause calls to ipc_$block to respond to event call channels again for this ring. */ call find_ectp; call set_mask (-1); return; %page; read_ev_chn: entry (P_event_channel_name, P_found_event, P_event_wait_info_ptr, P_code); /**** Read an event message out of an event channel */ call find_ectp; inhibit_count, P_found_event = 0; call ipc_util_$verify_channel (P_event_channel_name, ectep, is_fast, P_code); if P_code ^= 0 then return; /* Only call ring-0 if the ECT does not already have any messages for this channel */ block_val = cu_$level_get (); /* for cleanup handler required by copy_itt_messages */ cur_ring = get_ring_ (); on cleanup call cu_$level_set (block_val); mask = ""b; /* for any_other handler required by copy_itt_messages */ on any_other call any_other_handler (); if is_fast = YES then do; call read_fast_channel (P_event_channel_name, P_found_event, P_event_wait_info_ptr); if P_found_event = 0 then do; /* nothing known already: ask ring 0 */ call copy_itt_messages (NO); call read_fast_channel (P_event_channel_name, P_found_event, P_event_wait_info_ptr); end; end; else do; /* regular channel */ if wait_channel.first_ev_msgp = null () then call copy_itt_messages (NO); /* nothing known already: ask ring 0 */ call read_channel (inhibit_count, P_found_event, P_event_wait_info_ptr); if inhibit_count ^= 0 /* logical error, channel inhibited */ then P_code = error_table_$event_channel_cutoff; end; return; %page; /**** This entry waits for events to be signalled over event channels */ full_block: entry (P_event_wait_list_ptr, P_event_wait_info_ptr, P_code); call find_ectp (); event_wait_list_ptr = P_event_wait_list_ptr; event_wait_info_ptr = P_event_wait_info_ptr; event_wait_info.channel_index = 0; /* reset channel-index to zero */ event_wait_list_n_channels = event_wait_list.n_channels; /* get number of channels to read */ if event_wait_list_n_channels <= 0 then do; /* erroneous argument */ P_code = error_table_$bad_arg; return; end; block_val = cu_$level_get (); /* for cleanup handler requried by copy_itt_messages ... */ cur_ring = get_ring_ (); /* ... and hardcore_block */ event_call_in_progress = NO; /* for cleanup handler required by check_call_channels */ added_to_waiting_lists = NO; /* for cleanup handler if there are multiple control points */ on cleanup begin; if added_to_waiting_lists = YES /* this control point will no longer be waiting */ then call delete_from_waiting_lists_caller (event_wait_list_ptr); if event_call_in_progress = YES /* the event call has been aborted */ then do; call_channel.call_inhibit = OFF; event_call_in_progress = NO; end; call cu_$level_set (block_val); end; mask = ""b; /* for any_other handler required by copy_itt_messages */ on any_other call any_other_handler (); current_control_point_id = get_control_point_id_ (); /* Main loop of ipc_$full_block */ do while (TRUE); call copy_itt_messages (NO); /* get pending ITT messages */ /* format: off */ check_channels = /* we can only check for events if ... */ (have_multiple_control_points () = NO) |/* ... there is only one control point or ... */ (ect_header.wakeup_control_points = NO);/* ... all control points are in their proper state */ /* format: on */ /* Check the channels for a pending event to satisfy this block */ do while (check_channels = YES); if ect_header.call_priority = YES then do; /* check call channels first */ call check_call_channels (ANY_CALL_EVENT_CHANNEL_TYPE, found_call_event); if found_call_event = NO then do; call check_wait_channels (found_wait_event); if (found_wait_event = YES) | (P_code ^= 0) then go to RETURN_FROM_FULL_BLOCK; end; end; else do; /* check the wait channels first */ call check_wait_channels (found_wait_event); if (found_wait_event = YES) | (P_code ^= 0) then go to RETURN_FROM_FULL_BLOCK; call check_call_channels (ANY_CALL_EVENT_CHANNEL_TYPE, found_call_event); end; check_channels = (found_call_event = YES) & ((have_multiple_control_points () = NO) | (ect_header.wakeup_control_points = NO)); end; /* Control arrives here iff we have to block until an event arrives -- If there are multiple control points in the process, this control point will now relinquish control of the process to someone else. If there's only one control point, we can call ring 0 to block the process directly. */ if have_multiple_control_points () = YES then do; if added_to_waiting_lists = NO /* put this control point on each channel's waiting list */ then do; call add_to_waiting_lists (); if P_code ^= 0 then go to RETURN_FROM_FULL_BLOCK; end; call block_if_no_pending_events ();/* mark us blocked unless there are available events */ if P_code ^= 0 then go to RETURN_FROM_FULL_BLOCK; if ect_header.wakeup_control_points = YES then call wakeup_blocked_control_points (); call cpm_$scheduler (); /* find a control point to run */ end; else call hardcore_block (); end; /* Control arrives here when it's time to return to our caller and we might have passed through the main loop at least once */ RETURN_FROM_FULL_BLOCK: if added_to_waiting_lists = YES then call delete_from_waiting_lists (); return; %page; /* This entrypoint is called by the control point scheduler when there are no control points in the ready state. The purpose of this entrypoint is to wait for any IPC event (fast or regular) to occur and to then notify the control points waiting for those events. The notification will place said control points into the ready state and the scheduler will then select the one with the highest priority to process its wakeup. */ wait_for_an_event: entry (); call find_ectp (); block_val = cu_$level_get (); /* for cleanup handler requried by copy_itt_messages ... */ cur_ring = get_ring_ (); /* ... and hardcore_block */ on cleanup call cu_$level_set (block_val); mask = ""b; /* for any_other handler required by copy_itt_messages */ on any_other call any_other_handler (); call copy_itt_messages (YES); /* pick up any events that have already arrived */ if ect_header.wakeup_control_points = YES then call wakeup_blocked_control_points (); /* inform the waiting control points if we found anything */ else call hardcore_block (); /* otherwise, wait for something to happen */ return; %page; run_event_calls: entry (P_event_channel_type, P_code); /* * This entry causes any pending event calls of the specified type to be run. * It makes one pass through the chains of pending events instead of scanning * from the beginning of the chain after each event is processed (like * full_block). The major reason for this entry is for use by the wkp_ IPS * signal, whose contract is to run any pending event calls in the process. */ event_channel_type = P_event_channel_type; if event_channel_type ^= CALL_EVENT_CHANNEL_TYPE & event_channel_type ^= ASYNC_CALL_EVENT_CHANNEL_TYPE & event_channel_type ^= ANY_CALL_EVENT_CHANNEL_TYPE then do; P_code = error_table_$bad_arg; return; end; call find_ectp (); block_val = cu_$level_get (); /* Save the validation ring number. */ cur_ring = get_ring_ (); /* Get the current ring number for calls to ring 0. */ event_call_in_progress = NO; /* Triggers cleanup action. */ /* Prevents check_call_channels procedure from being non-quick. */ on cleanup begin; if event_call_in_progress = YES then do; call_channel.call_inhibit = OFF; event_call_in_progress = NO; end; call cu_$level_set (block_val); end; /* Set up an any_other handler for copy_itt_messages and current_control_point_id for check_call_channels. */ mask = ""b; on any_other call any_other_handler (); current_control_point_id = get_control_point_id_ (); /* * Calling copy_itt_messages once will get the pending events. As long as * we don't call it again we won't get any more events in the ECT. This is * how we guarantee that only the events that were pending when we are called * will be handled even though check_call_channels starts from the beginning * of the event messages each time we call it. */ call copy_itt_messages (NO); found_call_event = YES; /* Do the loop at least once. */ do while (found_call_event); /* Loop until no more. */ call check_call_channels (P_event_channel_type, found_call_event); end; return; %page; find_ectp: procedure (); /**** Internal procedure to get a pointer to the ECT for this ring. If there is none, one will be created. */ ect_ptr = stackbaseptr () -> stack_header.ect_ptr; if ect_ptr = null then call ipc_util_$create_ect (ect_ptr); end find_ectp; %page; /* Pickup any new event messages which have arrived since we last blocked */ copy_itt_messages: procedure (p_set_wcp); dcl p_set_wcp bit (1) aligned parameter; dcl an_ectep pointer; dcl 1 a_call_channel like call_channel aligned based (an_ectep); dcl 1 a_wait_channel like wait_channel aligned based (an_ectep); dcl channel_id fixed binary; dcl code fixed bin (35); /* Check with ring 0 if there are no ITT messages already in the ECT */ if ect_header.firstp (ITT_MESSAGE) = null then do; if block_val ^= cur_ring then call cu_$level_set (cur_ring); call hcs_$read_events (ipc_data_$fast_channel_events, ("0"b)); if block_val ^= cur_ring then call cu_$level_set (block_val); end; /* Record newly arrived fast events if multiple control points are present in this process as more than one such control point may be blocked on a fast channel */ if (p_set_wcp = YES) | (have_multiple_control_points () = YES) then do; do an_ectep = ect_header.firstp (WAIT) repeat (a_wait_channel.next_chanp) while (an_ectep ^= null ()); if a_wait_channel.type ^= WAIT then call inconsistent_ect (); if a_wait_channel.fast_channel = YES then do; channel_id = a_wait_channel.fast_channel_id; if (substr (ipc_data_$fast_channel_events, channel_id, 1) = YES) & (substr (ect_header.last_fast_channel_events, channel_id, 1) = NO) then do; /* this is a fresh event */ a_wait_channel.wakeup_control_points = YES; ect_header.wakeup_control_points = YES; end; end; end; ect_header.last_fast_channel_events = ipc_data_$fast_channel_events; end; /* remember the new events */ /* Process the ITT messages */ call mask_ips_interrupts (mask); do msg_ptr = ect_header.firstp (ITT_MESSAGE) repeat (ect_header.firstp (ITT_MESSAGE)) while (msg_ptr ^= null); ect_header.firstp (ITT_MESSAGE) = msg_ptr -> itt_message.next_itt_msgp; if ect_header.lastp (ITT_MESSAGE) = msg_ptr then ect_header.lastp (ITT_MESSAGE) = null; ect_header.count (ITT_MESSAGE) = ect_header.count (ITT_MESSAGE) - 1; call ipc_util_$verify_regular_channel (msg_ptr -> itt_message.channel_id, an_ectep, code); if code = 0 then do; /* This ITT message is intended for an existing channel -- add it to the appropriate queues */ msg_ptr -> event_message.chanp = an_ectep; if (p_set_wcp = YES) | (have_multiple_control_points () = YES) then ect_header.wakeup_control_points, a_wait_channel.wakeup_control_points = YES; /* must notify all control points in the process */ if a_call_channel.type = CALL then do; msg_ptr -> event_message.priority = a_call_channel.priority; call insert_event_call_message (msg_ptr); ect_header.total_call_wakeups = ect_header.total_call_wakeups + 1; end; else do; call insert_event_wait_message (msg_ptr); ect_header.total_wait_wakeups = ect_header.total_wait_wakeups + 1; end; ect_header.total_wakeups = ect_header.total_wakeups + 1; a_wait_channel.wakeup_count = a_wait_channel.wakeup_count + 1; end; else do; /* This ITT message is not intended for an existing channel -- throw it away */ call ipc_util_$delete_entry (ect_ptr, msg_ptr); ect_header.ittes_tossed = ect_header.ittes_tossed + 1; end; end; call unmask_ips_interrupts (mask); return; end copy_itt_messages; %page; /* Scans the list of outstanding event messages for call channels -- If a message is found for a channel which is not inhibited and which was declared a call channel by this control point, and the channel is the right type, the message is removed from the queue and the call handler is invoked. */ check_call_channels: procedure (P_event_channel_type, P_found_call_event); dcl P_event_channel_type fixed bin parameter; dcl P_found_call_event bit (1) aligned parameter; dcl call_msgp ptr; dcl ev_chn_flags bit (3) aligned; dcl got_message fixed bin; dcl is_fast bit (1) aligned; dcl rcode fixed bin (35); dcl saved_channel_name fixed bin (71); P_found_call_event = NO; /* assume failure */ if ect_header.mask_call_count > 0 /* all event calls are shut off */ then return; /* Scan the list of call event messages */ got_message = 0; do call_msgp = ect_header.firstp (EV_CALL_MESSAGE) repeat (call_msgp) while ((call_msgp ^= null ()) & (got_message = 0)); ectep = call_msgp -> event_message.chanp; /* find the channel which owns this message */ if call_channel.type ^= CALL then call inconsistent_ect (); if call_channel.control_point_id = current_control_point_id then do; /* It is for this control point. */ if (^call_channel.flags.async_call & (P_event_channel_type = CALL_EVENT_CHANNEL_TYPE | P_event_channel_type = ANY_CALL_EVENT_CHANNEL_TYPE)) | (call_channel.flags.async_call & (P_event_channel_type = ASYNC_CALL_EVENT_CHANNEL_TYPE | P_event_channel_type = ANY_CALL_EVENT_CHANNEL_TYPE)) then call read_channel ((0), got_message, addr (call_info)); else ; /* This one is not for us. */ end; call_msgp = call_msgp -> event_message.next_ev_msgp; end; if got_message = 0 /* nothing found */ then return; /* An acceptable message was found -- Invoke the call channel's procedure */ unspec (saved_channel_name) = unspec (call_channel.name); entry_value.ep_ptr = call_channel.procedure_ptr; entry_value.env_ptr = call_channel.environment_ptr; unspec (call_channel_procedure) = unspec (entry_value); call_info.data_ptr = call_channel.data_ptr; event_call_in_progress = YES; /* inform full_block's cleanup handler */ call_channel.call_inhibit = ON; /* prevent recursive invocations of this channel's handler */ /*** Call the user's program */ if have_multiple_control_points () = YES /* must always use cpm_ to insure our I/O switches are OK */ then call cpm_$generate_call_preferred (current_control_point_id, call_channel_procedure, addr (call_info), (0)) ; else call call_channel_procedure (addr (call_info)); call ipc_util_$verify_regular_channel (saved_channel_name, (null ()), rcode); if rcode = 0 /* channel wasn't deleted by the handler ... */ then call_channel.call_inhibit = OFF; /* ... so we can allow subsequent wakeups */ event_call_in_progress = NO; /* full_block's cleanup handler need not worry about it */ P_found_call_event = YES; /* keep checking channels */ return; end check_call_channels; %page; check_wait_channels: procedure (P_found_event_wait); dcl P_found_event_wait bit (1) aligned parameter; dcl temp_channel_name fixed bin (71); dcl 1 message_info aligned like event_wait_info; dcl loop fixed bin; P_found_event_wait = NO; inhibit_count = 0; do loop = 1 to event_wait_list_n_channels; temp_channel_name = event_wait_list.channel_id (loop); call ipc_util_$verify_channel (temp_channel_name, ectep, is_fast, P_code); if P_code ^= 0 then return; if is_fast = YES then call read_fast_channel (temp_channel_name, temp_found_event, addr (message_info)); else do; if wait_channel.type ^= WAIT then do; P_code = error_table_$not_a_wait_channel; return; end; call read_channel (inhibit_count, temp_found_event, addr (message_info)); end; if temp_found_event ^= 0 then do; event_wait_info.channel_id = message_info.channel_id; event_wait_info.message = message_info.message; event_wait_info.sender = message_info.sender; event_wait_info.dev_signal = message_info.dev_signal; event_wait_info.ring = message_info.ring; event_wait_info.channel_index = loop; P_found_event_wait = YES; return; end; end; if inhibit_count = event_wait_list_n_channels then do; P_code = error_table_$event_channel_cutoff; return; end; end check_wait_channels; %page; read_channel: proc (P_inhibit_count, P_found_event, P_event_wait_info_ptr); /**** Internal procedure to read one event message out of a channel. */ dcl P_inhibit_count fixed bin parameter; dcl P_found_event fixed bin parameter; dcl P_event_wait_info_ptr ptr parameter; dcl msg_ptr ptr; P_found_event = 0; /* set default return values */ if call_channel.type = CALL & call_channel.call_inhibit = YES then return; /* event call procedure being called */ if wait_channel.inhibit_count ^= 0 /* channel inhibited, must not be read */ then do; P_inhibit_count = P_inhibit_count + 1; /* increment count of inhibited channels */ return; /* ignore inhibited channel */ end; /* having reached this point, we know that we have the right to try and read the event channel. */ call mask_ips_interrupts (mask); msg_ptr = wait_channel.first_ev_msgp; if msg_ptr ^= null () /* there's a message waiting */ then do; call unthread_event_message (msg_ptr); /* remove it from the queue */ if wait_channel.first_ev_msgp = null () /* don't notify other control points if no events are left */ then wait_channel.wakeup_control_points = NO; P_event_wait_info_ptr -> event_wait_info = msg_ptr -> event_message.message_data, by name; /* return message to caller of ipc_$block */ P_found_event = 1; /* set indicator = successful */ call ipc_util_$delete_entry (ect_ptr, msg_ptr); /* delete the message entry */ end; call unmask_ips_interrupts (mask); end read_channel; %page; read_fast_channel: proc (P_channel_name, P_found_event, P_event_wait_info_ptr); dcl P_channel_name fixed bin (71) parameter; dcl P_found_event fixed bin parameter; dcl P_event_wait_info_ptr ptr parameter; dcl channel_index fixed bin; dcl unspec builtin; dcl 1 ev_chn_name aligned like event_channel_name automatic; P_found_event = 0; unspec (ev_chn_name) = unspec (P_channel_name); if ev_chn_name.type = REGULAR_CHANNEL_TYPE then return; channel_index = ev_chn_name.unique_id; if substr (ipc_data_$fast_channel_events, channel_index, 1) = NO then return; /**** Indicate we've read the event out. */ substr (ipc_data_$fast_channel_events, channel_index, 1) = NO; wait_channel.wakeup_control_points = NO; /* don't notify other control points about this channel now */ substr (ect_header.last_fast_channel_events, channel_index, 1) = NO; /* ... but be sure later events will notify */ /**** And fill in return info */ P_event_wait_info_ptr -> event_wait_info.channel_id = P_channel_name; P_event_wait_info_ptr -> event_wait_info.message = 0; P_event_wait_info_ptr -> event_wait_info.sender, P_event_wait_info_ptr -> event_wait_info.dev_signal = ""b; P_event_wait_info_ptr -> event_wait_info.ring = ev_chn_name.ring; P_found_event = 1; return; end read_fast_channel; %page; /* Insert the given message into the event call queue based on its priority */ insert_event_call_message: procedure (p_msg_ptr); dcl p_msg_ptr pointer parameter; dcl 1 next_event_message like event_message aligned based (next_msg_ptr); dcl next_msg_ptr pointer; dcl 1 p_event_message like event_message aligned based (p_msg_ptr); dcl prev_msg_ptr pointer; p_event_message.type = EV_CALL_MESSAGE; prev_msg_ptr = null (); /* assume it goes at the beginning of the queue */ do next_msg_ptr = ect_header.firstp (EV_CALL_MESSAGE) repeat (next_event_message.next_ev_msgp) while (next_msg_ptr ^= null ()); if next_event_message.chanp -> call_channel.type ^= CALL then call inconsistent_ect (); if next_event_message.priority > p_event_message.priority then go to INSERT_THE_MESSAGE; else prev_msg_ptr = next_msg_ptr; end; INSERT_THE_MESSAGE: call thread_event_message (p_msg_ptr, prev_msg_ptr); return; end insert_event_call_message; /* Insert the given message onto the tail of the event wait queue */ insert_event_wait_message: procedure (p_msg_ptr); dcl p_msg_ptr pointer parameter; p_msg_ptr -> event_message.type = EV_WAIT_MESSAGE; call thread_event_message (p_msg_ptr, ect_header.lastp (EV_WAIT_MESSAGE)); return; end insert_event_wait_message; %page; /* Thread an event message into the list of active messages after the specified message */ thread_event_message: procedure (p_msg_ptr, p_prev_msg_ptr); dcl p_msg_ptr pointer parameter; dcl p_prev_msg_ptr pointer parameter; dcl message_type fixed binary; dcl 1 next_event_message like event_message aligned based (next_msg_ptr); dcl next_msg_ptr pointer; dcl owning_chanp pointer; dcl 1 p_event_message like event_message aligned based (p_msg_ptr); dcl 1 prev_event_message like event_message aligned based (prev_msg_ptr); dcl prev_msg_ptr pointer; message_type = p_event_message.type; owning_chanp = p_event_message.chanp; if ((message_type = EV_WAIT_MESSAGE) & (owning_chanp -> wait_channel.type ^= WAIT)) | ((message_type = EV_CALL_MESSAGE) & (owning_chanp -> call_channel.type ^= CALL)) then call inconsistent_ect (); /* First add the message to the end of the per-channel thread */ if owning_chanp -> wait_channel.first_ev_msgp = null () then do; /* this is the first message for the channel */ if owning_chanp -> wait_channel.last_ev_msgp ^= null () then call inconsistent_ect (); owning_chanp -> wait_channel.first_ev_msgp = p_msg_ptr; p_event_message.prev_chan_msgp = null (); end; else do; /* the per-channel thread already has something on it */ if owning_chanp -> wait_channel.last_ev_msgp = null () then call inconsistent_ect (); if owning_chanp -> wait_channel.last_ev_msgp -> event_message.next_chan_msgp ^= null () then call inconsistent_ect (); owning_chanp -> wait_channel.last_ev_msgp -> event_message.next_chan_msgp = p_msg_ptr; p_event_message.prev_chan_msgp = owning_chanp -> wait_channel.last_ev_msgp; end; owning_chanp -> wait_channel.last_ev_msgp = p_msg_ptr; p_event_message.next_chan_msgp = null (); /* Now add the message to the per-type thread */ prev_msg_ptr = p_prev_msg_ptr; /* this parameter could be ect_header.lastp (type) and, since its passed by reference, the value would change as we set ect_header.lastp (type) when adding to end of the queue */ if prev_msg_ptr = null () then do; /* add it to the beginning */ next_msg_ptr = ect_header.firstp (message_type); ect_header.firstp (message_type) = p_msg_ptr; end; else do; /* add it to the middle or the end */ if prev_event_message.type ^= message_type then call inconsistent_ect (); next_msg_ptr = prev_event_message.next_ev_msgp; prev_event_message.next_ev_msgp = p_msg_ptr; end; if next_msg_ptr = null () then do; /* add it to the end */ if ect_header.lastp (message_type) ^= prev_msg_ptr then call inconsistent_ect (); ect_header.lastp (message_type) = p_msg_ptr; end; else do; /* add it to the beginning or the middle */ if next_event_message.type ^= message_type then call inconsistent_ect (); next_event_message.prev_ev_msgp = p_msg_ptr; end; p_event_message.prev_ev_msgp = prev_msg_ptr; p_event_message.next_ev_msgp = next_msg_ptr; /* Update the appropriate counters */ ect_header.count (message_type) = ect_header.count (message_type) + 1; if message_type = EV_CALL_MESSAGE /* let ipc_fast_ know */ then ipc_data_$event_calls_pending = ipc_data_$event_calls_pending + 1; return; end thread_event_message; %page; /* Unthread an event message from the list of active messages */ unthread_event_message: procedure (p_msg_ptr); dcl p_msg_ptr pointer parameter; dcl message_type fixed binary; dcl owning_chanp pointer; dcl 1 p_event_message like event_message aligned based (p_msg_ptr); message_type = p_event_message.type; owning_chanp = p_event_message.chanp; if ((message_type = EV_WAIT_MESSAGE) & (owning_chanp -> wait_channel.type ^= WAIT)) | ((message_type = EV_CALL_MESSAGE) & (owning_chanp -> call_channel.type ^= CALL)) then call inconsistent_ect (); /* First remove this message from the per-channel thread */ if p_event_message.prev_chan_msgp = null () then do; /* this is the first message for the channel */ if owning_chanp -> wait_channel.first_ev_msgp ^= p_msg_ptr then call inconsistent_ect (); owning_chanp -> wait_channel.first_ev_msgp = p_event_message.next_chan_msgp; end; else do; /* this is in the middle of the channel's thread */ if p_event_message.prev_chan_msgp -> event_message.next_chan_msgp ^= p_msg_ptr then call inconsistent_ect (); p_event_message.prev_chan_msgp -> event_message.next_chan_msgp = p_event_message.next_chan_msgp; end; if p_event_message.next_chan_msgp = null () then do; /* this is the last message for the channel */ if owning_chanp -> wait_channel.last_ev_msgp ^= p_msg_ptr then call inconsistent_ect (); owning_chanp -> wait_channel.last_ev_msgp = p_event_message.prev_chan_msgp; end; else do; /* this is in the middle of the channel's thread */ if p_event_message.next_chan_msgp -> event_message.prev_chan_msgp ^= p_msg_ptr then call inconsistent_ect (); p_event_message.next_chan_msgp -> event_message.prev_chan_msgp = p_event_message.prev_chan_msgp; end; p_event_message.prev_chan_msgp, p_event_message.next_chan_msgp = null (); /* Now remove this message from the per-type thread */ if p_event_message.prev_ev_msgp = null () then do; /* this is the first message for the type */ if ect_header.firstp (message_type) ^= p_msg_ptr then call inconsistent_ect (); ect_header.firstp (message_type) = p_event_message.next_ev_msgp; end; else do; /* this is in the middle of the type's thread */ if p_event_message.prev_ev_msgp -> event_message.next_ev_msgp ^= p_msg_ptr then call inconsistent_ect (); p_event_message.prev_ev_msgp -> event_message.next_ev_msgp = p_event_message.next_ev_msgp; end; if p_event_message.next_ev_msgp = null () then do; /* this is the last message for the type */ if ect_header.lastp (message_type) ^= p_msg_ptr then call inconsistent_ect (); ect_header.lastp (message_type) = p_event_message.prev_ev_msgp; end; else do; /* this is in the middle of the type's thread */ if p_event_message.next_ev_msgp -> event_message.prev_ev_msgp ^= p_msg_ptr then call inconsistent_ect (); p_event_message.next_ev_msgp -> event_message.prev_ev_msgp = p_event_message.prev_ev_msgp; end; p_event_message.prev_ev_msgp, p_event_message.next_ev_msgp = null (); /* Update the appropriate counters */ ect_header.count (message_type) = ect_header.count (message_type) - 1; if message_type = EV_CALL_MESSAGE /* let ipc_fast_ know */ then ipc_data_$event_calls_pending = ipc_data_$event_calls_pending - 1; return; end unthread_event_message; %page; /* Save the list of pending messages for the "current" channel -- The messages are unthreaded from the "active" messages */ save_channel_message_thread: procedure (p_saved_message_thread); dcl p_saved_message_thread pointer parameter; dcl (msg_ptr, prev_msg_ptr, next_msg_ptr) pointer; p_saved_message_thread, prev_msg_ptr = null (); do msg_ptr = wait_channel.first_ev_msgp repeat (next_msg_ptr) while (msg_ptr ^= null ()); next_msg_ptr = msg_ptr -> event_message.next_chan_msgp; call unthread_event_message (msg_ptr); if prev_msg_ptr = null () then p_saved_message_thread = msg_ptr; /* this is the first message in the list */ else prev_msg_ptr -> event_message.next_chan_msgp = msg_ptr; prev_msg_ptr = msg_ptr; end; return; end save_channel_message_thread; /* Rethread the list of pending messages for the "current" channel */ rethread_channel_message_thread: procedure (p_saved_message_thread); dcl p_saved_message_thread pointer parameter; dcl next_msg_ptr pointer; do msg_ptr = p_saved_message_thread repeat (next_msg_ptr) while (msg_ptr ^= null ()); next_msg_ptr = msg_ptr -> event_message.next_chan_msgp; if msg_ptr -> event_message.chanp ^= ectep then call inconsistent_ect (); if wait_channel.type = WAIT then call insert_event_wait_message (msg_ptr); else do; msg_ptr -> event_message.priority = call_channel.priority; call insert_event_call_message (msg_ptr); end; end; return; end rethread_channel_message_thread; %page; thread_channel: proc (P_entry_type); dcl P_entry_type fixed bin (8) parameter; last_ectep = ect_header.lastp (P_entry_type); /* list is empty */ if last_ectep = null then do; /* thread in at beginning of list */ ect_header.firstp (P_entry_type) = ectep; wait_channel.prev_chanp = null; end; else do; /* thread in at end of list */ wait_channel.prev_chanp = last_ectep; last_ectep -> wait_channel.next_chanp = ectep; end; /* fill in forward thread and tail of list */ wait_channel.next_chanp = null; ect_header.lastp (P_entry_type) = ectep; ect_header.count (P_entry_type) = ect_header.count (P_entry_type) + 1; end thread_channel; %page; unthread_channel: procedure (); entry_type = wait_channel.type; /* save type of ect entry */ /* if first channel adjust head of list */ if wait_channel.prev_chanp = null then ect_header.firstp (entry_type) = wait_channel.next_chanp; /* otherwise thread out back pointer */ else wait_channel.prev_chanp -> wait_channel.next_chanp = wait_channel.next_chanp; /* if last channel in list adjust tail of list*/ if wait_channel.next_chanp = null then ect_header.lastp (entry_type) = wait_channel.prev_chanp; /* otherwise thread out forward pointer */ else wait_channel.next_chanp -> wait_channel.prev_chanp = wait_channel.prev_chanp; /* set threads to null in entry */ wait_channel.next_chanp, wait_channel.prev_chanp = null; ect_header.count (entry_type) = ect_header.count (entry_type) - 1; end unthread_channel; %page; MAKE_EVENT_CALL: procedure (P_call_procedure); /**** This internal procedure is called to turn the specified event channel into an event call channel. The channel must be valid and not be a special (i.e. fast) channel. Implicit parameters are P_event_channel_name, P_datap, P_priority, and P_code. */ dcl P_call_procedure entry (ptr) variable; call ipc_util_$verify_regular_channel (P_event_channel_name, ectep, P_code); if P_code ^= 0 /* do not allow fast channels */ then return; call mask_ips_interrupts (mask); /* Save the list of any pending messages -- If the channel is already a call channel, we may still have to rethread it as its priority may be changed. In either case, leave the flag indicating whether it is an async call channel alone, since it was set when the channel was created, and should not be changed (since it is also encoded in the channel name). */ call save_channel_message_thread (saved_message_thread); /* Convert it into a call channel */ if wait_channel.type = WAIT then do; call reset_channel_wcps (); /* any waiting control points should now get an error */ call unthread_channel; call_channel.type = CALL; call thread_channel (CALL); end; call_channel.data_ptr = P_datap; call_channel.procedure_ptr = codeptr (P_call_procedure); call_channel.environment_ptr = environmentptr (P_call_procedure); call_channel.priority = P_priority; call_channel.control_point_id = get_control_point_id_ (); call_channel.call_inhibit = OFF; /* Rethread any pending messages for this channel */ call rethread_channel_message_thread (saved_message_thread); call unmask_ips_interrupts (mask); end MAKE_EVENT_CALL; %page; set_inhibit_switch: procedure (P_inhibit_value); dcl P_inhibit_value fixed bin (17) parameter; call ipc_util_$verify_regular_channel (P_event_channel_name, ectep, P_code); if P_code ^= 0 then return; wait_channel.inhibit_count = wait_channel.inhibit_count + P_inhibit_value; if wait_channel.inhibit_count < 0 then do; wait_channel.inhibit_count = 0; P_code = error_table_$event_channel_not_cutoff; end; end set_inhibit_switch; %page; set_priority_switch: procedure (P_priority_switch); dcl P_priority_switch bit (1) aligned parameter; P_code = 0; ect_header.flags.call_priority = P_priority_switch; end set_priority_switch; %page; set_mask: procedure (P_mask_value); dcl P_mask_value fixed bin; P_code = 0; ect_header.mask_call_count = ect_header.mask_call_count + P_mask_value; if ect_header.mask_call_count < 0 /* logical error, unpaired mask/unmask */ then do; ect_header.mask_call_count = 0; /* reset mask to 0 */ P_code = error_table_$event_calls_not_masked; /* code = logical error in use of IPC */ end; end set_mask; %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; /* 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) = ON 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. */ unmask_ips_interrupts_caller: entry (P_mask); call unmask_ips_interrupts (P_mask); return; %page; /* Report that the ECT is inconsistent -- This procedure will never return as ipc_util_$ect_error_handler generates a fatal process error */ inconsistent_ect: procedure (); call unmask_ips_interrupts (mask); call ipc_util_$ect_error_handler (error_table_$inconsistent_ect); end inconsistent_ect; /* 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; hardcore_block: procedure (); /**** This procedure merely calls hardcore to block the process (or not, if there are new event wakeups). It makes sure that the validation level is set to the current ring before doing so. */ if cur_ring ^= block_val then call cu_$level_set (cur_ring); call hcs_$fblock (ipc_data_$fast_channel_events, ("0"b)); if cur_ring ^= block_val then call cu_$level_set (block_val); return; end hardcore_block; %page; /* Determines if more than one control point is defined in this process */ have_multiple_control_points: procedure () returns (bit (1) aligned); if stackbaseptr () -> stack_header.cpm_enabled then return (cpm_data_$n_control_points > 1); else return (NO); end have_multiple_control_points; %page; /* Adds the current control point to the list of control points waiting for an event to be signalled on each of the channels in a call to ipc_$block */ add_to_waiting_lists: procedure (); dcl loop fixed binary; do loop = 1 to event_wait_list_n_channels; /* insure that all the channels are OK first */ call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), P_code); if P_code ^= 0 then return; if wait_channel.type ^= WAIT then do; P_code = error_table_$not_a_wait_channel; return; end; end; call mask_ips_interrupts (mask); do loop = 1 to event_wait_list_n_channels; call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), (0)); do wcpp = wait_channel.first_wcpp repeat (waiting_control_point.next_wcpp) while (wcpp ^= null ()); if waiting_control_point.control_point_id = current_control_point_id then do; /* this control point is already blocked on this channel */ waiting_control_point.block_count = waiting_control_point.block_count + 1; go to PROCESS_NEXT_CHANNEL; end; end; /*** Current control point not already blocked on this channel -- Setup another waiting_control_point for the channel */ call ipc_util_$make_entry (ect_ptr, WAITING_CP, wcpp, (0)); waiting_control_point.control_point_id = current_control_point_id; waiting_control_point.block_count = 1; if wait_channel.first_wcpp = null () then do; /* first control point for this channel */ if wait_channel.last_wcpp ^= null () then call inconsistent_ect (); wait_channel.first_wcpp = wcpp; waiting_control_point.prev_wcpp = null (); end; else do; /* add to the end of the list for this channel */ if wait_channel.last_wcpp = null () then call inconsistent_ect (); if wait_channel.last_wcpp -> waiting_control_point.next_wcpp ^= null () then call inconsistent_ect (); wait_channel.last_wcpp -> waiting_control_point.next_wcpp = wcpp; waiting_control_point.prev_wcpp = wait_channel.last_wcpp; end; wait_channel.last_wcpp = wcpp; /* this control point is now the tail of the list */ waiting_control_point.next_wcpp = null (); PROCESS_NEXT_CHANNEL: end; added_to_waiting_lists = YES; call unmask_ips_interrupts (mask); end add_to_waiting_lists; %page; /* Make the current control point BLOCKED -- If, however, there are either wait or call events pending which are destined for this control point, we must not enter the BLOCKED state. If we did block, we would remain blocked until another event arrived which could possibly never happen. */ block_if_no_pending_events: procedure (); dcl loop fixed binary; /* First check the channels on which we are blocked */ do loop = 1 to event_wait_list_n_channels; call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), P_code); if P_code ^= 0 then return; if wait_channel.type ^= WAIT then do; P_code = error_table_$not_a_wait_channel; return; end; if wait_channel.fast_channel = YES then if substr (ipc_data_$fast_channel_events, wait_channel.fast_channel_id, 1) = YES then return; else ; else /*** if wait_channel.fast_channel = NO then */ if wait_channel.first_ev_msgp ^= null () then return; else ; end; /* No events for any of the above channels -- Check all call channels */ do ectep = ect_header.firstp (CALL) repeat (call_channel.next_chanp) while (ectep ^= null ()); if call_channel.type ^= CALL then call inconsistent_ect (); if call_channel.control_point_id = current_control_point_id then if call_channel.first_ev_msgp ^= null () then return; end; /* Control arrives here iff there are no events already present for this control point -- Block. */ call cpm_$block (); return; end block_if_no_pending_events; %page; /* Removes the current control point from the above lists -- A non-quick version of this procedure follows on the next page*/ delete_from_waiting_lists: procedure (); dcl code fixed binary (35); dcl loop fixed binary; call mask_ips_interrupts (mask); do loop = 1 to event_wait_list_n_channels; call ipc_util_$verify_channel (event_wait_list.channel_id (loop), ectep, ("0"b), code); if code ^= 0 /* the channel is no longer OK: skip it */ then go to PROCESS_NEXT_CHANNEL; if wait_channel.type ^= WAIT /* the channel is no longer a wait channel: skip it */ then go to PROCESS_NEXT_CHANNEL; do wcpp = wait_channel.first_wcpp repeat (waiting_control_point.next_wcpp) while (wcpp ^= null ()); if waiting_control_point.control_point_id = current_control_point_id then do; /* found the proper entry */ if waiting_control_point.block_count = 1 then do; /* this is the only time we were waiting on this channel */ if waiting_control_point.prev_wcpp = null () then do; /* this was the first control point for this channel */ if wait_channel.first_wcpp ^= wcpp then call inconsistent_ect (); wait_channel.first_wcpp = waiting_control_point.next_wcpp; end; else do; /* remove this control point from the middle of the list */ if waiting_control_point.prev_wcpp -> waiting_control_point.next_wcpp ^= wcpp then call inconsistent_ect (); waiting_control_point.prev_wcpp -> waiting_control_point.next_wcpp = waiting_control_point.next_wcpp; end; if waiting_control_point.next_wcpp = null () then do; /* this is the last control point for this channel */ if wait_channel.last_wcpp ^= wcpp then call inconsistent_ect (); wait_channel.last_wcpp = waiting_control_point.prev_wcpp; end; else do; /* remove this control point from the middle of the list */ if waiting_control_point.next_wcpp -> waiting_control_point.prev_wcpp ^= wcpp then call inconsistent_ect (); waiting_control_point.next_wcpp -> waiting_control_point.prev_wcpp = waiting_control_point.prev_wcpp; end; call ipc_util_$delete_entry (ect_ptr, wcpp); end; else waiting_control_point.block_count = waiting_control_point.block_count - 1; /* this control point is still waiting on this channel */ go to PROCESS_NEXT_CHANNEL; end; end; call inconsistent_ect (); /* we aren't on the channel's list but we should be */ PROCESS_NEXT_CHANNEL: end; added_to_waiting_lists = NO; call unmask_ips_interrupts (mask); end delete_from_waiting_lists; /* Invoke delete_from_waiting_lists -- This entrypoint exists to prevent making the delete_from_waiting_lists internal procedure non-quick by invoking it from within an on unit. */ delete_from_waiting_lists_caller: entry (P_event_wait_list_ptr); call find_ectp (); event_wait_list_ptr = P_event_wait_list_ptr; event_wait_list_n_channels = event_wait_list.n_channels; current_control_point_id = get_control_point_id_ (); mask = ""b; /* for any_other handler */ on any_other call any_other_handler (); call delete_from_waiting_lists (); return; %page; /* Wakeup blocked control points -- If a control point is blocked on an event wait channel, it must be notified when a message arrives on that channel. Further, if a message arrives for an event call channel, the control point which "owns" that channel must be notified. */ wakeup_blocked_control_points: procedure (); dcl 1 a_wait_channel like wait_channel aligned based (an_ectep); dcl 1 a_call_channel like call_channel aligned based (an_ectep); dcl an_ectep pointer; do an_ectep = ect_header.firstp (WAIT) repeat (a_wait_channel.next_chanp) while (an_ectep ^= null ()), ect_header.firstp (CALL) repeat (a_call_channel.next_chanp) while (an_ectep ^= null ()); if a_wait_channel.wakeup_control_points = YES then call wakeup_channel_control_points (an_ectep); end; ect_header.wakeup_control_points = NO; return; end wakeup_blocked_control_points; /* Wakeup the control points waiting on a single channel */ wakeup_channel_control_points: procedure (p_ectep); dcl p_ectep pointer parameter; dcl 1 p_call_channel like call_channel aligned based (p_ectep); dcl 1 p_wait_channel like wait_channel aligned based (p_ectep); if p_wait_channel.type = WAIT then do; /* a wait channel */ do wcpp = p_wait_channel.first_wcpp repeat (waiting_control_point.next_wcpp) while (wcpp ^= null ()); call cpm_$wakeup (waiting_control_point.control_point_id, (0)); end; p_wait_channel.wakeup_control_points = NO; end; else do; /* a call channel */ call cpm_$wakeup (p_call_channel.control_point_id, (0)); p_call_channel.wakeup_control_points = NO; end; return; end wakeup_channel_control_points; %page; /* Resets a channel's waiting control points -- Any control points blocked on the channel are sent wakeups so that they may run and find that the channel has either been deleted or converted to an event call channel. The list of waiting control points is then deleted from the ECT. */ reset_channel_wcps: procedure (); dcl next_wcpp pointer; if (have_multiple_control_points () = YES) & (wait_channel.wakeup_control_points = YES) then call wakeup_channel_control_points (ectep); if wait_channel.first_wcpp ^= null () then do; do wcpp = wait_channel.first_wcpp repeat (next_wcpp) while (wcpp ^= null ()); next_wcpp = waiting_control_point.next_wcpp; call ipc_util_$delete_entry (ect_ptr, wcpp); end; wait_channel.first_wcpp, wait_channel.last_wcpp = null (); end; return; end reset_channel_wcps; /* format: off */ %page; %include ect_structures; %page; %include event_call_info; %page; %include event_channel_name; %page; %include event_wait_info; %page; %include event_wait_list; %page; %include ipc_create_arg; %page; %include stack_header; %page; %include cpm_entries; %page; %include cpm_data_; /* format: on */ end ipc_real_;  ipc_util_.pl1 11/11/89 1144.0rew 11/11/89 0803.3 171819 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3 */ /* IPC_UTIL_: This is a collection of primitives used by the Interprocess Communication Facility (IPC). These are internal interfaces and not intended to be called by any modules outside of IPC. The entries within ipc_util_ include those to create, retrieve, and delete event channels as well as those to validate, encode, and decode the event channel names. */ /* Rewritten from ipcprm_ for new ipc by E Donner Jan l981 Modified 1984-10-28 by E. Swenson for new IPC validation. */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206): Changed to support control point management. These changes were actually made in February 1985 by G. Palter. 2) change(86-08-12,Kissel), approve(86-08-12,MCR7479), audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206): Changed entry_type to fixed bin (8) and changed the code to verify the encoded flags in an event channel name. All this to support async event channels. END HISTORY COMMENTS */ ipc_util_: procedure (); return; /* not an entry */ /* Automatic */ dcl code fixed bin (35); dcl ecit_idx fixed bin (15) unsigned; /* Index into ECIT */ dcl ect_area_ptr ptr; dcl ect_area_size fixed bin (19); dcl entry_type fixed bin (8); dcl 1 info_for_area like area_info aligned; dcl system_area_ptr ptr; /* Based */ dcl ect_area area (ect_area_size) based (ect_area_ptr); dcl system_area area based (system_area_ptr); /* Constants */ dcl AREA_OVERHEAD fixed bin (17) initial (36) internal static options (constant); /* area header + extend block */ dcl BLOCK_OVERHEAD fixed bin (17) initial (2) internal static options (constant); /* for each allocation */ dcl DEFAULT_N_ECT_ENTRIES fixed bin (17) initial (64) internal static options (constant); /* default number used in calculating initial area size */ dcl INITIAL_SEED fixed bin (33) initial (1) internal static options (constant); dcl ON bit (1) aligned static options (constant) init ("1"b); dcl NO bit (1) aligned static options (constant) init ("0"b); dcl ALLOW_FAST_CHANNELS bit (1) aligned initial ("1"b) internal static options (constant); dcl DO_NOT_ALLOW_FAST_CHANNELS bit (1) aligned initial ("0"b) internal static options (constant); /* External Entries */ dcl define_area_ entry (ptr, fixed bin (35)); dcl get_ring_ entry returns (fixed bin (3)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$get_ipc_operands entry (fixed bin (18), fixed bin (35)); dcl ipc_real_$create_fast_ev_chn entry (fixed binary (18), fixed binary (35)); dcl ipc_validate_$decode_event_channel_name entry (fixed bin (18), fixed bin (35), fixed bin (71), bit (3) aligned, fixed bin (15), fixed bin (3), bit (1) aligned, fixed bin (18), fixed bin (35)); /* External Static */ dcl error_table_$ect_already_initialized fixed bin (35) external; dcl error_table_$ect_full fixed bin (35) external; dcl error_table_$inconsistent_ect fixed bin (35) external; dcl error_table_$invalid_channel fixed bin (35) external; dcl error_table_$special_channel fixed bin (35) external; dcl error_table_$wrong_channel_ring fixed bin (35) external; dcl ipc_data_$fast_channel_events bit (36) aligned external; dcl sys_info$max_seg_size fixed bin (19) external; /* Conditions */ dcl area condition; /* Builtins */ dcl addr builtin; dcl binary builtin; dcl empty builtin; dcl length builtin; dcl mod builtin; dcl null builtin; dcl size builtin; dcl stackbaseptr builtin; dcl string builtin; dcl substr builtin; dcl unspec builtin; %page; create_ect: entry (a_ect_ptr); /**** Entry to create the Event Channel Table for the current ring. It initializes the ECT header and creates the Event Channel Index Table. */ dcl a_ect_ptr ptr parameter; on area call ect_error_handler (error_table_$ect_full); call CREATE_ECT (); a_ect_ptr = ect_ptr; return; %page; create_single_seg_ect: entry (a_code); /**** This entry creates an Event Channel Table for the current ring that is not located in the system area, but is located in a segment dedicated to the ECT. */ dcl a_code fixed bin (35) parameter; if stackbaseptr () -> stack_header.ect_ptr ^= null then do; /* ect has been created before */ a_code = error_table_$ect_already_initialized; return; end; a_code = 0; ect_area_size = sys_info$max_seg_size; ect_area_ptr = null; /* This causes define_area_ to create new seg */ on area call ect_error_handler (error_table_$ect_full); call initialize_ect; return; %page; make_entry: entry (a_ect_ptr, a_type, a_ectep, a_ecit_idx); /**** This entry creates a fresh ECTE. The type created (WAIT or CALL) is specified in the parameter a_type. It returns a pointer to this ECTE in a_ectep. Currently this entry is only used to create WAIT and CALL ECTEs. If it is ever used to create other types (e.g. EV_WAIT_MESSAGE, etc.), then care must be taken to avoid setting up an ECITE for the ECTE. delete_entry must be made aware of these changes as well. This entry returns the ECIT index for use in event channel name manipulation. The modularization here should be changed to maintain the ECIT index as an internal value to ipc_util_, but this can be done at a later time. */ dcl a_ectep ptr parameter; dcl a_type fixed bin (8) parameter; dcl a_ecit_idx fixed bin (15); call SETUP (); entry_type = a_type; /* check for inconsistency before creating new entry */ call check_ect_consistency; /* allocate new entry - assume that entries of all types are the same size */ ect_area_size = ect_header.ect_area_size; on area call ect_error_handler (error_table_$ect_full); allocate wait_channel in (ect_header.ect_areap -> ect_area) set (ectep); unspec (wait_channel) = ""b; wait_channel.type = entry_type; /* make an entry in the event_channel_index table */ ecit_idx = 0; if entry_type = CALL | entry_type = WAIT then do; ecit_idx = FIND_ECIT_ENTRY (); if ecit_idx = 0 then /* Should never happen */ call ect_error_handler (error_table_$ect_full); ecit.ecte_ptr (ecit_idx) = ectep; end; /* update count in ect header */ ect_header.count (TOTAL) = ect_header.count (TOTAL) + 1; if entry_type = WAITING_CP then ect_header.count (WAITING_CP) = ect_header.count (WAITING_CP) + 1; a_ectep = ectep; a_ecit_idx = ecit_idx; return; %page; delete_entry: entry (a_ect_ptr, a_ectep); /**** This entry will delete an ECTE entry. It is used to delete entries like WAIT and CALL entries as well as EV_WAIT_MESSAGE and other entry types. Care must be taken to "do the right thing" with respect to the ECITEs. */ call SETUP (); ectep = a_ectep; entry_type = wait_channel.type; /**** Remove the event channel index table entry from use. Note that delete_entry is called to delete entries which are other than CALL or WAIT (e.g., EV_CALL_MESSAGE or WAITING_CP). Therefore, since we only set up ECIT entries for WAITs or CALLs, we mustn't try to search for the ECITE for other types. */ if entry_type = WAIT | entry_type = CALL then do; ecit_idx = GET_ECIT_IDX (ectep); if ecit_idx = 0 then /* Should never happen */ call ect_error_handler (error_table_$inconsistent_ect); else ecit.ecte_ptr (ecit_idx) = null (); end; /* update count in header */ if entry_type = WAITING_CP then ect_header.count (WAITING_CP) = ect_header.count (WAITING_CP) - 1; ect_header.count (TOTAL) = ect_header.count (TOTAL) - 1; /* free entry */ free wait_channel; call check_ect_consistency; a_ectep = null; return; %page; verify_channel: entry (P_event_channel_name, P_ectep, P_fast_channel, P_code); /**** This entrypoint verifies a given event channel name. P_code can be error_table_$invalid_channel_ring, error_table_$invalid_channel, or 0. P_fast_channel is set to "1"b if the channel is a fast channel, otherwise it is set to "0"b. */ dcl P_event_channel_name fixed binary (71) parameter; dcl P_ectep pointer parameter; dcl P_fast_channel bit (1) aligned parameter; dcl P_code fixed binary (35) parameter; on area call ect_error_handler (error_table_$ect_full); call FIND_ECTP (); call VERIFY_CHANNEL (ALLOW_FAST_CHANNELS); return; %page; verify_regular_channel: entry (P_event_channel_name, P_ectep, P_code); /**** This entrypoint verifies a given event channel name. If the event channel name is invalid, P_code is set to error_table_$invalid_channel. If the event channel name specifies a fast channel, P_code is set to error_table_$special_channel. Otherwise P_ectep will point to a valid ECTE describing the channel. */ on area call ect_error_handler (error_table_$ect_full); call FIND_ECTP (); call VERIFY_CHANNEL (DO_NOT_ALLOW_FAST_CHANNELS); return; %page; ect_error_handler: entry (a_status_code); /**** This entry is called when some fatal situation is detected in the ECT structures. It destroys the process with an appropriate error message. */ dcl a_status_code fixed bin (35) parameter; dcl 1 term_structure aligned, 2 version fixed bin, 2 fatal_code fixed bin (35); dcl terminate_process_ entry (char (*), ptr); term_structure.version = 0; term_structure.fatal_code = a_status_code; call terminate_process_ ("fatal_error", addr (term_structure)); return; %page; check_ect_consistency: procedure (); /**** This internal procedure attempts to check the consistency of the counts in the ECT header. */ if ect_header.count (TOTAL) ^= ect_header.count (WAIT) + ect_header.count (CALL) + ect_header.count (ITT_MESSAGE) + ect_header.count (EV_CALL_MESSAGE) + ect_header.count (EV_WAIT_MESSAGE) + ect_header.count (WAITING_CP) then call ect_error_handler (error_table_$inconsistent_ect); end check_ect_consistency; %page; initialize_ect: procedure (); /**** This internal procedure is called if no ECT exists for the current ring. It initializes the ECT. */ dcl ev_chn_unique_id fixed binary (18); dcl code fixed binary (35); /* now define characteristics of ect area */ info_for_area.version = area_info_version_1; info_for_area.owner = "ipc"; info_for_area.size = ect_area_size; info_for_area.areap = ect_area_ptr; string (info_for_area.control) = "0"b; info_for_area.control.extend = ON; info_for_area.control.zero_on_free = ON; info_for_area.control.system = ON; call define_area_ (addr (info_for_area), code); if code ^= 0 then call ect_error_handler (code); ect_area_ptr = info_for_area.areap; /* may have been set by define_area_ */ /* allocate header in new ect area */ /* and set initial values */ allocate ect_header in (ect_area) set (ect_ptr); unspec (ect_header) = ""b; ect_header.firstp (*), ect_header.lastp (*) = null; ect_header.ect_area_size = ect_area_size; ect_header.ect_areap = ect_area_ptr; ect_header.seed = INITIAL_SEED; /* Allocate the Event Channel Index Table */ call ALLOCATE_ECIT (DEFAULT_N_ECT_ENTRIES); ect_header.ecit_ptr = ecit_ptr; ect_header.ecit_lth = ecit_lth; /**** Retrieve the IPC validation operands from the APTE. These values were initialized at process creation time and are used to validate event channel wakeups destined for this process. They are also used to decode the event channel name and to extract the ECIT index from the event channel name. */ call hcs_$get_ipc_operands (ect_header.r_offset, ect_header.r_factor); /* set ect_ptr in stack header */ stackbaseptr () -> stack_header.ect_ptr = ect_ptr; /* Create WAIT channel definitions for all possible fast channels. These entries are only used when control point management is enabled to track the control points which have blocked on the fast channels. */ do ev_chn_unique_id = 1 to length (ipc_data_$fast_channel_events); call ipc_real_$create_fast_ev_chn (ev_chn_unique_id, code); if code ^= 0 then call ect_error_handler (code); end; return; end initialize_ect; %page; ALLOCATE_ECIT: procedure (size); /**** This procedure allocates and initializes an Event Channel Index Table (ECIT) in the current ECT area. */ dcl size fixed bin (17) parameter; ecit_ptr = null (); /* Nullify this global variable */ ecit_lth = size; /**** Already have a handler for the "area" condition */ allocate ecit in (ect_header.ect_areap -> ect_area) set (ecit_ptr); ecit.ecte_ptr (*) = null (); return; end ALLOCATE_ECIT; %page; FIND_ECIT_ENTRY: procedure () returns (fixed bin (15) unsigned); /**** This procedure searches through the current event channel index table for a free entry. If one is found, the index of this entry is returned. If none is available, then a new ECIT is allocated, the old ECIT entries copied into the new table and the old table freed.*/ dcl ecit_idx fixed bin (15) unsigned; dcl old_ecit_ptr ptr; dcl old_ecit_lth fixed bin (17); dcl 1 old_ecit aligned based (old_ecit_ptr), 2 ecte_ptr (old_ecit_lth) ptr unaligned; do ecit_idx = 1 to ecit_lth; if ecit.ecte_ptr (ecit_idx) = null () then return (ecit_idx); /* found a free slot */ end; /**** There are no free entries in the current ECIT table. For the time being, until we come up with a better algorithm, allocate a new table twice the size of the current table. */ old_ecit_ptr = ecit_ptr; old_ecit_lth = ecit_lth; call ALLOCATE_ECIT (ecit_lth * 2); ect_header.ecit_ptr = ecit_ptr; ect_header.ecit_lth = ecit_lth; /**** Copy old table into the new table */ do ecit_idx = 1 to old_ecit_lth; ecit.ecte_ptr (ecit_idx) = old_ecit.ecte_ptr (ecit_idx); end; free old_ecit; /* Free up the old table */ return (old_ecit_lth + 1); /* one past end of old data */ end FIND_ECIT_ENTRY; %page; GET_ECIT_IDX: procedure (P_ectep) returns (fixed bin (15) unsigned); /**** This internal procedure returns the ECIT index given a pointer to the event channel entry. */ dcl P_ectep ptr parameter; dcl 1 ev_chn_name aligned like event_channel_name automatic; dcl ecit_idx fixed bin (15) unsigned; dcl temp fixed bin (71); dcl encoded_index_binary fixed bin (18) unsigned; dcl 1 encoded_index structure aligned automatic, 2 flags bit (3) unaligned, 2 index fixed bin (15) unsigned unaligned; unspec (ev_chn_name) = unspec (P_ectep -> wait_channel.name); temp = binary (ev_chn_name.encoded_index, 18); encoded_index_binary = mod (temp - ect_header.r_offset, 262144); unspec (encoded_index) = substr (unspec (encoded_index_binary), 19, 18); ecit_idx = encoded_index.index; if ecit_idx > ect_header.ecit_lth then ecit_idx = 0; return (ecit_idx); end GET_ECIT_IDX; %page; VERIFY_CHANNEL: procedure (allow_fast_channels); /**** This internal procedure uses the implicit arguments from the verify_channel and verify_regular_channel entrypoints. */ dcl allow_fast_channels bit (1) aligned parameter; dcl code fixed bin (35); dcl ecit_idx fixed bin (15) unsigned; dcl ev_chn_flags bit (3) aligned; dcl ev_chn_index fixed bin (15); dcl ev_chn_ring fixed bin (3); dcl ev_chn_type bit (1) aligned; dcl ev_chn_unique_id fixed bin (18); dcl event_channel_name fixed bin (71); P_ectep = null (); P_code = 0; event_channel_name = P_event_channel_name; call ipc_validate_$decode_event_channel_name (ect_header.r_offset, ect_header.r_factor, event_channel_name, ev_chn_flags, ev_chn_index, ev_chn_ring, ev_chn_type, ev_chn_unique_id, code); if code ^= 0 then do; P_code = code; return; end; if ev_chn_flags ^= NORMAL_CHANNEL_FLAGS & ev_chn_flags ^= SEND_IPS_WKP_CHANNEL_FLAGS then INVALID_CHANNEL: do; P_code = error_table_$invalid_channel; return; end; if ev_chn_ring ^= get_ring_ () then do; P_code = error_table_$wrong_channel_ring; return; end; if ev_chn_type = FAST_CHANNEL_TYPE /* claims to be a fast channel */ then if ev_chn_unique_id > length (ipc_data_$fast_channel_events) then goto INVALID_CHANNEL; ecit_idx = ev_chn_index; if ecit_idx > ecit_lth then goto INVALID_CHANNEL; ectep = ecit.ecte_ptr (ecit_idx); if ectep = null () then goto INVALID_CHANNEL; if ectep -> wait_channel.name ^= unspec (event_channel_name) then goto INVALID_CHANNEL; /**** Things look ok, give caller what he/she wanted. */ if allow_fast_channels then P_fast_channel = (ev_chn_type = FAST_CHANNEL_TYPE); else if ev_chn_type = FAST_CHANNEL_TYPE then do; /* a fast channel and the caller doesn't want one */ P_code = error_table_$special_channel; return; end; P_ectep = ectep; return; end VERIFY_CHANNEL; %page; FIND_ECTP: procedure (); /**** Internal procedure to get a pointer to the ECT for this ring. If there is none, one will be created. */ ect_ptr = stackbaseptr () -> stack_header.ect_ptr; if ect_ptr = null () then call CREATE_ECT (); ecit_ptr = ect_header.ecit_ptr; ecit_lth = ect_header.ecit_lth; return; end FIND_ECTP; %page; SETUP: procedure (); /**** This internal procedure copies the parameter a_ect_ptr into ect_ptr and gets the ECIT variables necessary to reference the ECIT. */ ect_ptr = a_ect_ptr; ecit_ptr = ect_header.ecit_ptr; ecit_lth = ect_header.ecit_lth; return; end SETUP; %page; CREATE_ECT: procedure (); /* The ect is an extensible area which is allocated in system free area */ /* it is an area so that header and ect entries will be clustered */ system_area_ptr = get_system_free_area_ (); /* calculate room for reasonable number of ectes, ect header and extend block */ ect_area_size = AREA_OVERHEAD + size (ect_header) + DEFAULT_N_ECT_ENTRIES * size (wait_channel) + (DEFAULT_N_ECT_ENTRIES + 2) * BLOCK_OVERHEAD + DEFAULT_N_ECT_ENTRIES + BLOCK_OVERHEAD; /* one word for each entry in ecit */ allocate ect_area in (system_area) set (ect_area_ptr); call initialize_ect; return; end CREATE_ECT; /* format: off */ %page; %include area_info; %page; %include ect_structures; %page; %include event_channel_name; %page; %include stack_header; /* format: on */ end ipc_util_;  set_lock_.pl1 11/11/89 1144.0rew 11/11/89 0803.3 81432 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ /* set_lock_ -- This procedure allows a user to guarantee that two processes will not simultaneously execute the same critical section of code. A user provided lock word can be set to the lock identifier of only one process at a time thereby guaranteeing, assuming the proper conventions are followed, that only this process can be currently executing in the critical section of code. Originally coded by R. J. Feiertag on November 5, 1971 Modified on April 6, 1972 by R. J. Feiertag to work in all rings. Fixed by THVV 10/75 to work even if alrm is masked Modified by M. Pierret 03/80 , adding no_write_permission condition handler, stacq and clock builtins, and avoiding clock on waittime=0 and on 04/24/80 not_in_write_bracket condition. */ /****^ HISTORY COMMENTS: 1) change(71-11-05,Feiertag), approve(), audit(), install(): Written by R. J. Feiertag. 2) change(72-04-06,Feiertag), approve(), audit(), install(): Modified by R. J. Feiertag to work in all rings. 3) change(75-10-01,VanVleck), approve(), audit(), install(): Modified by THVV 10/75 to work even if alrm is masked 4) change(80-04-24,Pierret), approve(), audit(), install(): Modified by M. Pierret 03/80, adding no_write_permission condition handler, stacq and clock builtins, and avoiding clock on waittime=0 and on 04/24/80, not_in_write_bracket condition handler 5) change(85-01-09,Lippard), approve(85-01-30,MCR7159), audit(85-11-07,Spitzer), install(86-02-21,MR12.0-1024): Modified by Jim Lippard to add no_write_permission condition handler to set_lock_$unlock. 6) change(86-08-12,Kissel), approve(86-08-12,MCR7473), audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206): Changed to support control point management. These changes were actually done in April 1985 by G. Palter. The main change was to always use timer_manager_$sleep as that entrypoint was updated in 1979 to work in any ring regardless of the state of the alrm IPS signal. This change had to be made as the old code herein did not work with multiple control points. END HISTORY COMMENTS */ /* format: style3,linecom */ set_lock_: procedure (); return; /* not an entrypoint */ /* Parameters */ dcl lock bit (36) aligned parameter; /* lock word */ dcl wait_time fixed binary parameter; /* time in seconds to wait for lock to be unlocked */ dcl status fixed binary (35) parameter; /* Static data -- Initialized once per ring */ dcl first_invocation bit (1) aligned static initial ("1"b); dcl lock_id bit (36) aligned static; /* our process lock ID */ /* Remaining declarations */ dcl failure_time fixed binary (71); dcl sleep_time fixed binary (71); dcl ttul_code fixed binary; dcl ( error_table_$invalid_lock_reset, error_table_$lock_not_locked, error_table_$lock_wait_time_exceeded, error_table_$locked_by_other_process, error_table_$locked_by_this_process, error_table_$no_w_permission ) fixed binary (35) external; dcl get_lock_id_ entry (bit (36) aligned); dcl hcs_$try_to_unlock_lock entry (pointer, fixed binary); dcl timer_manager_$sleep entry (fixed binary (71), bit (2)); dcl (addr, clock, min, stacq) builtin; dcl (no_write_permission, not_in_write_bracket) condition; dcl AVERY_LONG_TIME fixed bin (71) /* (2**52) microseconds) */ init (10000000000000000000000000000000000000000000000000000b) static options (constant); dcl ONE_SEC_MICRO fixed bin (35) init (1000000) static options (constant); dcl IN_MICRO bit (2) init ("10"b) static options (constant); %page; /* format: off */ /* set_lock_$lock -- This entry attempts to set the lock word to the lock identifier of the calling process. If the lock is already set by some other existing process then it waits for some given period of time for the lock to be unlocked. If the lock is not unlocked in the given time then set_lock_ gives up and returns. dcl set_lock_$lock entry (bit(36) aligned, fixed binary, fixed binary (35)); call set_lock_$lock (lock, wait_time, status); where: lock (Input/Output) is the lock word. wait_time (Input) is the number of seconds to wait for the lock to be unlocked. If wait_time is zero, set_lock_$lock will never wait if the lock is already locked. If wait_time is negative, set_lock_$lock will wait forever for the lock to be unlocked. status (Output) is a standard system status code. It may take on one of the following values: 0 the lock was successfully locked and was not previously locked. error_table_$lock_wait_time_exceeded the lock was validly locked, we waited the requested period but the lock was not unlocked. error_table_$locked_by_this_process the lock was already locked by this process. error_table_$invalid_lock_reset the lock was successfully locked but was previously locked with an invalid lock ID. (E.g., a dead process) error_table_$no_w_permission the caller does not have the necessary access (write) to lock the supplied lock. */ /* format: on */ set_lock_$lock: entry (lock, wait_time, status); if first_invocation /* first time in this ring */ then call initialize_set_lock (); on no_write_permission, not_in_write_bracket begin; status = error_table_$no_w_permission; go to RETURN_FROM_SET_LOCK; end; failure_time = 0; do while ("1"b); /* forever */ if stacq (lock, lock_id, "0"b) /* try the lock */ then call return_from_set_lock (0); /* ... got it */ call hcs_$try_to_unlock_lock (addr (lock), ttul_code); if ttul_code = 3 /* ring 0 reset an invalid lock and relocked it for us */ then call return_from_set_lock (error_table_$invalid_lock_reset); if ttul_code ^= 2 then do; /* it's locked by a live process */ if lock = lock_id /* already locked by this process */ then call return_from_set_lock (error_table_$locked_by_this_process); if wait_time = 0 then sleep_time = 0; /* caller does not want to wait */ else do; /* either wait forever or for the requested time */ if failure_time = 0 /* ... determine when to give up */ then if wait_time < 0 then failure_time = AVERY_LONG_TIME; /* ... wait forever (2**52 microseconds) */ else failure_time = clock () + wait_time * ONE_SEC_MICRO; /* ... wait the specified number of seconds */ sleep_time = failure_time - clock (); end; /* ... compute how long to sleep */ if sleep_time <= 0 /* we've waited long enough */ then call return_from_set_lock (error_table_$lock_wait_time_exceeded); /*** We need to sleep before trying the lock again -- As of 1979, timer_manager_$sleep will work in any ring and will also work when the alrm IPS signal is masked. */ call timer_manager_$sleep (min (sleep_time, ONE_SEC_MICRO), IN_MICRO); end; end; %page; /* set_lock_$unlock -- This entry unlocks a lock word that is set to the calling process's lock identifier. dcl set_lock_$unlock entry (bit(36) aligned, fixed binary (35)); call set_lock_$unlock (lock, status); where: lock (Input/Output) is the lock word. status (Output) is a standard system status code. */ set_lock_$unlock: entry (lock, status); if first_invocation /* first time in this ring */ then call initialize_set_lock (); if stacq (lock, "0"b, lock_id) then call return_from_set_lock (0); /* we unlocked it */ else if lock = ""b /* it wasn't locked */ then call return_from_set_lock (error_table_$lock_not_locked); else call return_from_set_lock (error_table_$locked_by_other_process); %page; /* Set the status code and return to our caller */ return_from_set_lock: procedure (p_status); dcl p_status fixed binary (35) parameter; status = p_status; go to RETURN_FROM_SET_LOCK; end return_from_set_lock; RETURN_FROM_SET_LOCK: return; /* Initialize the set_lock_ mechanism in this this ring */ initialize_set_lock: procedure (); call get_lock_id_ (lock_id); first_invocation = "0"b; return; end initialize_set_lock; end set_lock_;  timer_manager_.pl1 11/11/89 1144.0rew 11/11/89 0803.5 317016 /****^ ************************************************************** * * * Copyright, (C) Massachusetts Institute of Technology, 1982 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ************************************************************** */ /* format: style4,insnl,delnl,ifthendo */ timer_manager_: proc; return; /* This procedure provides to a user process the ability to schedule timers as if there were an infinite number of hardware timers available, by keeping a list of scheduled timers and intercepting all timer wakeups and interrupts. Dedicated to Peter Bishop, who did the best he could with the tools he had. LINES MARKED "DEBUG" and commented out should REMAIN commented out in the production version. They are only decommented for debugging. Entirely rewritten 12/03/79 by C. D. Tavares. Also added ability to sleep in inner ring and examine list of timers scheduled to occur in the process. */ /* Changed by E. Donner Jan 1981 to change calls to full_ipc_$ to ipc_$ for new ipc changes */ /* Modified by Benson I. Margulies, September 1981, for condition wall an alarm_call calls. */ /* Modified September 8, 1982 by Richard Lamson to add data pointer argument */ /* Modified by BIM, November 1982 to take condition wall back out. */ /****^ 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): Changed to support control point management. These changes were actually done in February 1985 by G. Palter. 2) change(86-12-10,Fawcett), approve(86-12-17,MECR0003), audit(86-12-15,GDixon), install(86-12-17,MR12.0-1250): Changed to fix the problem in Initializer use of timer_manager_. system_startup_ (Initializer ring 1 command level) calls timer_manager_$sleep in ring 1, causing initial_ring (in timer_manager_'s ring 1 internal static) to be set to 1 (since Initializer hasn't crossed out into ring 4 yet). After crossing to ring 4, when the Initializer calls into ring_1 to a function that requires timer_manager_$sleep, ring 1 internal static still thinks initial_ring is 1, rather than 4. It therefore uses the login_ring sleep protocol rather than the inner ring protocol, goes blocked in ring 1 and never awakens. The fix is to always call the internal proc initialize. In this proc a check is made for initial_ring = 1 and then if this is Initializer, then set the initialized_mechanisum to Uninitialized (0) and reinit in this ring. 3) change(87-01-13,Fawcett), approve(87-01-13,MCR7601), audit(87-01-13,GJohnson), install(87-01-13,MR12.0-1270): This closes MECR0003. 4) change(87-01-13,Lippard), approve(86-11-24,MCR7577), audit(87-01-14,Dickson), install(87-03-30,MR12.1-1018): Change actually made 86-10-29, bogus date is to satisfy hcom. Make timer_manager_$sleep unschedule timer in cleanup handler. END HISTORY COMMENTS */ dcl a_time fixed bin (71) parameter, /* desired time of event */ a_flags bit (2) parameter, /* 0=abs/1=rel; 0=usec/1=sec */ a_routine entry variable parameter, /* routine to call when timer goes off */ a_channel fixed bin (71) parameter; /* channel to wakeup over when timer goes off */ dcl area_ptr pointer parameter, /* get_schedule entry: pointer to user area */ a_code fixed bin (35) parameter; dcl a_mc_ptr pointer parameter, /* interrupt entries: machine conditions ptr pointer */ a_condition_name char (*) parameter, /* alrm or cput */ a_hc_mc_ptr pointer parameter, /* hardcore machine conditions ptr */ io_ptr pointer, /* we don't use this */ a_continue bit (1) aligned; /* resignal condition if we turn it on */ dcl a_call_timer_info_ptr pointer parameter; /* invoke_users_routine: data set by other control point */ dcl data_ptr pointer, data_ptr_provided bit (1) aligned; dcl call_timer_info_ptr pointer, call_timer_info_condition_name_lth fixed binary (21); /* static */ dcl ( allow_all_mask bit (36) aligned initial ((36)"1"b), alrm_cput_mask bit (36) aligned initial (""b), alrm_cput_quit_mask bit (36) aligned initial (""b), alrm_disabled_mask bit (36) aligned initial (""b), my_group_id char (32) initial (""), initial_ring fixed bin initial (-2), initialized_mechanism fixed bin initial (0), my_processid bit (36) initial (""b), start_alarm_list_ptr pointer initial (null), start_cpu_list_ptr pointer initial (null), free_bead_list_ptr pointer initial (null), saved_channel_array (5) fixed binary (71) initial ((5) - 1), saved_channel_count fixed binary initial (0), sys_areap pointer initial (null), this_ring fixed bin initial (-1) ) static; /* external static */ dcl error_table_$invalid_channel fixed bin (35) external static, error_table_$noalloc fixed bin (35) external static, sys_info$max_seg_size fixed bin (35) ext static; /* constants */ dcl ( Alarm bit (1) aligned initial ("1"b), CPU bit (1) aligned initial (""b), Initializer char (23) initial ("Initializer.SysDaemon.z"), Inhibit bit (1) aligned initial ("1"b), No_inhibit bit (1) aligned initial (""b), Call bit (1) aligned initial ("1"b), Wakeup bit (1) aligned initial (""b), Limited fixed bin initial (1), Full fixed bin initial (2), Uninitialized fixed bin initial (0), Absolute_setting fixed bin initial (2), Million fixed bin (35) initial (1f6), Forever fixed bin (71) initial (1f70b), All_IPS (1) char (32) aligned initial ("-all"), IPS_names (3) char (32) aligned initial ("alrm", "cput", "quit") ) static options (constant); /* entries */ dcl create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)), ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)), get_group_id_ entry () returns (char (32)), get_initial_ring_ entry returns (fixed bin), get_process_id_ entry returns (bit (36) aligned), get_ring_ entry returns (fixed bin), get_system_free_area_ entry returns (pointer), hcs_$assign_channel entry (fixed bin (71), fixed bin (35)), hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned), hcs_$get_alarm_timer entry (fixed bin (71), fixed bin (71)), hcs_$set_alarm_timer entry (fixed bin (71), fixed bin, fixed bin (71)), hcs_$set_automatic_ips_mask entry (bit (36) aligned, bit (36) aligned), hcs_$set_cpu_timer ext entry (fixed bin (71), fixed bin, fixed bin (71)), hcs_$get_ips_mask ext entry (bit (36) aligned), hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned), hcs_$wakeup entry (bit (36), fixed bin (71), char (8) aligned, fixed bin (35)), ipc_$block entry (pointer, pointer, fixed bin (35)); /* based */ dcl 1 bead aligned based, 2 next_ptr pointer, 2 info like schedule.timer; dcl 1 call_timer_info aligned based (call_timer_info_ptr), 2 routine entry (pointer, character (*), pointer, pointer) variable, 2 condition_name_lth fixed binary (21), 2 pad bit (36) aligned, 2 mc_ptr pointer, 2 hc_mc_ptr pointer, 2 data_ptr pointer, 2 condition_name character (call_timer_info_condition_name_lth refer (call_timer_info.condition_name_lth)) unaligned; dcl sys_area area (sys_info$max_seg_size) based (sys_areap); /* builtins and conditions */ dcl (addr, bool, clock, hbound, length, null, stackbaseptr, substr, unspec, vclock) builtin; dcl (area, cleanup) condition, timer_manager_err condition; /* format: off */ %page; %include timer_manager_schedule; %page; %include mc; %page; %include stack_header; %page; %include cpm_data_; %page; %include cpm_entries; /* format: on */ %page; alarm_call: entry (a_time, a_flags, a_routine); call set_data_ptr (4, data_ptr, data_ptr_provided); call schedule_timer (abs_time (a_time, a_flags, Alarm), Alarm, No_inhibit, Call, 0, a_routine, data_ptr, data_ptr_provided); return; %skip (2); alarm_call_inhibit: entry (a_time, a_flags, a_routine); call set_data_ptr (4, data_ptr, data_ptr_provided); call schedule_timer (abs_time (a_time, a_flags, Alarm), Alarm, Inhibit, Call, 0, a_routine, data_ptr, data_ptr_provided); return; %skip (2); cpu_call: entry (a_time, a_flags, a_routine); call set_data_ptr (4, data_ptr, data_ptr_provided); call schedule_timer (abs_time (a_time, a_flags, CPU), CPU, No_inhibit, Call, 0, a_routine, data_ptr, data_ptr_provided); return; %skip (2); cpu_call_inhibit: entry (a_time, a_flags, a_routine); call set_data_ptr (4, data_ptr, data_ptr_provided); call schedule_timer (abs_time (a_time, a_flags, CPU), CPU, Inhibit, Call, 0, a_routine, data_ptr, data_ptr_provided); return; %skip (2); alarm_wakeup: entry (a_time, a_flags, a_channel); call schedule_timer (abs_time (a_time, a_flags, Alarm), Alarm, No_inhibit, Wakeup, a_channel, signal_timer_manager_err, null, "0"b); return; %skip (2); cpu_wakeup: entry (a_time, a_flags, a_channel); call schedule_timer (abs_time (a_time, a_flags, CPU), CPU, No_inhibit, Wakeup, a_channel, signal_timer_manager_err, null, "0"b); return; %skip (2); sleep: entry (a_time, a_flags); call sleep (abs_time (a_time, a_flags, Alarm), "0"b); return; %skip (2); sleep_lss: entry (a_time, a_flags); call sleep (abs_time (a_time, a_flags, Alarm), "1"b); return; %skip (2); reset_alarm_call: entry (a_routine); call set_data_ptr (2, data_ptr, data_ptr_provided); call unschedule_timer (Alarm, Call, 0, a_routine, data_ptr, data_ptr_provided); return; %skip (2); reset_alarm_wakeup: entry (a_channel); call unschedule_timer (Alarm, Wakeup, a_channel, signal_timer_manager_err, null, "0"b); return; %skip (2); reset_cpu_call: entry (a_routine); call set_data_ptr (2, data_ptr, data_ptr_provided); call unschedule_timer (CPU, Call, 0, a_routine, data_ptr, data_ptr_provided); return; %skip (2); reset_cpu_wakeup: entry (a_channel); call unschedule_timer (CPU, Wakeup, a_channel, signal_timer_manager_err, null, "0"b); return; %skip (2); get_schedule: entry (area_ptr, schedule_ptr, a_code); call get_schedule (area_ptr, schedule_ptr, a_code); return; %skip (2); /* The following two entries are entries called by the system when timers go off */ alarm_interrupt: entry (a_mc_ptr, a_condition_name, a_hc_mc_ptr, io_ptr, a_continue); call process_interrupt (Alarm, a_mc_ptr, a_condition_name, a_hc_mc_ptr, a_continue); return; %skip (2); cpu_time_interrupt: entry (a_mc_ptr, a_condition_name, a_hc_mc_ptr, io_ptr, a_continue); call process_interrupt (CPU, a_mc_ptr, a_condition_name, a_hc_mc_ptr, a_continue); return; %skip (10); invoke_users_routine: entry (a_call_timer_info_ptr); call_timer_info_ptr = a_call_timer_info_ptr; on cleanup begin; if call_timer_info_ptr ^= null () then free call_timer_info in (sys_area); call_timer_info_ptr = null (); end; call call_timer_info . routine (call_timer_info.mc_ptr, call_timer_info.condition_name, call_timer_info.hc_mc_ptr, call_timer_info.data_ptr); free call_timer_info in (sys_area); call_timer_info_ptr = null (); return; %skip (10); set_data_ptr: proc (arg_number, a_data_ptr, a_data_ptr_provided); call cu_$arg_ptr (arg_number, p_ptr, p_len, x_code); if x_code = 0 then do; a_data_ptr = p_ptr -> based_ptr; a_data_ptr_provided = "1"b; end; else do; a_data_ptr = null (); a_data_ptr_provided = "0"b; end; return; declare arg_number fixed binary parameter; declare a_data_ptr pointer parameter; declare a_data_ptr_provided bit (1) aligned; declare p_ptr pointer; declare p_len fixed binary (21); declare x_code fixed binary (35); declare based_ptr pointer based; end; %page; schedule_timer: proc (time, type, inhibit, action, channel, routine, data_ptr, data_ptr_provided); dcl ( time fixed bin (71), type bit (1) aligned, inhibit bit (1) aligned, action bit (1) aligned, channel fixed bin (71), routine entry variable, data_ptr_provided bit (1) aligned, data_ptr pointer ) parameter; dcl bead_ptr pointer, found bit (1) aligned, next_bead_ptr pointer, prev_bead_ptr pointer, saved_mask bit (36) aligned, start_list_ptr pointer; call initialize (Full); /* Mask down so we won't be bothered by asynchronous processing or unexpected recursion */ saved_mask = "0"b; on cleanup begin; if substr (saved_mask, 36, 1) = "1"b then call hcs_$reset_ips_mask (saved_mask, saved_mask); end; call hcs_$set_ips_mask (alrm_cput_quit_mask, saved_mask); /* disable alrm, cput, quit */ /* Search down appropriate list and sort in alarm by time */ found = "0"b; prev_bead_ptr = null; if type = Alarm then start_list_ptr = start_alarm_list_ptr; else start_list_ptr = start_cpu_list_ptr; do bead_ptr = start_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null & ^found); if time < bead_ptr -> bead.time then found = "1"b; else prev_bead_ptr = bead_ptr; end; /* At this point, prev_bead_ptr points to the bead after which we want to sort in the new timer */ if free_bead_list_ptr = null () then allocate bead in (sys_area) set (bead_ptr); else do; bead_ptr = free_bead_list_ptr; free_bead_list_ptr = bead_ptr -> bead.next_ptr; end; /**** DEBUG if debugging then call ioa_ ("Allocated bead at ^p.", bead_ptr); /* DEBUG */ bead_ptr -> bead.time = time; bead_ptr -> bead.alarm = (type = Alarm); bead_ptr -> bead.cpu = (type = CPU); bead_ptr -> bead.inhibit = (inhibit = Inhibit); bead_ptr -> bead.call = (action = Call); bead_ptr -> bead.wakeup = (action = Wakeup); bead_ptr -> bead.data_ptr_provided = data_ptr_provided; bead_ptr -> bead.channel = channel; bead_ptr -> bead.routine = routine; bead_ptr -> bead.data_ptr = data_ptr; bead_ptr -> bead.control_point_id = get_control_point_id_ (); if prev_bead_ptr = null then do; /* The new bead was placed at the head of the list */ bead_ptr -> bead.next_ptr = start_list_ptr; start_list_ptr = bead_ptr; if type = Alarm then start_alarm_list_ptr = start_list_ptr; else start_cpu_list_ptr = start_list_ptr; /* Since the new bead is now the first scheduled to occur, we must (re)set the appropriate timer to the new time. */ call set_next_timer; end; else do; bead_ptr -> bead.next_ptr = prev_bead_ptr -> bead.next_ptr; prev_bead_ptr -> bead.next_ptr = bead_ptr; end; /**** DEBUG if debugging_chain then call display_chain (start_list_ptr); /* DEBUG */ call hcs_$reset_ips_mask (saved_mask, saved_mask); return; %skip (5); unschedule_timer: entry (type, action, channel, routine, data_ptr, data_ptr_provided); dcl removed_first bit (1) aligned; call initialize (Full); /* Mask down so we won't be bothered by asynchronous processing or unexpected recursion */ saved_mask = "0"b; on cleanup begin; if substr (saved_mask, 36, 1) = "1"b then call hcs_$reset_ips_mask (saved_mask, saved_mask); end; call hcs_$set_ips_mask (alrm_cput_quit_mask, saved_mask); /* disable alrm, cput, quit */ /* Search down appropriate list and get rid of matching entries */ if type = Alarm then start_list_ptr = start_alarm_list_ptr; else start_list_ptr = start_cpu_list_ptr; removed_first = ""b; prev_bead_ptr = null; do bead_ptr = start_list_ptr repeat (next_bead_ptr) while (bead_ptr ^= null); next_bead_ptr = bead_ptr -> bead.next_ptr; if action = Wakeup then if bead_ptr -> bead.channel = channel then call remove_bead (bead_ptr, prev_bead_ptr); else prev_bead_ptr = bead_ptr; else if bead_ptr -> bead.routine = routine then if data_ptr_provided then if data_ptr = bead_ptr -> bead.data_ptr then call remove_bead (bead_ptr, prev_bead_ptr); else prev_bead_ptr = bead_ptr; else call remove_bead (bead_ptr, prev_bead_ptr); else prev_bead_ptr = bead_ptr; end; if removed_first then call set_next_timer; call hcs_$reset_ips_mask (saved_mask, saved_mask); return; %skip (2); process_interrupt: entry (type, mc_ptr, condition_name, hc_mc_ptr, continue); dcl ( mc_ptr pointer, condition_name char (*), hc_mc_ptr pointer, continue bit (1) aligned ) parameter; dcl code fixed bin (35), temp_mask bit (36) aligned, wakeup_message char (8) aligned; dcl 1 auto_bead automatic, 2 next_ptr pointer, 2 info like schedule.timer; /**** DEBUG if debugging then do; /* DEBUG */ /**** DEBUG call ioa_ ("Processing interrupt for ^a", condition_name); /* DEBUG */ /**** DEBUG call hcs_$set_ips_mask ((36)"1"b, ""b); /* DEBUG */ /**** DEBUG end; /* DEBUG */ if type = Alarm then start_list_ptr = start_alarm_list_ptr; else start_list_ptr = start_cpu_list_ptr; /* First, check if the timer that went off was expected. Unexpected timers can occur in three ways. One, somebody may be fiddling around with the hardcore timers (naughty). Two, a timer may have gone off right while we were masked and busy removing the very same timer from the list (via the reset entries). Three, there is presently a minor problem in hardcore that causes CPU timers to go off a bit too early (the timer is rung with respect to a CPU time that includes page fault time, whereas the real virtual CPU time doesn't). Since we can't tell the difference in order to slap anyone's wrists, if we get any unscheduled timers, we just grin and swallow them. In addition, we re-force the correct (expected) timer back into hardcore. */ if start_list_ptr = null then do; /* didn't expect ANY such timer */ call set_next_timer; /* turn off HC timer */ return; end; if type = Alarm then if start_list_ptr -> bead.time > clock () then do; /**** DEBUG if debugging then call ioa_ ("Unexpected alrm, rescheduling."); /* DEBUG */ call set_next_timer; return; end; else ; else if start_list_ptr -> bead.time > vclock () then do; /**** DEBUG if debugging then call ioa_ ("Unexpected cput, rescheduling."); /* DEBUG */ call set_next_timer; return; end; unspec (auto_bead) = unspec (start_list_ptr -> bead); call remove_bead (start_list_ptr, null); call set_next_timer; if auto_bead.call then do; /**** DEBUG if debugging then call ioa_ ("Processing the call."); /* DEBUG */ if ^auto_bead.inhibit then call hcs_$set_ips_mask (allow_all_mask, "0"b); else on cleanup begin; /* restore mask if fault and release while inhibited */ if mc_ptr ^= null then do; temp_mask = mc_ptr -> mc.ips_temp; if substr (temp_mask, 36, 1) then call hcs_$reset_ips_mask (temp_mask, "0"b); end; end; if have_multiple_control_points () /* must always use cpm_ to insure I/O switches are OK */ then call call_routine_in_other_control_point (); else call auto_bead.routine (mc_ptr, condition_name, hc_mc_ptr, auto_bead.data_ptr); end; else if auto_bead.wakeup then do; /**** DEBUG if debugging then call ioa_ ("Processing the wakeup."); /* DEBUG */ if type = Alarm then wakeup_message = "alarm___"; else wakeup_message = "cpu_time"; call hcs_$wakeup (my_processid, auto_bead.channel, wakeup_message, code); if code ^= 0 then if code ^= error_table_$invalid_channel then call signal_timer_manager_err; /* only acceptable error is user destroyed his channel */ end; return; %skip (5); have_multiple_control_points: procedure () returns (bit (1) aligned); if stackbaseptr () -> stack_header.cpm_enabled then return (cpm_data_$n_control_points > 1); else return ("0"b); end have_multiple_control_points; %skip (5); call_routine_in_other_control_point: procedure (); call_timer_info_condition_name_lth = length (condition_name); allocate call_timer_info in (sys_area) set (call_timer_info_ptr); call_timer_info.routine = auto_bead.routine; call_timer_info.mc_ptr = mc_ptr; call_timer_info.hc_mc_ptr = hc_mc_ptr; call_timer_info.data_ptr = auto_bead.data_ptr; call_timer_info.condition_name = condition_name; call cpm_$generate_call_preferred (auto_bead.control_point_id, invoke_users_routine, call_timer_info_ptr, code); return; end call_routine_in_other_control_point; %skip (5); remove_bead: proc (a_bead_ptr, prev_bead_ptr); dcl (a_bead_ptr, prev_bead_ptr) pointer parameter; dcl bead_ptr pointer, next_bead_ptr pointer; bead_ptr = a_bead_ptr; if prev_bead_ptr = null then do; removed_first = "1"b; start_list_ptr = bead_ptr -> bead.next_ptr; if type = Alarm then start_alarm_list_ptr = start_list_ptr; else start_cpu_list_ptr = start_list_ptr; end; else prev_bead_ptr -> bead.next_ptr = bead_ptr -> bead.next_ptr; next_bead_ptr = bead_ptr -> bead.next_ptr; /**** DEBUG if debugging then /* DEBUG */ /**** DEBUG call ioa_ ("Removed bead at ^p^[; was first bead^;^].", bead_ptr, removed_first); /* DEBUG */ bead_ptr -> bead.next_ptr = free_bead_list_ptr; free_bead_list_ptr = bead_ptr; a_bead_ptr = next_bead_ptr; /**** DEBUG if debugging_chain then call display_chain (start_list_ptr); /* DEBUG */ return; end remove_bead; %skip (2); set_next_timer: proc; if type = Alarm then if start_alarm_list_ptr ^= null then do; /**** DEBUG if debugging then do; /* DEBUG */ /**** DEBUG call date_time_ (start_alarm_list_ptr -> bead.time, junk_string); /* DEBUG */ /**** DEBUG call ioa_ ("Setting HC alarm for ^a (^d) from ^p.", junk_string, /* DEBUG */ /**** DEBUG start_alarm_list_ptr -> bead.time, start_alarm_list_ptr); /* DEBUG */ /**** DEBUG end; /* DEBUG */ call hcs_$set_alarm_timer (start_alarm_list_ptr -> bead.time, Absolute_setting, 0); end; else do; /**** DEBUG if debugging then call ioa_ ("Turning HC alarm off."); /* DEBUG */ call hcs_$set_alarm_timer (Forever, Absolute_setting, 0); /* Hardcore interprets a number this big as "shut up" */ end; else if start_cpu_list_ptr ^= null then do; /**** DEBUG if debugging then call ioa_ ("Setting HC CPU timer to ^6.3f from ^p.", /* DEBUG */ /**** DEBUG start_cpu_list_ptr -> bead.time / 1e6, /* DEBUG */ /**** DEBUG start_cpu_list_ptr); /* DEBUG */ call hcs_$set_cpu_timer (start_cpu_list_ptr -> bead.time, Absolute_setting, 0); end; else do; /**** DEBUG if debugging then call ioa_ ("Turning HC CPU timer off."); /* DEBUG */ call hcs_$set_cpu_timer (0, Absolute_setting, 0); /* pxss, on the other hand, likes zeroes for that purpose */ end; return; end set_next_timer; %page; get_schedule: entry (area_ptr, schedule_ptr, a_code); dcl ( area_ptr pointer, schedule_ptr pointer parameter, a_code fixed bin (35) ) parameter; dcl timer_idx fixed bin; dcl user_area area (sys_info$max_seg_size) based (area_ptr); saved_mask = ""b; on cleanup begin; if substr (saved_mask, 36, 1) then call hcs_$reset_ips_mask (saved_mask, saved_mask); end; schedule_ptr = null; call hcs_$set_ips_mask (alrm_cput_mask, saved_mask); /* Count the outstanding scheduled timers */ N_Timers = 0; do bead_ptr = start_alarm_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null), start_cpu_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null); N_Timers = N_Timers + 1; end; on area begin; a_code = error_table_$noalloc; goto return_hard; end; allocate schedule in (user_area) set (schedule_ptr); revert area; schedule_ptr -> schedule.version = timer_manager_schedule_version_3; timer_idx = 0; do bead_ptr = start_alarm_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null), start_cpu_list_ptr repeat (bead_ptr -> bead.next_ptr) while (bead_ptr ^= null); timer_idx = timer_idx + 1; call fill_slot (bead_ptr); end; a_code = 0; return_hard: call hcs_$reset_ips_mask (saved_mask, saved_mask); return; %skip (2); fill_slot: proc (bead_ptr); dcl bead_ptr pointer parameter; unspec (schedule_ptr -> schedule.timer (timer_idx)) = unspec (bead_ptr -> bead.info); return; end fill_slot; end schedule_timer; %page; sleep: proc (time, lss); dcl time fixed bin (71) parameter, lss bit (1) aligned parameter; dcl 1 wait_list aligned, 2 number_of_channels fixed bin, 2 sleep_channel fixed bin (71); dcl 1 block_message aligned, 2 channel_id fixed bin (71), 2 message fixed bin (71), 2 sender_processid bit (36), 2 origin, 3 device bit (18) unaligned, 3 ring fixed bin (18) unaligned unsigned, 2 channel_index fixed bin; dcl code fixed bin (35), cur_mask bit (36) aligned, old_channel fixed bin (71), old_timer fixed bin (71); call initialize (Limited); /* if we need any more, someone else will do it */ wait_list.number_of_channels = 1; sleep_channel = -1; on cleanup begin; if sleep_channel ^= -1 then do; call ipc_$delete_ev_chn (sleep_channel, code); call unschedule_timer (Alarm, Wakeup, sleep_channel, signal_timer_manager_err, null(), "0"b); sleep_channel = -1; end; end; /* call hcs_$assign_channel (sleep_channel, code); /* HC bug causes fast channels to fail right now. */ /* if code ^= 0 then /* maybe no fast channels left */ if saved_channel_count > 0 then do; saved_channel_count = saved_channel_count - 1; sleep_channel = saved_channel_array (saved_channel_count + 1); end; else do; call ipc_$create_ev_chn (sleep_channel, code); if code /* still */ ^= 0 then call signal_timer_manager_err; end; call hcs_$get_ips_mask (cur_mask); /**** DEBUG if debugging then do; /* DEBUG */ /**** DEBUG call date_time_ (time, junk_string); /* DEBUG */ /**** DEBUG call ioa_ ("Sleeping until ^a (^d).", junk_string, time); /* DEBUG */ /**** DEBUG end; /* DEBUG */ if (lss | (this_ring ^= initial_ring) | (bool (cur_mask, alrm_disabled_mask, "1000"b) ^= ""b)) then begin; /* Here, we either want to or have to do the whole thing manually. If this is as LSS nap, we don't want any other interrupts to occur. If alrms are masked, they CAN'T occur-- and neither can our own. If we are executing in an inner ring (or other ring than initial ring) we can't take advantage of the timer-queuing properties of schedule_timer anyway. */ /**** DEBUG if debugging then call ioa_ ("Sleeping the hard way."); /* DEBUG */ old_channel = -1; on cleanup begin; if old_channel ^= -1 then call hcs_$set_alarm_timer (old_timer, Absolute_setting, old_channel); end; call hcs_$get_alarm_timer (old_timer, old_channel); /**** DEBUG if debugging then call ioa_ ("Old timer was ^d on channel ^o.", old_timer, old_channel); /* DEBUG */ call hcs_$set_alarm_timer (time, Absolute_setting, sleep_channel); /**** DEBUG if debugging then do; /* DEBUG */ /**** DEBUG call hcs_$get_alarm_timer (junk_time, junk_channel); /* DEBUG */ /**** DEBUG call ioa_ ("HC verifies new timer as ^d on channel ^o.", junk_time, junk_channel); /* DEBUG */ /**** DEBUG end; /* DEBUG */ call ipc_$block (addr (wait_list), addr (block_message), code); if code ^= 0 then call signal_timer_manager_err; /**** DEBUG if debugging then call ioa_ ("Returned from block."); /* DEBUG */ call hcs_$set_alarm_timer (old_timer, Absolute_setting, old_channel); old_channel = -1; end; else do; /* normal case, use queuing mechanism */ /**** DEBUG if debugging then call ioa_ ("Sleeping the easy way."); /* DEBUG */ call schedule_timer (time, Alarm, No_inhibit, Wakeup, sleep_channel, signal_timer_manager_err, null (), "0"b); call ipc_$block (addr (wait_list), addr (block_message), code); if code ^= 0 then call signal_timer_manager_err; /**** DEBUG if debugging then call ioa_ ("Returned from block."); /* DEBUG */ end; if saved_channel_count >= hbound (saved_channel_array, 1) then do; call ipc_$delete_ev_chn (sleep_channel, code); if code ^= 0 then call signal_timer_manager_err; return; end; else do; saved_channel_array (saved_channel_count + 1) = sleep_channel; saved_channel_count = saved_channel_count + 1; return; end; end sleep; %page; abs_time: proc (time, flags, type) returns (fixed bin (71)); dcl time fixed bin (71) parameter, flags bit (2) parameter, type bit (1) aligned parameter; dcl abstime fixed bin (71); /* Compute the absolute time from the given time according to the flags the user indicated */ abstime = time; if substr (flags, 2, 1) then abstime = abstime * Million; /* change seconds to microseconds */ if substr (flags, 1, 1) then if type = CPU then abstime = abstime + vclock (); else abstime = abstime + clock (); if abstime <= 0 then abstime = 1; /* go off right away */ return (abstime); end abs_time; %page; initialize: proc (necessary_mechanism); dcl necessary_mechanism fixed bin parameter; dcl alrm_cput_auto_mask bit (36) aligned, old_auto_ips_mask bit (36) aligned, old_ips_mask bit (36) aligned; if initial_ring = 1 then if my_group_id = Initializer then initialized_mechanism = Uninitialized; goto step (initialized_mechanism); step (0): /* initialize limited mechanism */ /**** The limited mechanism suffices for timer_manager_$sleep in inner rings */ this_ring = get_ring_ (); initial_ring = get_initial_ring_ (); my_group_id = get_group_id_ (); my_processid = get_process_id_ (); sys_areap = get_system_free_area_ (); call create_ips_mask_ (addr (IPS_names), 1, alrm_disabled_mask); substr (alrm_disabled_mask, 36, 1) = "1"b; call create_ips_mask_ (addr (IPS_names), 3, alrm_cput_quit_mask); call create_ips_mask_ (addr (All_IPS), 1, allow_all_mask); allow_all_mask = ^allow_all_mask; initialized_mechanism = Limited; step (1): if initialized_mechanism >= necessary_mechanism then return; /**** The mechanism set up by this section will only work in the process' initial ring. This is because the list of timers is kept in per-ring static, and therefore, any given ring can not know what timers are outstanding in other rings. Since there is only one REAL timer, this would be terminally confusing. Therefore, we limit ourselves to operation in the user ring. */ if this_ring ^= initial_ring then call signal_timer_manager_err; /* Now we want to diddle the automatic IPS mask. Not precisely a mask, this is really a set of indicators corresponding to IPS interrupts. Whenever an IPS interrupt indicated in the mask occurs, hardcore automatically masks ALL IPS interrupts off before handling it. It is the job of the handler to remember to reset the IPS mask back to what it was. The old mask can be found in the machine conditions. */ call create_ips_mask_ (addr (IPS_names), 2, alrm_cput_mask); alrm_cput_auto_mask = ^alrm_cput_mask; old_auto_ips_mask, old_ips_mask = ""b; on cleanup begin; if substr (old_auto_ips_mask, 36, 1) then call hcs_$set_automatic_ips_mask (old_auto_ips_mask, old_auto_ips_mask); if substr (old_ips_mask, 36, 1) then call hcs_$set_ips_mask (old_ips_mask, old_ips_mask); end; call hcs_$set_ips_mask (""b, old_ips_mask); /* mask down while diddling auto mask */ call hcs_$set_automatic_ips_mask (""b, old_auto_ips_mask); /* get current auto mask */ old_auto_ips_mask = alrm_cput_auto_mask | old_auto_ips_mask; /* carry forward any indicators anyone else might have set */ call hcs_$set_automatic_ips_mask (old_auto_ips_mask, ""b); old_auto_ips_mask = ""b; call hcs_$reset_ips_mask (old_ips_mask, old_ips_mask); initialized_mechanism = Full; step (2): return; end initialize; %skip (5); signal_timer_manager_err: proc; do while ("1"b); signal timer_manager_err; end; end signal_timer_manager_err; %page; /**** DEBUG display_chain: proc (lp); /* DEBUG */ /**** DEBUG dcl (lp, bp) pointer; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG dcl 1 auto_bead automatic, /* DEBUG */ /**** DEBUG 2 next_ptr pointer, /* DEBUG */ /**** DEBUG 2 info like schedule.timer; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG dcl sysprint stream; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG put data (lp); put skip (2); /* DEBUG */ /**** DEBUG do bp = lp repeat (bp -> bead.next_ptr) while (bp ^= null); /* DEBUG */ /**** DEBUG put data (bp); put skip; /* DEBUG */ /**** DEBUG unspec (auto_bead) = unspec (bp -> bead); /* DEBUG */ /**** DEBUG put data (auto_bead); put skip (2); /* DEBUG */ /**** DEBUG end; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG return; /* DEBUG */ /**** DEBUG end display_chain; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG debug: entry; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG dcl (debugging, debugging_chain) bit (1) aligned static initial (""b); /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG dcl ioa_ ext entry options (variable), /* DEBUG */ /**** DEBUG junk_time fixed bin (71), /* DEBUG */ /**** DEBUG junk_channel fixed bin (71), /* DEBUG */ /**** DEBUG junk_string char (24), /* DEBUG */ /**** DEBUG date_time_ ext entry (fixed bin (71), char (*)); /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG debugging = "1"b; /* DEBUG */ /**** DEBUG debugging_chain = ""b; /* DEBUG */ /**** DEBUG return; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG nodebug: entry; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG debugging, debugging_chain = ""b; /* DEBUG */ /**** DEBUG return; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG debug_chain: entry; /* DEBUG */ /**** DEBUG /* DEBUG */ /**** DEBUG debugging, debugging_chain = "1"b; /* DEBUG */ /**** DEBUG return; /* DEBUG */ end timer_manager_;  wkp_signal_handler_.pl1 11/11/89 1144.0rew 11/11/89 0803.5 24516 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indnoniterend,initcol3,dclind5,idind32 */ wkp_signal_handler_: procedure; /*****************************************************************************/ /* */ /* This is the default handler for the "wkp_" IPS signal. Its job is to */ /* make one pass through the pending IPC events, and run any event call */ /* handlers that have wakeups. */ /* */ /*****************************************************************************/ /* Written by C. Hornig, January 1979. (to do nothing) */ /****^ HISTORY COMMENTS: 1) change(86-08-12,Kissel), approve(86-08-12,MCR7479), audit(86-10-08,Fawcett), install(86-11-03,MR12.0-1206): Modified to do its thing to support async event channels. END HISTORY COMMENTS */ dcl quit_signalled bit (1) aligned; dcl ipc_$run_event_calls entry (fixed bin, fixed bin (35)); dcl quit condition; /* If any of the call handlers that are run during this time signal quit, we will remember it, and signal it ourself when they are all done. This is because ipc_ currently has a flag which prevents event call handlers from being run recursively. In particular, for DSA this means that we can't have two quits in a row because it is the event call handler which signals quit. If there are ever event call handlers that want to signal other things, this code should be changed to catch those conditions and signal them later as well. */ quit_signalled = "0"b; on quit quit_signalled = "1"b; /* Just run the handlers for any asynchronous type of event call channels which have pending wakeups. */ call ipc_$run_event_calls (ASYNC_CALL_EVENT_CHANNEL_TYPE, (0)); /* Signal quit if anyone wanted us to, but revert first to avoid self-flagellation. */ revert quit; if quit_signalled then signal quit; return; %include ipc_create_arg; end wkp_signal_handler_; 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