DataMuseum.dk

top - metrics - 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⟧ 

TextFile

-- 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