⟦2d83b3537⟧

TextFile


-- Copyright 1992 Verdix Corporation

------------------------------------------------------------------------------
-- User interface to Ada exception services.
--
-- Services for:
--  [1] getting the id and pc of the current Ada exception
--  [2] returning the string name of an exception id
--  [3] dividing an exception into components
--  [4] installing a callout to be called whenever an exception is raised
--
-- Unix self-hosts (using VADS_MICRO) also have core dump services to:
--  [1] produce a "core" file from anywhere in your program
--  [2] enable the generation of a "core" file for an unhandled Ada
--      exception
--  [3] enable exception traceback regs to be saved for a unhandled core dump
------------------------------------------------------------------------------
with system;	use system;
package v_i_except is

    pragma suppress(ALL_CHECKS);
    pragma suppress(EXCEPTION_TABLES);
    pragma not_elaborated;

	----------------------------------------------------------------------
	-- Get the id and the pc of the current exception. If called outside
	-- of an Ada exception handler, then, information for the last raised
	-- exception is returned.
	----------------------------------------------------------------------
	procedure exception_current(
		id			: out address;	-- id is sometimes referred to as image
		pc			: out address);	-- pc where the exception was raised

		-- Each task has a copy of the id and pc for
		-- the last raised exception. There is also a single copy maintained
		-- for exceptions raised in an ISR or in a NO TASKING program.
		--
		-- If exceptions are raised in nested ISR handlers, then, the
		-- previous exception information is silently overwritten.


	----------------------------------------------------------------------
	-- Returns the name for the specified exception id. Id is sometimes
	-- referred to as "image".
	----------------------------------------------------------------------
	function exception_name(id: address) return string;

	----------------------------------------------------------------------
	-- If the exception image is a distributed ada exception then dads_flag
	-- is returned TRUE and the nt_index (unit number) and at_index
	-- (section number) will have valid values.  If dads_flag
	-- is FALSE then at_index and nt_index are undefined.
	----------------------------------------------------------------------
	procedure decode_da_exception(
		id				: address;		-- exception image
		dads_flag		: out boolean;	-- TRUE if distributed ada
		nt_index		: out integer;	-- valid if dads_flag is TRUE
		at_index		: out integer);	-- valid if dads_flag is TRUE

	----------------------------------------------------------------------
	-- Install a callout to be called whenever an exception is raised.
	--
	-- If unable to allocate memory for the callout data structure,
	-- STORAGE_ERROR exception is raised.
	--
	-- The callouts are called in LIFO order.
	--
	-- An example of an exception_callout that maintains a circular
	-- buffer of all raised Ada exceptions is provided in the
	-- trace_xcpt package found at the end of this file.
	----------------------------------------------------------------------
	procedure exception_callout_install(proc: address);
		-- The callout procedure is called as follows:
		--		procedure exception_callout_proc(
		--			id			: address;	-- also referred to as "image"
		--			pc			: address;	-- pc where exception was raised
		--			reg_context	: address);	-- pointer to register context
		--									-- saved on the stack. Content
		--									-- is CPU specific. See below.
		--
		-- The exception_callout_proc() must be reentrant. It can be
		-- concurrently called from multiple tasks or an ISR.
		--
		-- Upon entry, stack limit checking has already been disabled.
		--
		-- reg_context points to:
		--	for SPARC:
		--		if TRACEBACK_REGS = TRUE (via debugger "set except_stack")
		--			g0..g7, o0..o7, where o6 points to locals and ins
		--		else
		--			no register context is saved, reg_context = NO_ADDR
		--		end if
		--
		--		TRACEBACK_REGS may be set in the user program via:
		--			traceback_regs: boolean;
		--			pragma interface_name(traceback_regs, "TRACEBACK_REGS");
		--			...
		--			traceback_regs := TRUE;
		--
		--	for MIPS:
		--		r0..r31, where only v0, s0..s7, sp, fp, and ra have been saved
		--
		--	for M68K:
		--		d0..d7, a0..a7, where only d4..d7, a2..a7 have been saved
		--
		--	for VAX (Ultrix):
		--		r0..r15, where only r6..r15 have been saved
		--
		--	for VAX (VMS):
		--		r0..r15, where only r2..r15 have been saved
		--
		--	for HP-9000/700 (HP-UX):
        --      fr0..fr31, gr0..gr31, where only fr12..fr21, rp, gr2..gr18,
        --      ret0, and sp have been saved.  On machines with PA-RISC
		--      architecture revision 1.0, fr16..fr21 are not saved.  Note
		--      that the float registers are 64 bits in size.
		--

	----------------------------------------------------------------------
	-- You can call the following VADS service to produce a "core"
	-- file from anywhere in your program.
	--
	-- Only applicable to Unix self-hosts.
	----------------------------------------------------------------------
	procedure dump_core;

	----------------------------------------------------------------------
	-- Call the following service to enable the generation of
	-- a "core" file for an unhandled Ada exception.
	--
	-- Only applicable to Unix self-hosts.
	----------------------------------------------------------------------
	procedure enable_unhandled_dump_core;
	  pragma inline_only(enable_unhandled_dump_core);

	----------------------------------------------------------------------
	-- Call the following service if you also want the exception
	-- traceback regs to be saved for a unhandled core dump. 
	-- Note, saving the traceback regs will add a small amount of time to
	-- normal Ada exception handling. However, TRACEBACK_REGS must be set
	-- if you want to know where the unhandled exception was executed.
	--
	-- Only applicable to Unix self-hosts.
	----------------------------------------------------------------------
	procedure enable_traceback_regs;
	  pragma inline_only(enable_traceback_regs);


