gcc/ada/libgnat/s-trasym__dwarf.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --           S Y S T E M . T R A C E B A C K . S Y M B O L I C              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1999-2018, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  Run-time symbolic traceback support for targets using DWARF debug data
  33
  34 pragma Polling (Off);
  35 --  We must turn polling off for this unit, because otherwise we can get
  36 --  elaboration circularities when polling is turned on.
  37
  38 with Ada.Unchecked_Deallocation;
  39
  40 with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
  41 with Ada.Containers.Generic_Array_Sort;
  42
  43 with System.Address_To_Access_Conversions;
  44 with System.Soft_Links;
  45 with System.CRTL;
  46 with System.Dwarf_Lines;
  47 with System.Exception_Traces;
  48 with System.Standard_Library;
  49 with System.Traceback_Entries;
  50 with System.Strings;
  51 with System.Bounded_Strings;
  52
  53 package body System.Traceback.Symbolic is
  54
  55    use System.Bounded_Strings;
  56    use System.Dwarf_Lines;
  57
  58    subtype Big_String is String (Positive);
  59    --  To deal with C strings
  60
  61    package Big_String_Conv is new System.Address_To_Access_Conversions
  62      (Big_String);
  63
  64    type Module_Cache;
  65    type Module_Cache_Acc is access all Module_Cache;
  66
  67    type Module_Cache is record
  68       Name : Strings.String_Access;
  69       --  Name of the module
  70
  71       C : Dwarf_Context (In_Exception => True);
  72       --  Context to symbolize an address within this module
  73
  74       Chain : Module_Cache_Acc;
  75    end record;
  76
  77    procedure Free is new Ada.Unchecked_Deallocation
  78      (Module_Cache,
  79       Module_Cache_Acc);
  80
  81    Cache_Chain : Module_Cache_Acc;
  82    --  Simply linked list of modules
  83
  84    type Module_Array is array (Natural range <>) of Module_Cache_Acc;
  85    type Module_Array_Acc is access Module_Array;
  86
  87    Modules_Cache : Module_Array_Acc;
  88    --  Sorted array of cached modules (if not null)
  89
  90    Exec_Module : aliased Module_Cache;
  91    --  Context for the executable
  92
  93    type Init_State is (Uninitialized, Initialized, Failed);
  94    Exec_Module_State : Init_State := Uninitialized;
  95    --  How Exec_Module is initialized
  96
  97    procedure Init_Exec_Module;
  98    --  Initialize Exec_Module if not already initialized
  99
 100    function Symbolic_Traceback
 101      (Traceback    : System.Traceback_Entries.Tracebacks_Array;
 102       Suppress_Hex : Boolean) return String;
 103    function Symbolic_Traceback
 104      (E            : Ada.Exceptions.Exception_Occurrence;
 105       Suppress_Hex : Boolean) return String;
 106    --  Suppress_Hex means do not print any hexadecimal addresses, even if the
 107    --  symbol is not available.
 108
 109    function Lt (Left, Right : Module_Cache_Acc) return Boolean;
 110    --  Sort function for Module_Cache
 111
 112    procedure Init_Module
 113      (Module       : out Module_Cache;
 114       Success      : out Boolean;
 115       Module_Name  :     String;
 116       Load_Address :     Address := Null_Address);
 117    --  Initialize Module
 118
 119    procedure Close_Module (Module : in out Module_Cache);
 120    --  Finalize Module
 121
 122    function Value (Item : System.Address) return String;
 123    --  Return the String contained in Item, up until the first NUL character
 124
 125    pragma Warnings (Off, "*Add_Module_To_Cache*");
 126    procedure Add_Module_To_Cache (Module_Name : String);
 127    --  To be called by Build_Cache_For_All_Modules to add a new module to the
 128    --  list. May not be referenced.
 129
 130    package Module_Name is
 131
 132       procedure Build_Cache_For_All_Modules;
 133       --  Create the cache for all current modules
 134
 135       function Get (Addr : System.Address;
 136                     Load_Addr : access System.Address) return String;
 137       --  Returns the module name for the given address Addr, or an empty
 138       --  string for the main executable.  Load_Addr is set to the shared
 139       --  library load address if this information is available, or to
 140       --  System.Null_Address otherwise.
 141
 142       function Is_Supported return Boolean;
 143       pragma Inline (Is_Supported);
 144       --  Returns True if Module_Name is supported, so if the traceback is
 145       --  supported for shared libraries.
 146
 147    end Module_Name;
 148
 149    package body Module_Name is separate;
 150
 151    function Executable_Name return String;
 152    --  Returns the executable name as reported by argv[0]. If gnat_argv not
 153    --  initialized or if argv[0] executable not found in path, function returns
 154    --  an empty string.
 155
 156    function Get_Executable_Load_Address return System.Address;
 157    pragma Import
 158      (C,
 159       Get_Executable_Load_Address,
 160       "__gnat_get_executable_load_address");
 161    --  Get the load address of the executable, or Null_Address if not known
 162
 163    procedure Hexa_Traceback
 164      (Traceback    :        Tracebacks_Array;
 165       Suppress_Hex :        Boolean;
 166       Res          : in out Bounded_String);
 167    --  Non-symbolic traceback (simply write addresses in hexa)
 168
 169    procedure Symbolic_Traceback_No_Lock
 170      (Traceback    :        Tracebacks_Array;
 171       Suppress_Hex :        Boolean;
 172       Res          : in out Bounded_String);
 173    --  Like the public Symbolic_Traceback_No_Lock except there is no provision
 174    --  against concurrent accesses.
 175
 176    procedure Module_Symbolic_Traceback
 177      (Traceback    :        Tracebacks_Array;
 178       Module       :        Module_Cache;
 179       Suppress_Hex :        Boolean;
 180       Res          : in out Bounded_String);
 181    --  Returns the Traceback for a given module
 182
 183    procedure Multi_Module_Symbolic_Traceback
 184      (Traceback    :        Tracebacks_Array;
 185       Suppress_Hex :        Boolean;
 186       Res          : in out Bounded_String);
 187    --  Build string containing symbolic traceback for the given call chain
 188
 189    procedure Multi_Module_Symbolic_Traceback
 190      (Traceback    :        Tracebacks_Array;
 191       Module       :        Module_Cache;
 192       Suppress_Hex :        Boolean;
 193       Res          : in out Bounded_String);
 194    --  Likewise but using Module
 195
 196    Max_String_Length : constant := 4096;
 197    --  Arbitrary limit on Bounded_Str length
 198
 199    -----------
 200    -- Value --
 201    -----------
 202
 203    function Value (Item : System.Address) return String is
 204    begin
 205       if Item /= Null_Address then
 206          for J in Big_String'Range loop
 207             if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then
 208                return Big_String_Conv.To_Pointer (Item) (1 .. J - 1);
 209             end if;
 210          end loop;
 211       end if;
 212
 213       return "";
 214    end Value;
 215
 216    -------------------------
 217    -- Add_Module_To_Cache --
 218    -------------------------
 219
 220    procedure Add_Module_To_Cache (Module_Name : String) is
 221       Module  : Module_Cache_Acc;
 222       Success : Boolean;
 223    begin
 224       Module := new Module_Cache;
 225       Init_Module (Module.all, Success, Module_Name);
 226       if not Success then
 227          Free (Module);
 228          return;
 229       end if;
 230       Module.Chain := Cache_Chain;
 231       Cache_Chain  := Module;
 232    end Add_Module_To_Cache;
 233
 234    ----------------------
 235    -- Init_Exec_Module --
 236    ----------------------
 237
 238    procedure Init_Exec_Module is
 239    begin
 240       if Exec_Module_State = Uninitialized then
 241          declare
 242             Exec_Path : constant String  := Executable_Name;
 243             Exec_Load : constant Address := Get_Executable_Load_Address;
 244             Success   : Boolean;
 245          begin
 246             Init_Module (Exec_Module, Success, Exec_Path, Exec_Load);
 247
 248             if Success then
 249                Exec_Module_State := Initialized;
 250             else
 251                Exec_Module_State := Failed;
 252             end if;
 253          end;
 254       end if;
 255    end Init_Exec_Module;
 256
 257    --------
 258    -- Lt --
 259    --------
 260
 261    function Lt (Left, Right : Module_Cache_Acc) return Boolean is
 262    begin
 263       return Low (Left.C) < Low (Right.C);
 264    end Lt;
 265
 266    -----------------------------
 267    -- Module_Cache_Array_Sort --
 268    -----------------------------
 269
 270    procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort
 271      (Natural,
 272       Module_Cache_Acc,
 273       Module_Array,
 274       Lt);
 275
 276    ------------------
 277    -- Enable_Cache --
 278    ------------------
 279
 280    procedure Enable_Cache (Include_Modules : Boolean := False) is
 281    begin
 282       --  Can be called at most once
 283       if Cache_Chain /= null then
 284          return;
 285       end if;
 286
 287       --  Add all modules
 288       Init_Exec_Module;
 289       Cache_Chain := Exec_Module'Access;
 290
 291       if Include_Modules then
 292          Module_Name.Build_Cache_For_All_Modules;
 293       end if;
 294
 295       --  Build and fill the array of modules
 296       declare
 297          Count  : Natural;
 298          Module : Module_Cache_Acc;
 299       begin
 300          for Phase in 1 .. 2 loop
 301             Count  := 0;
 302             Module := Cache_Chain;
 303             while Module /= null loop
 304                Count := Count + 1;
 305
 306                if Phase = 1 then
 307                   Enable_Cache (Module.C);
 308                else
 309                   Modules_Cache (Count) := Module;
 310                end if;
 311                Module := Module.Chain;
 312             end loop;
 313
 314             if Phase = 1 then
 315                Modules_Cache := new Module_Array (1 .. Count);
 316             end if;
 317          end loop;
 318       end;
 319
 320       --  Sort the array
 321       Module_Cache_Array_Sort (Modules_Cache.all);
 322    end Enable_Cache;
 323
 324    ---------------------
 325    -- Executable_Name --
 326    ---------------------
 327
 328    function Executable_Name return String is
 329       --  We have to import gnat_argv as an Address to match the type of
 330       --  gnat_argv in the binder generated file. Otherwise, we get spurious
 331       --  warnings about type mismatch when LTO is turned on.
 332
 333       Gnat_Argv : System.Address;
 334       pragma Import (C, Gnat_Argv, "gnat_argv");
 335
 336       type Argv_Array is array (0 .. 0) of System.Address;
 337       package Conv is new System.Address_To_Access_Conversions (Argv_Array);
 338
 339       function locate_exec_on_path (A : System.Address) return System.Address;
 340       pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
 341
 342    begin
 343       if Gnat_Argv = Null_Address then
 344          return "";
 345       end if;
 346
 347       declare
 348          Addr : constant System.Address :=
 349            locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0));
 350          Result : constant String := Value (Addr);
 351
 352       begin
 353          --  The buffer returned by locate_exec_on_path was allocated using
 354          --  malloc, so we should use free to release the memory.
 355
 356          if Addr /= Null_Address then
 357             System.CRTL.free (Addr);
 358          end if;
 359
 360          return Result;
 361       end;
 362    end Executable_Name;
 363
 364    ------------------
 365    -- Close_Module --
 366    ------------------
 367
 368    procedure Close_Module (Module : in out Module_Cache) is
 369    begin
 370       Close (Module.C);
 371       Strings.Free (Module.Name);
 372    end Close_Module;
 373
 374    -----------------
 375    -- Init_Module --
 376    -----------------
 377
 378    procedure Init_Module
 379      (Module       : out Module_Cache;
 380       Success      : out Boolean;
 381       Module_Name  :     String;
 382       Load_Address :     Address := Null_Address)
 383    is
 384    begin
 385       --  Early return if the module is not known
 386
 387       if Module_Name = "" then
 388          Success := False;
 389          return;
 390       end if;
 391
 392       Open (Module_Name, Module.C, Success);
 393
 394       --  If a module can't be opened just return now, we just cannot give more
 395       --  information in this case.
 396
 397       if not Success then
 398          return;
 399       end if;
 400
 401       Set_Load_Address (Module.C, Load_Address);
 402
 403       Module.Name := new String'(Module_Name);
 404    end Init_Module;
 405
 406    -------------------------------
 407    -- Module_Symbolic_Traceback --
 408    -------------------------------
 409
 410    procedure Module_Symbolic_Traceback
 411      (Traceback    :        Tracebacks_Array;
 412       Module       :        Module_Cache;
 413       Suppress_Hex :        Boolean;
 414       Res          : in out Bounded_String)
 415    is
 416       Success : Boolean := False;
 417    begin
 418       if Symbolic.Module_Name.Is_Supported then
 419          Append (Res, '[');
 420          Append (Res, Module.Name.all);
 421          Append (Res, ']' & ASCII.LF);
 422       end if;
 423
 424       Dwarf_Lines.Symbolic_Traceback
 425         (Module.C,
 426          Traceback,
 427          Suppress_Hex,
 428          Success,
 429          Res);
 430
 431       if not Success then
 432          Hexa_Traceback (Traceback, Suppress_Hex, Res);
 433       end if;
 434
 435       --  We must not allow an unhandled exception here, since this function
 436       --  may be installed as a decorator for all automatic exceptions.
 437
 438    exception
 439       when others =>
 440          return;
 441    end Module_Symbolic_Traceback;
 442
 443    -------------------------------------
 444    -- Multi_Module_Symbolic_Traceback --
 445    -------------------------------------
 446
 447    procedure Multi_Module_Symbolic_Traceback
 448      (Traceback    :        Tracebacks_Array;
 449       Suppress_Hex :        Boolean;
 450       Res          : in out Bounded_String)
 451    is
 452       F : constant Natural := Traceback'First;
 453    begin
 454       if Traceback'Length = 0 or else Is_Full (Res) then
 455          return;
 456       end if;
 457
 458       if Modules_Cache /= null then
 459          --  Search in the cache
 460
 461          declare
 462             Addr        : constant Address := Traceback (F);
 463             Hi, Lo, Mid : Natural;
 464          begin
 465             Lo := Modules_Cache'First;
 466             Hi := Modules_Cache'Last;
 467             while Lo <= Hi loop
 468                Mid := (Lo + Hi) / 2;
 469                if Addr < Low (Modules_Cache (Mid).C) then
 470                   Hi := Mid - 1;
 471                elsif Is_Inside (Modules_Cache (Mid).C, Addr) then
 472                   Multi_Module_Symbolic_Traceback
 473                     (Traceback,
 474                      Modules_Cache (Mid).all,
 475                      Suppress_Hex,
 476                      Res);
 477                   return;
 478                else
 479                   Lo := Mid + 1;
 480                end if;
 481             end loop;
 482
 483             --  Not found
 484             Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
 485             Multi_Module_Symbolic_Traceback
 486               (Traceback (F + 1 .. Traceback'Last),
 487                Suppress_Hex,
 488                Res);
 489          end;
 490       else
 491
 492          --  First try the executable
 493          if Is_Inside (Exec_Module.C, Traceback (F)) then
 494             Multi_Module_Symbolic_Traceback
 495               (Traceback,
 496                Exec_Module,
 497                Suppress_Hex,
 498                Res);
 499             return;
 500          end if;
 501
 502          --  Otherwise, try a shared library
 503          declare
 504             Load_Addr : aliased System.Address;
 505             M_Name  : constant String :=
 506               Module_Name.Get (Addr => Traceback (F),
 507                                Load_Addr => Load_Addr'Access);
 508             Module  : Module_Cache;
 509             Success : Boolean;
 510          begin
 511             Init_Module (Module, Success, M_Name, Load_Addr);
 512             if Success then
 513                Multi_Module_Symbolic_Traceback
 514                  (Traceback,
 515                   Module,
 516                   Suppress_Hex,
 517                   Res);
 518                Close_Module (Module);
 519             else
 520                --  Module not found
 521                Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
 522                Multi_Module_Symbolic_Traceback
 523                  (Traceback (F + 1 .. Traceback'Last),
 524                   Suppress_Hex,
 525                   Res);
 526             end if;
 527          end;
 528       end if;
 529    end Multi_Module_Symbolic_Traceback;
 530
 531    procedure Multi_Module_Symbolic_Traceback
 532      (Traceback    :        Tracebacks_Array;
 533       Module       :        Module_Cache;
 534       Suppress_Hex :        Boolean;
 535       Res          : in out Bounded_String)
 536    is
 537       Pos : Positive;
 538    begin
 539       --  Will symbolize the first address...
 540
 541       Pos := Traceback'First + 1;
 542
 543       --  ... and all addresses in the same module
 544
 545       Same_Module :
 546       loop
 547          exit Same_Module when Pos > Traceback'Last;
 548
 549          --  Get address to check for corresponding module name
 550
 551          exit Same_Module when not Is_Inside (Module.C, Traceback (Pos));
 552
 553          Pos := Pos + 1;
 554       end loop Same_Module;
 555
 556       Module_Symbolic_Traceback
 557         (Traceback (Traceback'First .. Pos - 1),
 558          Module,
 559          Suppress_Hex,
 560          Res);
 561       Multi_Module_Symbolic_Traceback
 562         (Traceback (Pos .. Traceback'Last),
 563          Suppress_Hex,
 564          Res);
 565    end Multi_Module_Symbolic_Traceback;
 566
 567    --------------------
 568    -- Hexa_Traceback --
 569    --------------------
 570
 571    procedure Hexa_Traceback
 572      (Traceback    :        Tracebacks_Array;
 573       Suppress_Hex :        Boolean;
 574       Res          : in out Bounded_String)
 575    is
 576       use System.Traceback_Entries;
 577    begin
 578       if Suppress_Hex then
 579          Append (Res, "...");
 580          Append (Res, ASCII.LF);
 581       else
 582          for J in Traceback'Range loop
 583             Append_Address (Res, PC_For (Traceback (J)));
 584             Append (Res, ASCII.LF);
 585          end loop;
 586       end if;
 587    end Hexa_Traceback;
 588
 589    --------------------------------
 590    -- Symbolic_Traceback_No_Lock --
 591    --------------------------------
 592
 593    procedure Symbolic_Traceback_No_Lock
 594      (Traceback    :        Tracebacks_Array;
 595       Suppress_Hex :        Boolean;
 596       Res          : in out Bounded_String)
 597    is
 598    begin
 599       if Symbolic.Module_Name.Is_Supported then
 600          Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
 601       else
 602          if Exec_Module_State = Failed then
 603             Append (Res, "Call stack traceback locations:" & ASCII.LF);
 604             Hexa_Traceback (Traceback, Suppress_Hex, Res);
 605          else
 606             Module_Symbolic_Traceback
 607               (Traceback,
 608                Exec_Module,
 609                Suppress_Hex,
 610                Res);
 611          end if;
 612       end if;
 613    end Symbolic_Traceback_No_Lock;
 614
 615    ------------------------
 616    -- Symbolic_Traceback --
 617    ------------------------
 618
 619    function Symbolic_Traceback
 620      (Traceback    : Tracebacks_Array;
 621       Suppress_Hex : Boolean) return String
 622    is
 623       Res : Bounded_String (Max_Length => Max_String_Length);
 624    begin
 625       System.Soft_Links.Lock_Task.all;
 626       Init_Exec_Module;
 627       Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
 628       System.Soft_Links.Unlock_Task.all;
 629
 630       return To_String (Res);
 631
 632    exception
 633       when others =>
 634          System.Soft_Links.Unlock_Task.all;
 635          raise;
 636    end Symbolic_Traceback;
 637
 638    function Symbolic_Traceback
 639      (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
 640    begin
 641       return Symbolic_Traceback (Traceback, Suppress_Hex => False);
 642    end Symbolic_Traceback;
 643
 644    function Symbolic_Traceback_No_Hex
 645      (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
 646    begin
 647       return Symbolic_Traceback (Traceback, Suppress_Hex => True);
 648    end Symbolic_Traceback_No_Hex;
 649
 650    function Symbolic_Traceback
 651      (E            : Ada.Exceptions.Exception_Occurrence;
 652       Suppress_Hex : Boolean) return String
 653    is
 654    begin
 655       return Symbolic_Traceback
 656           (Ada.Exceptions.Traceback.Tracebacks (E),
 657            Suppress_Hex);
 658    end Symbolic_Traceback;
 659
 660    function Symbolic_Traceback
 661      (E : Ada.Exceptions.Exception_Occurrence) return String
 662    is
 663    begin
 664       return Symbolic_Traceback (E, Suppress_Hex => False);
 665    end Symbolic_Traceback;
 666
 667    function Symbolic_Traceback_No_Hex
 668      (E : Ada.Exceptions.Exception_Occurrence) return String is
 669    begin
 670       return Symbolic_Traceback (E, Suppress_Hex => True);
 671    end Symbolic_Traceback_No_Hex;
 672
 673    Exception_Tracebacks_Symbolic : Integer;
 674    pragma Import
 675      (C,
 676       Exception_Tracebacks_Symbolic,
 677       "__gl_exception_tracebacks_symbolic");
 678    --  Boolean indicating whether symbolic tracebacks should be generated.
 679
 680    use Standard_Library;
 681 begin
 682    --  If this version of this package is available, and the binder switch -Es
 683    --  was given, then we want to use this as the decorator by default, and we
 684    --  want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
 685    --  cannot have already set Exception_Trace, because the runtime library is
 686    --  elaborated before user-defined code.
 687
 688    if Exception_Tracebacks_Symbolic /= 0 then
 689       Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
 690       pragma Assert (Exception_Trace = RM_Convention);
 691       Exception_Trace := Unhandled_Raise_In_Main;
 692    end if;
 693 end System.Traceback.Symbolic;