blob: d95a039f3a660b7412b6535a2dbf80948a12a31c [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- 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) 2009-2022, Free Software Foundation, Inc. --
-- --
-- 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 3, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- 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, whereas 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.
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);
-- Same as the exported version, but takes Traceback as an Address
------------------
-- 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_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;
procedure Call_Chain
(Traceback : in out System.Traceback_Entries.Tracebacks_Array;
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
begin
Call_Chain
(Traceback'Address, Max_Len, Len,
Exclude_Min, Exclude_Max,
-- Skip one extra frame to skip the other Call_Chain entry as well
Skip_Frames => Skip_Frames + 1);
end Call_Chain;
end System.Traceback;