private
	pragma interface(ADA, exception_current);
	pragma interface_name(exception_current, "__EXCEPTION_CURRENT");

	pragma interface(ADA, exception_name);
	pragma interface_name(exception_name, "__EXCEPTION_NAME");

	pragma interface(ADA, decode_da_exception);
	pragma interface_name(decode_da_exception, "__DECODE_DA_EXCEPTION");

	pragma interface(ADA, exception_callout_install);
	pragma interface_name(exception_callout_install,
		"__EXCEPTION_CALLOUT_INSTALL");

	pragma interface(Ada, dump_core);
	pragma interface_name(dump_core, "DUMP_CORE");
end v_i_except;

package body v_i_except is
	procedure enable_unhandled_dump_core is
		unhandled_dump_core_enabled : boolean;
		  pragma interface_name(unhandled_dump_core_enabled,
			"UNHANDLED_DUMP_CORE_ENABLED");
	begin
		unhandled_dump_core_enabled := TRUE;
	end;

	procedure enable_traceback_regs is
		traceback_regs: boolean;
		  pragma interface_name(traceback_regs, "TRACEBACK_REGS");
	begin
		traceback_regs := TRUE;
	end;
end;

--  The following is sample code that uses the services above.
--
--	package trace_xcpt is
--
--	-- When elaborated, the body of trace_xcpt installs an exception_callout
--	-- that maintains a circular buffer of all raised Ada exceptions.
--
--	-- If the program core dumps, a.db can be used to examine the
--	-- the circular buffer to get a trace of where the last exception
--  -- was originally raised and subsequently reraised.
--
--	end trace_xcpt;
--	
--	with system;					use system;
--	with v_i_except;
--	with unchecked_conversion;
--	package body trace_xcpt is
--		-- This example traces the MIPS registers. It needs minor
--		-- modifications for other CPU architectures.
--	
--		type trace_entry_t is record
--			id		: address;
--			pc		: address;
--			sp		: address;
--			ra		: address;
--		end record;
--		type a_trace_entry_t is access trace_entry_t;
--	
--		TRACE_CNT					: constant integer := 100;
--		trace_entries				: array (0..TRACE_CNT-1) of trace_entry_t;
--		  pragma external_name(trace_entries, "TRACE_ENTRIES");
--		trace_bottom                : address;
--		  pragma external_name(trace_bottom, "TRACE_BOTTOM");
--		trace_top                   : address;
--		  pragma external_name(trace_top, "TRACE_TOP");
--		trace_put                   : a_trace_entry_t;
--		  pragma external_name(trace_put, "TRACE_PUT");
--	
--		TRACE_ENTRY_LEN: constant integer := trace_entry_t'size / STORAGE_UNIT;
--	
--		function to_a_trace_entry_t is
--			new unchecked_conversion(address, a_trace_entry_t);
--		function to_address is
--			new unchecked_conversion(a_trace_entry_t, address);
--	
--		type regs_t is array (0..31) of address;
--		type a_regs_t is access regs_t;
--		function to_a_regs_t is
--			new unchecked_conversion(address, a_regs_t);
--	
--		procedure trace_callout(id: address; pc: address;
--			reg_context: address)
--		is
--			t		: a_trace_entry_t;
--			regs	: a_regs_t := to_a_regs_t(reg_context);
--		begin
--			trace_put.id := id;
--			trace_put.pc := pc;
--			trace_put.sp := regs(29);
--			trace_put.ra := regs(31);
--			t := to_a_trace_entry_t(to_address(trace_put) + TRACE_ENTRY_LEN);
--			if to_address(t) >= trace_top then
--				trace_put := to_a_trace_entry_t(trace_bottom);
--			else
--				trace_put := t;
--			end if;
--		end;
--	begin
--		trace_bottom := trace_entries(trace_entries'first)'address;
--		trace_top := trace_bottom + TRACE_CNT * TRACE_ENTRY_LEN;
--		trace_put := to_a_trace_entry_t(trace_bottom);
--	
--		v_i_except.exception_callout_install(trace_callout'address);
--	end trace_xcpt
DataMuseum.dk

Rational R1000/400

⟦2d83b3537⟧ TextFile

Derivation

TextFile
