|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 19233 (0x4b21) Types: TextFile Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000 └─ ⟦cfc2e13cd⟧ »Space Info Vol 2« └─⟦c1b6a0eff⟧ └─⟦this⟧
-- Copyright 1986,1987,1988,1991,1993 Verdix Corporation ------------------------------------------------------------------------------ -- User interface to the ADA tasking extensions -- -- Note: earlier releases used the following subtypes defined in v_i_types. -- subtype v_i_types.a_task_t is system.task_id; -- subtype v_i_types.a_program_t is system.program_id; -- subtype v_i_types.user_field_t is integer; -- -- The subprograms in this package are backward compatible with the above -- subtypes. ------------------------------------------------------------------------------ with system; use system; with v_usr_conf_i; package v_i_tasks is pragma suppress(ALL_CHECKS); pragma suppress(EXCEPTION_TABLES); pragma not_elaborated; -------------------------------------------------------------------------- -- Gets/sets the user field in the specified task. -------------------------------------------------------------------------- function get_user_field(tsk: task_id) return integer; function get_user_field(tsk: task_id) return address; pragma inline_only(get_user_field); procedure set_user_field(tsk: task_id; new_value: integer); procedure set_user_field(tsk: task_id; new_value: address); pragma inline_only(set_user_field); -- DA_RTS -------------------------------------------------------------------------- -- Gets/sets the surrogate tcb field in the specified task. -------------------------------------------------------------------------- function get_da_surrogate_tcb_ptr(tsk: task_id) return address; procedure set_da_surrogate_tcb_ptr(tsk: task_id; new_value: address); -------------------------------------------------------------------------- -- Panic due to a detected unrecoverable problem. -------------------------------------------------------------------------- procedure panic_exit( s : string; status : integer := -1); -- DA_RTS -------------------------------------------------------------------------- -- Gets/sets the current or static priority of the specified task. -- -- Task scheduling is only re-evaluated if the current priority of the -- current task is lowered or if the current priority of any other -- task is set. -- -- The current priority is used for all scheduling activities. -- The static priority is only used for rendezvous as follows: -- rendezvous_start: -- if not PRIORITY_INHERITANCE_ENABLED and then -- called_task.current_priority < calling_task.static_priority -- then -- called_task.current_priority := calling_task.static_prioity; -- end if; -- rendezvous_end: -- called_task.current_priority := called_task.static_priority; -------------------------------------------------------------------------- function get_current_priority(tsk: task_id) return priority; procedure set_current_priority(tsk: task_id; new_value: priority); function get_static_priority(tsk: task_id) return priority; procedure set_static_priority(tsk: task_id; new_value: priority); -- begin CIFO option function task_has_pragma_priority(tsk: task_id) return boolean; -- end CIFO option -------------------------------------------------------------------------- -- Gets/sets the current pool (cp) for the current task -------------------------------------------------------------------------- function get_pool return system.address; procedure set_pool(p: system.address); -------------------------------------------------------------------------- -- Gets/sets the flag to disable the program from exiting -------------------------------------------------------------------------- function get_exit_disabled_flag return boolean; procedure set_exit_disabled_flag(disabled_flag: boolean); -------------------------------------------------------------------------- -- Gets/sets the fast rendezvous enabled flag for the current task. -- See FAST_RENDEZVOUS_ENABLED in v_usr_conf.a for details about -- the fast rendezvous optimization. -- -- If FAST_RENDEZVOUS_ENABLED was disabled in the configuration table, -- then, it can never be enabled. -- -- Normally, fast rendezvous would only need to be disabled for -- multi-processor Ada, where the accept body must execute -- in the acceptor task that is bound to a processor. -------------------------------------------------------------------------- function get_fast_rendezvous_enabled return boolean; procedure set_fast_rendezvous_enabled(enabled: boolean); -- begin CIFO option -------------------------------------------------------------------------- -- Gets/sets the private per-task data used by the CIFO. -------------------------------------------------------------------------- procedure get_cifo_tcb(t: task_id; p : out system.address); procedure set_cifo_tcb(t: task_id; p : in system.address); -------------------------------------------------------------------------- -- Return the calling task's master task -------------------------------------------------------------------------- function get_task_master return task_id; --------------------------------------------------------------------------- -- Returns TRUE if the task is in the current program's list of tasks and -- the task has been activated but not yet terminated, abnormal or -- completed. Otherwise, returns FALSE. -- -- This subprogram first checks that the "tsk" parameter points to a -- valid task control block (tcb) before accessing any field in the tcb. -- -- If the sequence_num >= 0, then, the task's sequence_num must also -- match for the task to be valid. --------------------------------------------------------------------------- function task_is_valid(tsk: task_id; sequence_num: integer := -1) return boolean; --------------------------------------------------------------------------- -- Return TRUE if the task is abnormal. The task should have been -- previously checked for validity with 'task_is_valid'. --------------------------------------------------------------------------- function task_is_abnormal(tsk: task_id) return boolean; -------------------------------------------------------------------------- -- Returns TRUE if the specified task is in rendezvous with a passive -- task. -------------------------------------------------------------------------- function task_in_passive_rendezvous(tsk: task_id) return boolean; -- end CIFO option --------------------------------------------------------------------------- -- Return TRUE if the calling task is completed. For the CIFO option, -- The task should have been previously checked for validity with -- 'task_is_valid'. --------------------------------------------------------------------------- function task_is_completed(tsk: task_id) return boolean; -------------------------------------------------------------------------- -- Returns the pc of the first instruction of the task. -------------------------------------------------------------------------- function get_task_start_pc(tsk: task_id) return system.address; -------------------------------------------------------------------------- -- Returns the task's unique sequence number. The returned -- sequence number >= 0. Sequence numbers are unique across -- multiple programs. -------------------------------------------------------------------------- function get_task_sequence_number(tsk: task_id) return integer; -------------------------------------------------------------------------- -- Checks if the calling task is already in rendezvous with the -- called task. Returns TRUE if in rendezvous. -------------------------------------------------------------------------- function check_in_rendezvous( called_task : task_id; calling_task : task_id) return boolean; -------------------------------------------------------------------------- -- Returns the Task Control Block (TCB) of the current task. -- -- If executing in a fast rendezvous, returns the acceptor task and -- not the caller task that is really executing the rendezvous. -------------------------------------------------------------------------- function get_current_task return task_id; -------------------------------------------------------------------------- -- Returns the Task Control Block (TCB) associated with the specified task. -------------------------------------------------------------------------- function get_task(id: system.task_id) return task_id; pragma inline_only(get_task); -------------------------------------------------------------------------- -- Gets the configuration table for the current program. -------------------------------------------------------------------------- function get_configuration_table return v_usr_conf_i.a_configuration_table_t; -------------------------------------------------------------------------- -- Calls a procedure in another program -------------------------------------------------------------------------- procedure inter_program_call( proc_prg : program_id; proc_addr : address; arg : address); ------------------------------------------------------------------------------ -- The following services provide backward compatibility with earlier -- releases of VADS. -- -- The interface to these low kernel services is now provided in -- ada_krn_i.a. The following routines simply layer upon their -- counterparts in ada_krn_i.a. ------------------------------------------------------------------------------ -------------------------------------------------------------------------- -- Returns the Program Control Block (PCB) of the current program. -------------------------------------------------------------------------- function get_current_program return program_id; pragma inline_only(get_current_program); -------------------------------------------------------------------------- -- Returns the specified task's Program Control Block (PCB) -------------------------------------------------------------------------- function get_program(tsk: task_id) return program_id; pragma inline_only(get_program); -------------------------------------------------------------------------- -- Terminates the specified Ada program -------------------------------------------------------------------------- procedure terminate_program( status : integer; -- exit status prg : program_id := get_current_program ); pragma inline_only(terminate_program); -------------------------------------------------------------------------- -- Gets the user defined key for the specified program. -------------------------------------------------------------------------- function get_program_key( prg : program_id := get_current_program ) return system.address; pragma inline_only(get_program_key); -------------------------------------------------------------------------- -- Suspends/resumes the specified task. -- -- The VADS_MICRO always returns TRUE. If not layered upon -- VADS_MICRO, then, check ada_krn_i's task_suspend or task_resume. -------------------------------------------------------------------------- function suspend_task(tsk: task_id) return boolean; pragma inline_only(suspend_task); function resume_task(tsk: task_id) return boolean; pragma inline_only(resume_task); -------------------------------------------------------------------------- -- Gets/sets the time slice interval for the specified task. -- -- Time slicing for a task is disabled by setting it to 0.0 seconds -------------------------------------------------------------------------- function get_time_slice(tsk: task_id) return duration; pragma inline_only(get_time_slice); procedure set_time_slice(tsk: task_id; new_time_slice: duration); pragma inline_only(set_time_slice); -------------------------------------------------------------------------- -- Gets/sets the global time slicing enabled configuration parameter -------------------------------------------------------------------------- function get_time_slicing return boolean; pragma inline_only(get_time_slicing); procedure set_time_slicing(enabled: boolean); pragma inline_only(set_time_slicing); -------------------------------------------------------------------------- -- Disables/enables task preemption -- -- Shouldn't be called from an ISR. disable_preemption doesn't -- disable interrupts. -------------------------------------------------------------------------- procedure disable_preemption; pragma inline_only(disable_preemption); procedure enable_preemption; pragma inline_only(enable_preemption); private -- DA_RTS pragma interface(ADA, get_da_surrogate_tcb_ptr); pragma interface_name(get_da_surrogate_tcb_ptr, "__GET_DA_SURROGATE_TCB_PTR"); pragma interface(ADA, set_da_surrogate_tcb_ptr); pragma interface_name(set_da_surrogate_tcb_ptr, "__SET_DA_SURROGATE_TCB_PTR"); pragma interface(ADA, panic_exit); pragma interface_name(panic_exit, "_PANIC_EXIT"); -- DA_RTS pragma interface(ADA, get_current_priority); pragma interface_name(get_current_priority, "__GET_CURRENT_PRIORITY"); pragma interface(ADA, set_current_priority); pragma interface_name(set_current_priority, "__SET_CURRENT_PRIORITY"); pragma interface(ADA, get_static_priority); pragma interface_name(get_static_priority, "__GET_STATIC_PRIORITY"); pragma interface(ADA, set_static_priority); pragma interface_name(set_static_priority, "__SET_STATIC_PRIORITY"); pragma interface(ADA, get_pool); pragma interface_name(get_pool, "__GET_POOL"); pragma interface(ADA, set_pool); pragma interface_name(set_pool, "__SET_POOL"); pragma interface(ADA, get_exit_disabled_flag); pragma interface_name(get_exit_disabled_flag, "__GET_EXIT_DISABLED_FLAG"); pragma interface(ADA, set_exit_disabled_flag); pragma interface_name(set_exit_disabled_flag, "__SET_EXIT_DISABLED_FLAG"); pragma interface(ADA, get_fast_rendezvous_enabled); pragma interface_name(get_fast_rendezvous_enabled, "__GET_FAST_RENDEZVOUS_ENABLED"); pragma interface(ADA, set_fast_rendezvous_enabled); pragma interface_name(set_fast_rendezvous_enabled, "__SET_FAST_RENDEZVOUS_ENABLED"); -- begin CIFO option pragma interface(ADA, get_cifo_tcb); pragma interface_name(get_cifo_tcb, "__GET_CIFO_TCB"); pragma interface(ADA, set_cifo_tcb); pragma interface_name(set_cifo_tcb, "__SET_CIFO_TCB"); pragma interface(ADA, get_task_master); pragma interface_name(get_task_master, "__GET_TASK_MASTER"); pragma interface(ADA, task_is_valid); pragma interface_name(task_is_valid, "__TASK_IS_VALID"); pragma interface(ADA, task_is_abnormal); pragma interface_name(task_is_abnormal, "__TASK_IS_ABNORMAL"); pragma interface(ADA, task_has_pragma_priority); pragma interface_name(task_has_pragma_priority, "__TASK_HAS_PRAGMA_PRIORITY"); pragma interface(ADA, task_in_passive_rendezvous); pragma interface_name(task_in_passive_rendezvous, "__TASK_IN_PASSIVE_RENDEZVOUS"); -- end CIFO option pragma interface(ADA, task_is_completed); pragma interface_name(task_is_completed, "__TASK_IS_COMPLETED"); pragma interface(ADA, get_task_start_pc); pragma interface_name(get_task_start_pc, "__GET_TASK_START_PC"); pragma interface(ADA, get_task_sequence_number); pragma interface_name(get_task_sequence_number, "__GET_TASK_SEQUENCE_NUMBER"); pragma interface(ADA, check_in_rendezvous); pragma interface_name(check_in_rendezvous, "__CHECK_IN_RENDEZVOUS"); pragma interface(ADA, get_current_task); pragma interface_name(get_current_task, "TS_TID"); pragma interface(ADA, get_configuration_table); pragma interface_name(get_configuration_table, "__GET_CONFIGURATION_TABLE"); pragma interface(ADA, inter_program_call); pragma interface_name(inter_program_call, "__INTER_PROGRAM_CALL"); end; with system; use system; with ada_krn_i; with v_i_types; package body v_i_tasks is pragma suppress(ALL_CHECKS); pragma suppress(EXCEPTION_TABLES); function get_user_universal_field(tsk: task_id) return v_i_types.universal_scalar; pragma interface(ADA, get_user_universal_field); pragma interface_name(get_user_universal_field, "__GET_USER_UNIVERSAL_FIELD"); procedure set_user_universal_field(tsk: task_id; new_value: v_i_types.universal_scalar); pragma interface(ADA, set_user_universal_field); pragma interface_name(set_user_universal_field, "__SET_USER_UNIVERSAL_FIELD"); function get_user_field(tsk: task_id) return integer is begin return v_i_types.from_universal_scalar(get_user_universal_field(tsk)); end; function get_user_field(tsk: task_id) return address is begin return v_i_types.from_universal_scalar(get_user_universal_field(tsk)); end; procedure set_user_field(tsk: task_id; new_value: integer) is begin set_user_universal_field(tsk, v_i_types.to_universal_scalar(new_value)); end; procedure set_user_field(tsk: task_id; new_value: address) is begin set_user_universal_field(tsk, v_i_types.to_universal_scalar(new_value)); end; function get_task(id: system.task_id) return task_id is begin return id; end; function get_current_program return program_id is begin return ada_krn_i.program_self; end; function get_program(tsk: task_id) return program_id is begin if task_is_completed(tsk) then return get_current_program; else return ada_krn_i.program_get(tsk); end if; end; procedure terminate_program( status : integer; -- exit status prg : program_id := get_current_program ) is begin ada_krn_i.program_terminate(prg, status); end; function get_program_key( prg : program_id := get_current_program ) return system.address is begin return ada_krn_i.program_get_key(prg); end; function suspend_task(tsk: task_id) return boolean is begin if task_is_completed(tsk) then return FALSE; else return ada_krn_i.task_suspend(tsk); end if; end; function resume_task(tsk: task_id) return boolean is begin if task_is_completed(tsk) then return FALSE; else return ada_krn_i.task_resume(tsk); end if; end; function get_time_slice(tsk: task_id) return duration is begin if task_is_completed(tsk) then return 0.0; else return ada_krn_i.task_get_time_slice(tsk); end if; end; procedure set_time_slice(tsk: task_id; new_time_slice: duration) is begin if not task_is_completed(tsk) then ada_krn_i.task_set_time_slice(tsk, new_time_slice); end if; end; function get_time_slicing return boolean is begin return ada_krn_i.kernel_get_time_slicing_enabled; end; procedure set_time_slicing(enabled: boolean) is begin ada_krn_i.kernel_set_time_slicing_enabled(enabled); end; procedure disable_preemption is begin ada_krn_i.task_disable_preemption; end; procedure enable_preemption is begin ada_krn_i.task_enable_preemption; end; end