------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--           S Y S T E M . T R A C E B A C K . S Y M B O L I C              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 1999-2022, 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 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.      --
--                                                                          --
------------------------------------------------------------------------------

--  Run-time symbolic traceback support for targets using DWARF debug data

with Ada.Unchecked_Deallocation;

with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
with Ada.Containers.Generic_Array_Sort;

with System.Address_To_Access_Conversions;
with System.Soft_Links;
with System.CRTL;
with System.Dwarf_Lines;
with System.Exception_Traces;
with System.Standard_Library;
with System.Traceback_Entries;
with System.Strings;
with System.Bounded_Strings;

package body System.Traceback.Symbolic is

   use System.Bounded_Strings;
   use System.Dwarf_Lines;

   subtype Big_String is String (Positive);
   --  To deal with C strings

   package Big_String_Conv is new System.Address_To_Access_Conversions
     (Big_String);

   type Module_Cache;
   type Module_Cache_Acc is access all Module_Cache;

   type Module_Cache is record
      Name : Strings.String_Access;
      --  Name of the module

      C : Dwarf_Context (In_Exception => True);
      --  Context to symbolize an address within this module

      Chain : Module_Cache_Acc;
   end record;

   procedure Free is new Ada.Unchecked_Deallocation
     (Module_Cache,
      Module_Cache_Acc);

   Cache_Chain : Module_Cache_Acc;
   --  Simply linked list of modules

   type Module_Array is array (Natural range <>) of Module_Cache_Acc;
   type Module_Array_Acc is access Module_Array;

   Modules_Cache : Module_Array_Acc;
   --  Sorted array of cached modules (if not null)

   Exec_Module : aliased Module_Cache;
   --  Context for the executable

   type Init_State is (Uninitialized, Initialized, Failed);
   Exec_Module_State : Init_State := Uninitialized;
   --  How Exec_Module is initialized

   procedure Init_Exec_Module;
   --  Initialize Exec_Module if not already initialized

   function Symbolic_Traceback
     (Traceback    : System.Traceback_Entries.Tracebacks_Array;
      Suppress_Hex : Boolean) return String;
   function Symbolic_Traceback
     (E            : Ada.Exceptions.Exception_Occurrence;
      Suppress_Hex : Boolean) return String;
   --  Suppress_Hex means do not print any hexadecimal addresses, even if the
   --  symbol is not available.

   function Lt (Left, Right : Module_Cache_Acc) return Boolean;
   --  Sort function for Module_Cache

   procedure Init_Module
     (Module       : out Module_Cache;
      Success      : out Boolean;
      Module_Name  :     String;
      Load_Address :     Address := Null_Address);
   --  Initialize Module

   procedure Close_Module (Module : in out Module_Cache);
   --  Finalize Module

   function Value (Item : System.Address) return String;
   --  Return the String contained in Item, up until the first NUL character

   pragma Warnings (Off, "*Add_Module_To_Cache*");
   procedure Add_Module_To_Cache (Module_Name : String;
                                  Load_Address : System.Address);
   --  To be called by Build_Cache_For_All_Modules to add a new module to the
   --  list. May not be referenced.

   package Module_Name is

      procedure Build_Cache_For_All_Modules;
      --  Create the cache for all current modules

      function Get (Addr : System.Address;
                    Load_Addr : access System.Address) return String;
      --  Returns the module name for the given address Addr, or an empty
      --  string for the main executable.  Load_Addr is set to the shared
      --  library load address if this information is available, or to
      --  System.Null_Address otherwise.

      function Is_Supported return Boolean;
      pragma Inline (Is_Supported);
      --  Returns True if Module_Name is supported, so if the traceback is
      --  supported for shared libraries.

   end Module_Name;

   package body Module_Name is separate;

   function Executable_Name return String;
   --  Returns the executable name as reported by argv[0]. If gnat_argv not
   --  initialized, return an empty string. If the argv[0] executable is not
   --  found in the PATH, return it unresolved.

   function Get_Executable_Load_Address return System.Address;
   pragma Import
     (C,
      Get_Executable_Load_Address,
      "__gnat_get_executable_load_address");
   --  Get the load address of the executable, or Null_Address if not known

   procedure Hexa_Traceback
     (Traceback    :        Tracebacks_Array;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String);
   --  Non-symbolic traceback (simply write addresses in hexa)

   procedure Symbolic_Traceback_No_Lock
     (Traceback    :        Tracebacks_Array;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String);
   --  Like the public Symbolic_Traceback_No_Lock except there is no provision
   --  against concurrent accesses.

   procedure Module_Symbolic_Traceback
     (Traceback    :        Tracebacks_Array;
      Module       :        Module_Cache;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String);
   --  Returns the Traceback for a given module

   procedure Multi_Module_Symbolic_Traceback
     (Traceback    :        Tracebacks_Array;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String);
   --  Build string containing symbolic traceback for the given call chain

   procedure Multi_Module_Symbolic_Traceback
     (Traceback    :        Tracebacks_Array;
      Module       :        Module_Cache;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String);
   --  Likewise but using Module

   Max_String_Length : constant := 4096;
   --  Arbitrary limit on Bounded_Str length

   -----------
   -- Value --
   -----------

   function Value (Item : System.Address) return String is
   begin
      if Item /= Null_Address then
         for J in Big_String'Range loop
            if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then
               return Big_String_Conv.To_Pointer (Item) (1 .. J - 1);
            end if;
         end loop;
      end if;

      return "";
   end Value;

   -------------------------
   -- Add_Module_To_Cache --
   -------------------------

   procedure Add_Module_To_Cache (Module_Name : String;
                                  Load_Address : System.Address)
   is
      Module  : Module_Cache_Acc;
      Success : Boolean;
   begin
      Module := new Module_Cache;
      Init_Module (Module.all, Success, Module_Name, Load_Address);
      if not Success then
         Free (Module);
         return;
      end if;
      Module.Chain := Cache_Chain;
      Cache_Chain  := Module;
   end Add_Module_To_Cache;

   ----------------------
   -- Init_Exec_Module --
   ----------------------

   procedure Init_Exec_Module is
   begin
      if Exec_Module_State = Uninitialized then
         declare
            Exec_Path : constant String  := Executable_Name;
            Exec_Load : constant Address := Get_Executable_Load_Address;
            Success   : Boolean;
         begin
            Init_Module (Exec_Module, Success, Exec_Path, Exec_Load);

            if Success then
               Exec_Module_State := Initialized;
            else
               Exec_Module_State := Failed;
            end if;
         end;
      end if;
   end Init_Exec_Module;

   --------
   -- Lt --
   --------

   function Lt (Left, Right : Module_Cache_Acc) return Boolean is
   begin
      return Low_Address (Left.C) < Low_Address (Right.C);
   end Lt;

   -----------------------------
   -- Module_Cache_Array_Sort --
   -----------------------------

   procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort
     (Natural,
      Module_Cache_Acc,
      Module_Array,
      Lt);

   ------------------
   -- Enable_Cache --
   ------------------

   procedure Enable_Cache (Include_Modules : Boolean := False) is
   begin
      --  Can be called at most once
      if Cache_Chain /= null then
         return;
      end if;

      --  Add all modules
      Init_Exec_Module;

      if Exec_Module_State = Failed then
         raise Program_Error with
           "cannot enable cache, executable state initialization failed.";
      end if;

      Cache_Chain := Exec_Module'Access;

      if Include_Modules then
         Module_Name.Build_Cache_For_All_Modules;
      end if;

      --  Build and fill the array of modules
      declare
         Count  : Natural;
         Module : Module_Cache_Acc;
      begin
         for Phase in 1 .. 2 loop
            Count  := 0;
            Module := Cache_Chain;
            while Module /= null loop
               Count := Count + 1;

               if Phase = 1 then
                  Enable_Cache (Module.C);
               else
                  Modules_Cache (Count) := Module;
               end if;
               Module := Module.Chain;
            end loop;

            if Phase = 1 then
               Modules_Cache := new Module_Array (1 .. Count);
            end if;
         end loop;
      end;

      --  Sort the array
      Module_Cache_Array_Sort (Modules_Cache.all);
   end Enable_Cache;

   ---------------------
   -- Executable_Name --
   ---------------------

   function Executable_Name return String is
      --  We have to import gnat_argv as an Address to match the type of
      --  gnat_argv in the binder generated file. Otherwise, we get spurious
      --  warnings about type mismatch when LTO is turned on.

      Gnat_Argv : System.Address;
      pragma Import (C, Gnat_Argv, "gnat_argv");

      type Argv_Array is array (0 .. 0) of System.Address;
      package Conv is new System.Address_To_Access_Conversions (Argv_Array);

      function locate_exec_on_path (A : System.Address) return System.Address;
      pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");

   begin
      if Gnat_Argv = Null_Address then
         return "";
      end if;

      --  See if we can resolve argv[0] to a full path (to a file that we will
      --  be able to open). If the resolution fails, we were probably spawned
      --  by an imprecise exec call, typically passing a mere file name as
      --  argv[0] for a program in the current directory with '.' not on PATH.
      --  Best we can do is fallback to argv[0] unchanged in this case. If we
      --  fail opening that downstream, we'll just bail out.

      declare
         Argv0 : constant System.Address
           := Conv.To_Pointer (Gnat_Argv) (0);

         Resolved_Argv0 : constant System.Address
           := locate_exec_on_path (Argv0);

         Exe_Argv : constant System.Address
           := (if Resolved_Argv0 /= System.Null_Address
               then Resolved_Argv0
               else Argv0);

         Result : constant String := Value (Exe_Argv);

      begin
         --  The buffer returned by locate_exec_on_path was allocated using
         --  malloc and we should release this memory.

         if Resolved_Argv0 /= Null_Address then
            System.CRTL.free (Resolved_Argv0);
         end if;

         return Result;
      end;
   end Executable_Name;

   ------------------
   -- Close_Module --
   ------------------

   procedure Close_Module (Module : in out Module_Cache) is
   begin
      Close (Module.C);
      Strings.Free (Module.Name);
   end Close_Module;

   -----------------
   -- Init_Module --
   -----------------

   procedure Init_Module
     (Module       : out Module_Cache;
      Success      : out Boolean;
      Module_Name  :     String;
      Load_Address :     Address := Null_Address)
   is
   begin
      --  Early return if the module is not known

      if Module_Name = "" then
         Success := False;
         return;
      end if;

      Open (Module_Name, Module.C, Success);

      --  If a module can't be opened just return now, we just cannot give more
      --  information in this case.

      if not Success then
         return;
      end if;

      Set_Load_Address (Module.C, Load_Address);

      Module.Name := new String'(Module_Name);
   end Init_Module;

   -------------------------------
   -- Module_Symbolic_Traceback --
   -------------------------------

   procedure Module_Symbolic_Traceback
     (Traceback    :        Tracebacks_Array;
      Module       :        Module_Cache;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String)
   is
      Success : Boolean;
   begin
      if Symbolic.Module_Name.Is_Supported then
         Append (Res, '[');
         Append (Res, Module.Name.all);
         Append (Res, ']' & ASCII.LF);
      end if;

      Dwarf_Lines.Symbolic_Traceback
        (Module.C,
         Traceback,
         Suppress_Hex,
         Success,
         Res);

      if not Success then
         Hexa_Traceback (Traceback, Suppress_Hex, Res);
      end if;

      --  We must not allow an unhandled exception here, since this function
      --  may be installed as a decorator for all automatic exceptions.

   exception
      when others =>
         return;
   end Module_Symbolic_Traceback;

   -------------------------------------
   -- Multi_Module_Symbolic_Traceback --
   -------------------------------------

   procedure Multi_Module_Symbolic_Traceback
     (Traceback    :        Tracebacks_Array;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String)
   is
      F : constant Natural := Traceback'First;
   begin
      if Traceback'Length = 0 or else Is_Full (Res) then
         return;
      end if;

      if Modules_Cache /= null then
         --  Search in the cache

         declare
            Addr        : constant Address := Traceback (F);
            Hi, Lo, Mid : Natural;
         begin
            Lo := Modules_Cache'First;
            Hi := Modules_Cache'Last;
            while Lo <= Hi loop
               Mid := (Lo + Hi) / 2;
               if Addr < Low_Address (Modules_Cache (Mid).C) then
                  Hi := Mid - 1;
               elsif Is_Inside (Modules_Cache (Mid).C, Addr) then
                  Multi_Module_Symbolic_Traceback
                    (Traceback,
                     Modules_Cache (Mid).all,
                     Suppress_Hex,
                     Res);
                  return;
               else
                  Lo := Mid + 1;
               end if;
            end loop;

            --  Not found
            Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
            Multi_Module_Symbolic_Traceback
              (Traceback (F + 1 .. Traceback'Last),
               Suppress_Hex,
               Res);
         end;
      else

         --  First try the executable
         if Is_Inside (Exec_Module.C, Traceback (F)) then
            Multi_Module_Symbolic_Traceback
              (Traceback,
               Exec_Module,
               Suppress_Hex,
               Res);
            return;
         end if;

         --  Otherwise, try a shared library
         declare
            Load_Addr : aliased System.Address;
            M_Name  : constant String :=
              Module_Name.Get (Addr => Traceback (F),
                               Load_Addr => Load_Addr'Access);
            Module  : Module_Cache;
            Success : Boolean;
         begin
            Init_Module (Module, Success, M_Name, Load_Addr);
            if Success then
               Multi_Module_Symbolic_Traceback
                 (Traceback,
                  Module,
                  Suppress_Hex,
                  Res);
               Close_Module (Module);
            else
               --  Module not found
               Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
               Multi_Module_Symbolic_Traceback
                 (Traceback (F + 1 .. Traceback'Last),
                  Suppress_Hex,
                  Res);
            end if;
         end;
      end if;
   end Multi_Module_Symbolic_Traceback;

   procedure Multi_Module_Symbolic_Traceback
     (Traceback    :        Tracebacks_Array;
      Module       :        Module_Cache;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String)
   is
      Pos : Positive;
   begin
      --  Will symbolize the first address...

      Pos := Traceback'First + 1;

      --  ... and all addresses in the same module

      Same_Module :
      loop
         exit Same_Module when Pos > Traceback'Last;

         --  Get address to check for corresponding module name

         exit Same_Module when not Is_Inside (Module.C, Traceback (Pos));

         Pos := Pos + 1;
      end loop Same_Module;

      Module_Symbolic_Traceback
        (Traceback (Traceback'First .. Pos - 1),
         Module,
         Suppress_Hex,
         Res);
      Multi_Module_Symbolic_Traceback
        (Traceback (Pos .. Traceback'Last),
         Suppress_Hex,
         Res);
   end Multi_Module_Symbolic_Traceback;

   --------------------
   -- Hexa_Traceback --
   --------------------

   procedure Hexa_Traceback
     (Traceback    :        Tracebacks_Array;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String)
   is
      use System.Traceback_Entries;
   begin
      if Suppress_Hex then
         Append (Res, "...");
         Append (Res, ASCII.LF);
      else
         for J in Traceback'Range loop
            Append_Address (Res, PC_For (Traceback (J)));
            Append (Res, ASCII.LF);
         end loop;
      end if;
   end Hexa_Traceback;

   --------------------------------
   -- Symbolic_Traceback_No_Lock --
   --------------------------------

   procedure Symbolic_Traceback_No_Lock
     (Traceback    :        Tracebacks_Array;
      Suppress_Hex :        Boolean;
      Res          : in out Bounded_String)
   is
   begin
      if Symbolic.Module_Name.Is_Supported then
         Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
      else
         if Exec_Module_State = Failed then
            Append (Res, "Call stack traceback locations:" & ASCII.LF);
            Hexa_Traceback (Traceback, Suppress_Hex, Res);
         else
            Module_Symbolic_Traceback
              (Traceback,
               Exec_Module,
               Suppress_Hex,
               Res);
         end if;
      end if;
   end Symbolic_Traceback_No_Lock;

   ------------------------
   -- Symbolic_Traceback --
   ------------------------

   function Symbolic_Traceback
     (Traceback    : Tracebacks_Array;
      Suppress_Hex : Boolean) return String
   is
      Res : Bounded_String (Max_Length => Max_String_Length);
   begin
      System.Soft_Links.Lock_Task.all;
      Init_Exec_Module;
      Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
      System.Soft_Links.Unlock_Task.all;

      return To_String (Res);

   exception
      when others =>
         System.Soft_Links.Unlock_Task.all;
         raise;
   end Symbolic_Traceback;

   function Symbolic_Traceback
     (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
   begin
      return Symbolic_Traceback (Traceback, Suppress_Hex => False);
   end Symbolic_Traceback;

   function Symbolic_Traceback_No_Hex
     (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
   begin
      return Symbolic_Traceback (Traceback, Suppress_Hex => True);
   end Symbolic_Traceback_No_Hex;

   function Symbolic_Traceback
     (E            : Ada.Exceptions.Exception_Occurrence;
      Suppress_Hex : Boolean) return String
   is
   begin
      return Symbolic_Traceback
          (Ada.Exceptions.Traceback.Tracebacks (E),
           Suppress_Hex);
   end Symbolic_Traceback;

   function Symbolic_Traceback
     (E : Ada.Exceptions.Exception_Occurrence) return String
   is
   begin
      return Symbolic_Traceback (E, Suppress_Hex => False);
   end Symbolic_Traceback;

   function Symbolic_Traceback_No_Hex
     (E : Ada.Exceptions.Exception_Occurrence) return String is
   begin
      return Symbolic_Traceback (E, Suppress_Hex => True);
   end Symbolic_Traceback_No_Hex;

   Exception_Tracebacks_Symbolic : constant Integer;
   pragma Import
     (C,
      Exception_Tracebacks_Symbolic,
      "__gl_exception_tracebacks_symbolic");
   --  Boolean indicating whether symbolic tracebacks should be generated.

   use Standard_Library;
begin
   --  If this version of this package is available, and the binder switch -Es
   --  was given, then we want to use this as the decorator by default, and we
   --  want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
   --  cannot have already set Exception_Trace, because the runtime library is
   --  elaborated before user-defined code.

   if Exception_Tracebacks_Symbolic /= 0 then
      Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
      pragma Assert (Exception_Trace = RM_Convention);
      Exception_Trace := Unhandled_Raise_In_Main;
   end if;
end System.Traceback.Symbolic;