------------------------------------------------------------------------------
--                                                                          --
--                         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                                  --
--                                                                          --
--                            $Revision: 1.10 $
--                                                                          --
--           Copyright (C) 1999-2001 Ada Core Technologies, 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 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,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, 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. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

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;
   type UWT_Ptr is access all UWT;

   function To_UWT_Address is new Ada.Unchecked_Conversion (UWT_Ptr, Address);

   --  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 : access CFD);
   pragma Import (C, U_init_frame_record, "U_init_frame_record");

   procedure U_prep_frame_rec_for_unwind (Frame : 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 : access CFD; Prev : 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  : access CFD;
      previous_frame : 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)
   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 : 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 : 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 : 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 : 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 : 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 : 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 : 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 : 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   : UWT := U_get_shLib_unwind_table (Frame.cur_r19);
               Shlib_Start : Address := U_get_shLib_text_addr (Frame.cur_r19);
               Rlo_Offset  : 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 the
      --  backtrace starts at the right point for our caller, that is at its
      --  own frame.

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

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