aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/gcc/ada/s-traceb-hpux.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.3.1/gcc/ada/s-traceb-hpux.adb')
-rw-r--r--gcc-4.3.1/gcc/ada/s-traceb-hpux.adb603
1 files changed, 603 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/s-traceb-hpux.adb b/gcc-4.3.1/gcc/ada/s-traceb-hpux.adb
new file mode 100644
index 000000000..c2718af3f
--- /dev/null
+++ b/gcc-4.3.1/gcc/ada/s-traceb-hpux.adb
@@ -0,0 +1,603 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K --
+-- (HP/UX Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2006, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+package body System.Traceback is
+
+ -- This package implements the backtracing facility by way of a dedicated
+ -- HP library for stack unwinding described in the "Runtime Architecture
+ -- Document".
+
+ pragma Linker_Options ("/usr/lib/libcl.a");
+
+ -- The library basically offers services to fetch information about a
+ -- "previous" frame based on information about a "current" one.
+
+ type Current_Frame_Descriptor is record
+ cur_fsz : Address; -- Frame size of current routine.
+ cur_sp : Address; -- The current value of stack pointer.
+ cur_rls : Address; -- PC-space of the caller.
+ cur_rlo : Address; -- PC-offset of the caller.
+ cur_dp : Address; -- Data Pointer of the current routine.
+ top_rp : Address; -- Initial value of RP.
+ top_mrp : Address; -- Initial value of MRP.
+ top_sr0 : Address; -- Initial value of sr0.
+ top_sr4 : Address; -- Initial value of sr4.
+ top_r3 : Address; -- Initial value of gr3.
+ cur_r19 : Address; -- GR19 value of the calling routine.
+ top_r4 : Address; -- Initial value of gr4.
+ dummy : Address; -- Reserved.
+ out_rlo : Address; -- PC-offset of the caller after get_previous.
+ end record;
+
+ type Previous_Frame_Descriptor is record
+ prev_fsz : Address; -- frame size of calling routine.
+ prev_sp : Address; -- SP of calling routine.
+ prev_rls : Address; -- PC_space of calling routine's caller.
+ prev_rlo : Address; -- PC_offset of calling routine's caller.
+ prev_dp : Address; -- DP of calling routine.
+ udescr0 : Address; -- low word of calling routine's unwind desc.
+ udescr1 : Address; -- high word of calling routine's unwind desc.
+ ustart : Address; -- start of the unwind region.
+ uend : Address; -- end of the unwind region.
+ uw_index : Address; -- index into the unwind table.
+ prev_r19 : Address; -- GR19 value of the caller's caller.
+ top_r3 : Address; -- Caller's initial gr3.
+ top_r4 : Address; -- Caller's initial gr4.
+ end record;
+
+ -- Provide useful shortcuts for the names
+
+ subtype CFD is Current_Frame_Descriptor;
+ subtype PFD is Previous_Frame_Descriptor;
+
+ -- Frames with dynamic stack allocation are handled using the associated
+ -- frame pointer, but HP compilers and GCC setup this pointer differently.
+ -- HP compilers set it to point at the top (highest address) of the static
+ -- part of the frame, wheras GCC sets it to point at the bottom of this
+ -- region. We have to fake the unwinder to compensate for this difference,
+ -- for which we'll need to access some subprograms unwind descriptors.
+
+ type Bits_2_Value is mod 2 ** 2;
+ for Bits_2_Value'Size use 2;
+
+ type Bits_4_Value is mod 2 ** 4;
+ for Bits_4_Value'Size use 4;
+
+ type Bits_5_Value is mod 2 ** 5;
+ for Bits_5_Value'Size use 5;
+
+ type Bits_27_Value is mod 2 ** 27;
+ for Bits_27_Value'Size use 27;
+
+ type Unwind_Descriptor is record
+ cannot_unwind : Boolean;
+ mcode : Boolean;
+ mcode_save_restore : Boolean;
+ region_desc : Bits_2_Value;
+ reserved0 : Boolean;
+ entry_sr : Boolean;
+ entry_fr : Bits_4_Value;
+ entry_gr : Bits_5_Value;
+
+ args_stored : Boolean;
+ variable_frame : Boolean;
+ separate_package_body : Boolean;
+ frame_extension_mcode : Boolean;
+
+ stack_overflow_check : Boolean;
+ two_steps_sp_adjust : Boolean;
+ sr4_export : Boolean;
+ cxx_info : Boolean;
+
+ cxx_try_catch : Boolean;
+ sched_entry_seq : Boolean;
+ reserved1 : Boolean;
+ save_sp : Boolean;
+
+ save_rp : Boolean;
+ save_mrp : Boolean;
+ save_r19 : Boolean;
+ cleanups : Boolean;
+
+ hpe_interrupt_marker : Boolean;
+ hpux_interrupt_marker : Boolean;
+ large_frame : Boolean;
+ alloca_frame : Boolean;
+
+ reserved2 : Boolean;
+ frame_size : Bits_27_Value;
+ end record;
+
+ for Unwind_Descriptor'Size use 64;
+
+ for Unwind_Descriptor use record
+ cannot_unwind at 0 range 0 .. 0;
+ mcode at 0 range 1 .. 1;
+ mcode_save_restore at 0 range 2 .. 2;
+ region_desc at 0 range 3 .. 4;
+ reserved0 at 0 range 5 .. 5;
+ entry_sr at 0 range 6 .. 6;
+ entry_fr at 0 range 7 .. 10;
+
+ entry_gr at 1 range 3 .. 7;
+
+ args_stored at 2 range 0 .. 0;
+ variable_frame at 2 range 1 .. 1;
+ separate_package_body at 2 range 2 .. 2;
+ frame_extension_mcode at 2 range 3 .. 3;
+ stack_overflow_check at 2 range 4 .. 4;
+ two_steps_sp_adjust at 2 range 5 .. 5;
+ sr4_export at 2 range 6 .. 6;
+ cxx_info at 2 range 7 .. 7;
+
+ cxx_try_catch at 3 range 0 .. 0;
+ sched_entry_seq at 3 range 1 .. 1;
+ reserved1 at 3 range 2 .. 2;
+ save_sp at 3 range 3 .. 3;
+ save_rp at 3 range 4 .. 4;
+ save_mrp at 3 range 5 .. 5;
+ save_r19 at 3 range 6 .. 6;
+ cleanups at 3 range 7 .. 7;
+
+ hpe_interrupt_marker at 4 range 0 .. 0;
+ hpux_interrupt_marker at 4 range 1 .. 1;
+ large_frame at 4 range 2 .. 2;
+ alloca_frame at 4 range 3 .. 3;
+
+ reserved2 at 4 range 4 .. 4;
+ frame_size at 4 range 5 .. 31;
+ end record;
+
+ subtype UWD is Unwind_Descriptor;
+ type UWD_Ptr is access all UWD;
+
+ function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr);
+
+ -- The descriptor associated with a given code location is retrieved
+ -- using functions imported from the HP library, requiring the definition
+ -- of additional structures.
+
+ type Unwind_Table_Region is record
+ Table_Start : Address;
+ Table_End : Address;
+ end record;
+ -- An Unwind Table region, which is a memory area containing Unwind
+ -- Descriptors.
+
+ subtype UWT is Unwind_Table_Region;
+
+ -- The subprograms imported below are provided by the HP library
+
+ function U_get_unwind_table return UWT;
+ pragma Import (C, U_get_unwind_table, "U_get_unwind_table");
+ -- Get the unwind table region associated with the current executable.
+ -- This function is actually documented as having an argument, but which
+ -- is only used for the MPE/iX targets.
+
+ function U_get_shLib_unwind_table (r19 : Address) return UWT;
+ pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl");
+ -- Return the unwind table region associated with a possible shared
+ -- library, as determined by the provided r19 value.
+
+ function U_get_shLib_text_addr (r19 : Address) return Address;
+ pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr");
+ -- Return the address at which the code for a shared library begins, or
+ -- -1 if the value provided for r19 does not identify shared library code.
+
+ function U_get_unwind_entry
+ (Pc : Address;
+ Space : Address;
+ Table_Start : Address;
+ Table_End : Address) return Address;
+ pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry");
+ -- Given the bounds of an unwind table, return the address of the
+ -- unwind descriptor associated with a code location/space. In the case
+ -- of shared library code, the offset from the beginning of the library
+ -- is expected as Pc.
+
+ procedure U_init_frame_record (Frame : not null access CFD);
+ pragma Import (C, U_init_frame_record, "U_init_frame_record");
+
+ procedure U_prep_frame_rec_for_unwind (Frame : not null access CFD);
+ pragma Import (C, U_prep_frame_rec_for_unwind,
+ "U_prep_frame_rec_for_unwind");
+
+ -- Fetch the description data of the frame in which these two procedures
+ -- are called.
+
+ function U_get_u_rlo
+ (Cur : not null access CFD; Prev : not null access PFD) return Integer;
+ pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX");
+ -- From a complete current frame with a return location possibly located
+ -- into a linker generated stub, and basic information about the previous
+ -- frame, place the first non stub return location into the current frame.
+ -- Return -1 if something went wrong during the computation.
+
+ function U_is_shared_pc (rlo : Address; r19 : Address) return Address;
+ pragma Import (C, U_is_shared_pc, "U_is_shared_pc");
+ -- Return 0 if the provided return location does not correspond to code
+ -- in a shared library, or something non null otherwise.
+
+ function U_get_previous_frame_x
+ (current_frame : not null access CFD;
+ previous_frame : not null access PFD;
+ previous_size : Integer) return Integer;
+ pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x");
+ -- Fetch the data describing the "previous" frame relatively to the
+ -- "current" one. "previous_size" should be the size of the "previous"
+ -- frame descriptor provided.
+ --
+ -- The library provides a simpler interface without the size parameter
+ -- but it is not usable when frames with dynamically allocated space are
+ -- on the way.
+
+ ------------------
+ -- C_Call_Chain --
+ ------------------
+
+ function C_Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural) return Natural
+ is
+ Val : Natural;
+
+ begin
+ Call_Chain (Traceback, Max_Len, Val);
+ return Val;
+ end C_Call_Chain;
+
+ ----------------
+ -- Call_Chain --
+ ----------------
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
+ is
+ type Tracebacks_Array is array (1 .. Max_Len) of System.Address;
+ pragma Suppress_Initialization (Tracebacks_Array);
+
+ -- The code location returned by the unwinder is a return location but
+ -- what we need is a call point. Under HP-UX call instructions are 4
+ -- bytes long and the return point they specify is 4 bytes beyond the
+ -- next instruction because of the delay slot.
+
+ Call_Size : constant := 4;
+ DSlot_Size : constant := 4;
+ Rlo_Offset : constant := Call_Size + DSlot_Size;
+
+ -- Moreover, the return point is passed via a register which two least
+ -- significant bits specify a privilege level that we will have to mask.
+
+ Priv_Mask : constant := 16#00000003#;
+
+ Frame : aliased CFD;
+ Code : System.Address;
+ J : Natural := 1;
+ Pop_Success : Boolean;
+ Trace : Tracebacks_Array;
+ for Trace'Address use Traceback;
+
+ -- The backtracing process needs a set of subprograms :
+
+ function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr;
+ -- Return an access to the unwind descriptor for the caller of
+ -- a given frame, using only the provided return location.
+
+ function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr;
+ -- Return an access to the unwind descriptor for the user code caller
+ -- of a given frame, or null if the information is not available.
+
+ function Pop_Frame (Frame : not null access CFD) return Boolean;
+ -- Update the provided machine state structure so that it reflects
+ -- the state one call frame "above" the initial one.
+ --
+ -- Return True if the operation has been successful, False otherwise.
+ -- Failure typically occurs when the top of the call stack has been
+ -- reached.
+
+ function Prepare_For_Unwind_Of
+ (Frame : not null access CFD) return Boolean;
+ -- Perform the necessary adaptations to the machine state before
+ -- calling the unwinder. Currently used for the specific case of
+ -- dynamically sized previous frames.
+ --
+ -- Return True if everything went fine, or False otherwise.
+
+ Program_UWT : constant UWT := U_get_unwind_table;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ function Pop_Frame (Frame : not null access CFD) return Boolean is
+ Up_Frame : aliased PFD;
+ State_Ready : Boolean;
+
+ begin
+ -- Check/adapt the state before calling the unwinder and return
+ -- if anything went wrong.
+
+ State_Ready := Prepare_For_Unwind_Of (Frame);
+
+ if not State_Ready then
+ return False;
+ end if;
+
+ -- Now, safely call the unwinder and use the results
+
+ if U_get_previous_frame_x (Frame,
+ Up_Frame'Access,
+ Up_Frame'Size) /= 0
+ then
+ return False;
+ end if;
+
+ -- In case a stub is on the way, the usual previous return location
+ -- (the one in prev_rlo) is the one in the stub and the "real" one
+ -- is placed in the "current" record, so let's take this one into
+ -- account.
+
+ Frame.out_rlo := Frame.cur_rlo;
+
+ Frame.cur_fsz := Up_Frame.prev_fsz;
+ Frame.cur_sp := Up_Frame.prev_sp;
+ Frame.cur_rls := Up_Frame.prev_rls;
+ Frame.cur_rlo := Up_Frame.prev_rlo;
+ Frame.cur_dp := Up_Frame.prev_dp;
+ Frame.cur_r19 := Up_Frame.prev_r19;
+ Frame.top_r3 := Up_Frame.top_r3;
+ Frame.top_r4 := Up_Frame.top_r4;
+
+ return True;
+ end Pop_Frame;
+
+ ---------------------------------
+ -- Prepare_State_For_Unwind_Of --
+ ---------------------------------
+
+ function Prepare_For_Unwind_Of
+ (Frame : not null access CFD) return Boolean
+ is
+ Caller_UWD : UWD_Ptr;
+ FP_Adjustment : Integer;
+
+ begin
+ -- No need to bother doing anything if the stack is already fully
+ -- unwound.
+
+ if Frame.cur_rlo = 0 then
+ return False;
+ end if;
+
+ -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder
+ -- uses the value provided in current.top_r3 or current.top_r4 as
+ -- a frame pointer to compute the size of the frame. What decides
+ -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with
+ -- r4 chosen if the bit is set.
+
+ -- The size computed by the unwinder is STATIC_PART + (SP - FP),
+ -- which is correct with HP's frame pointer convention, but not
+ -- with GCC's one since we end up with the static part accounted
+ -- for twice.
+
+ -- We have to compute r4 when it is required because the unwinder
+ -- has looked for it at a place where it was not if we went through
+ -- GCC frames.
+
+ -- The size of the static part of a frame can be found in the
+ -- associated unwind descriptor.
+
+ Caller_UWD := UWD_For_Caller_Of (Frame);
+
+ -- If we cannot get it, we are unable to compute the potentially
+ -- necessary adjustments. We'd better not try to go on then.
+
+ if Caller_UWD = null then
+ return False;
+ end if;
+
+ -- If the caller frame is a GCC one, r3 is its frame pointer and
+ -- points to the bottom of the frame. The value to provide for r4
+ -- can then be computed directly from the one of r3, compensating
+ -- for the static part of the frame.
+
+ -- If the caller frame is an HP one, r3 is used to locate the
+ -- previous frame marker, that is it also points to the bottom of
+ -- the frame (this is why r3 cannot be used as the frame pointer in
+ -- the HP sense for large frames). The value to provide for r4 can
+ -- then also be computed from the one of r3 with the compensation
+ -- for the static part of the frame.
+
+ FP_Adjustment := Integer (Caller_UWD.frame_size * 8);
+ Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment);
+
+ return True;
+ end Prepare_For_Unwind_Of;
+
+ -----------------------
+ -- UWD_For_Caller_Of --
+ -----------------------
+
+ function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr
+ is
+ UWD_Access : UWD_Ptr;
+
+ begin
+ -- First try the most direct path, using the return location data
+ -- associated with the frame.
+
+ UWD_Access := UWD_For_RLO_Of (Frame);
+
+ if UWD_Access /= null then
+ return UWD_Access;
+ end if;
+
+ -- If we did not get a result, we might face an in-stub return
+ -- address. In this case U_get_previous_frame can tell us what the
+ -- first not-in-stub return point is. We cannot call it directly,
+ -- though, because we haven't computed the potentially necessary
+ -- frame pointer adjustments, which might lead to SEGV in some
+ -- circumstances. Instead, we directly call the libcl routine which
+ -- is called by U_get_previous_frame and which only requires few
+ -- information. Take care, however, that the information is provided
+ -- in the "current" argument, so we need to work on a copy to avoid
+ -- disturbing our caller.
+
+ declare
+ U_Current : aliased CFD := Frame.all;
+ U_Previous : aliased PFD;
+
+ begin
+ U_Previous.prev_dp := U_Current.cur_dp;
+ U_Previous.prev_rls := U_Current.cur_rls;
+ U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz;
+
+ if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then
+ UWD_Access := UWD_For_RLO_Of (U_Current'Access);
+ end if;
+ end;
+
+ return UWD_Access;
+ end UWD_For_Caller_Of;
+
+ --------------------
+ -- UWD_For_RLO_Of --
+ --------------------
+
+ function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr
+ is
+ UWD_Address : Address;
+
+ -- The addresses returned by the library point to full descriptors
+ -- including the frame information bits but also the applicable PC
+ -- range. We need to account for this.
+
+ Frame_Info_Offset : constant := 8;
+
+ begin
+ -- First try to locate the descriptor in the program's unwind table
+
+ UWD_Address := U_get_unwind_entry (Frame.cur_rlo,
+ Frame.cur_rls,
+ Program_UWT.Table_Start,
+ Program_UWT.Table_End);
+
+ -- If we did not get it, we might have a frame from code in a
+ -- stub or shared library. For code in stub we would have to
+ -- compute the first non-stub return location but this is not
+ -- the role of this subprogram, so let's just try to see if we
+ -- can get a result from the tables in shared libraries.
+
+ if UWD_Address = -1
+ and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
+ then
+ declare
+ Shlib_UWT : constant UWT :=
+ U_get_shLib_unwind_table (Frame.cur_r19);
+ Shlib_Start : constant Address :=
+ U_get_shLib_text_addr (Frame.cur_r19);
+ Rlo_Offset : constant Address :=
+ Frame.cur_rlo - Shlib_Start;
+ begin
+ UWD_Address := U_get_unwind_entry (Rlo_Offset,
+ Frame.cur_rls,
+ Shlib_UWT.Table_Start,
+ Shlib_UWT.Table_End);
+ end;
+ end if;
+
+ if UWD_Address /= -1 then
+ return To_UWD_Access (UWD_Address + Frame_Info_Offset);
+ else
+ return null;
+ end if;
+ end UWD_For_RLO_Of;
+
+ -- Start of processing for Call_Chain
+
+ begin
+ -- Fetch the state for this subprogram's frame and pop it so that we
+ -- start with an initial out_rlo "here".
+
+ U_init_frame_record (Frame'Access);
+ Frame.top_sr0 := 0;
+ Frame.top_sr4 := 0;
+
+ U_prep_frame_rec_for_unwind (Frame'Access);
+
+ Pop_Success := Pop_Frame (Frame'Access);
+
+ -- Skip the requested number of frames
+
+ for I in 1 .. Skip_Frames loop
+ Pop_Success := Pop_Frame (Frame'Access);
+ end loop;
+
+ -- Loop popping frames and storing locations until either a problem
+ -- occurs, or the top of the call chain is reached, or the provided
+ -- array is full.
+
+ loop
+ -- We have to test some conditions against the return location
+ -- as it is returned, so get it as is first.
+
+ Code := Frame.out_rlo;
+
+ exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1;
+
+ -- Compute the call point from the retrieved return location :
+ -- Mask the privilege bits and account for the delta between the
+ -- call site and the return point.
+
+ Code := (Code and not Priv_Mask) - Rlo_Offset;
+
+ if Code < Exclude_Min or else Code > Exclude_Max then
+ Trace (J) := Code;
+ J := J + 1;
+ end if;
+
+ Pop_Success := Pop_Frame (Frame'Access);
+ end loop;
+
+ Len := J - 1;
+ end Call_Chain;
+
+end System.Traceback;