gcc/ada/memroot.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              M E M R O O T                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1997-2008, 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with GNAT.Table;
  27 with GNAT.HTable; use GNAT.HTable;
  28 with Ada.Text_IO; use Ada.Text_IO;
  29
  30 package body Memroot is
  31
  32    Main_Name_Id : Name_Id;
  33    --  The constant "main" where we should stop the backtraces
  34
  35    -------------
  36    -- Name_Id --
  37    -------------
  38
  39    package Chars is new GNAT.Table (
  40      Table_Component_Type => Character,
  41      Table_Index_Type     => Integer,
  42      Table_Low_Bound      => 1,
  43      Table_Initial        => 10_000,
  44      Table_Increment      => 100);
  45    --  The actual character container for names
  46
  47    type Name is  record
  48       First, Last : Integer;
  49    end record;
  50
  51    package Names is new GNAT.Table (
  52      Table_Component_Type => Name,
  53      Table_Index_Type     => Name_Id,
  54      Table_Low_Bound      => 0,
  55      Table_Initial        => 400,
  56      Table_Increment      => 100);
  57
  58    type Name_Range is range 1 .. 1023;
  59
  60    function Name_Eq (N1, N2 : Name) return Boolean;
  61    --  compare 2 names
  62
  63    function H (N : Name) return Name_Range;
  64
  65    package Name_HTable is new GNAT.HTable.Simple_HTable (
  66      Header_Num => Name_Range,
  67      Element    => Name_Id,
  68      No_Element => No_Name_Id,
  69      Key        => Name,
  70      Hash       => H,
  71      Equal      => Name_Eq);
  72
  73    --------------
  74    -- Frame_Id --
  75    --------------
  76
  77    type Frame is record
  78       Name, File, Line : Name_Id;
  79    end record;
  80
  81    function Image
  82      (F       : Frame_Id;
  83       Max_Fil : Integer;
  84       Max_Lin : Integer;
  85       Short   : Boolean := False) return String;
  86    --  Returns an image for F containing the file name, the Line number,
  87    --  and if 'Short' is not true, the subprogram name. When possible, spaces
  88    --  are inserted between the line number and the subprogram name in order
  89    --  to align images of the same frame. Alignment is computed with Max_Fil
  90    --  & Max_Lin representing the max number of character in a filename or
  91    --  length in a given frame.
  92
  93    package Frames is new GNAT.Table (
  94      Table_Component_Type => Frame,
  95      Table_Index_Type     => Frame_Id,
  96      Table_Low_Bound      => 1,
  97      Table_Initial        => 400,
  98      Table_Increment      => 100);
  99
 100    type Frame_Range is range 1 .. 10000;
 101    function H (N : Integer_Address) return Frame_Range;
 102
 103    package Frame_HTable is new GNAT.HTable.Simple_HTable (
 104      Header_Num => Frame_Range,
 105      Element    => Frame_Id,
 106      No_Element => No_Frame_Id,
 107      Key        => Integer_Address,
 108      Hash       => H,
 109      Equal      => "=");
 110
 111    -------------
 112    -- Root_Id --
 113    -------------
 114
 115    type Root is  record
 116      First, Last     : Integer;
 117      Nb_Alloc        : Integer;
 118      Alloc_Size      : Storage_Count;
 119      High_Water_Mark : Storage_Count;
 120    end record;
 121
 122    package Frames_In_Root is new GNAT.Table (
 123      Table_Component_Type => Frame_Id,
 124      Table_Index_Type     => Integer,
 125      Table_Low_Bound      => 1,
 126      Table_Initial        => 400,
 127      Table_Increment      => 100);
 128
 129    package Roots is new GNAT.Table (
 130      Table_Component_Type => Root,
 131      Table_Index_Type     => Root_Id,
 132      Table_Low_Bound      => 1,
 133      Table_Initial        => 200,
 134      Table_Increment      => 100);
 135    type Root_Range is range 1 .. 513;
 136
 137    function Root_Eq (N1, N2 : Root) return Boolean;
 138    function H     (B : Root)     return Root_Range;
 139
 140    package Root_HTable is new GNAT.HTable.Simple_HTable (
 141      Header_Num => Root_Range,
 142      Element    => Root_Id,
 143      No_Element => No_Root_Id,
 144      Key        => Root,
 145      Hash       => H,
 146      Equal      => Root_Eq);
 147
 148    ----------------
 149    -- Alloc_Size --
 150    ----------------
 151
 152    function Alloc_Size (B : Root_Id) return Storage_Count is
 153    begin
 154       return Roots.Table (B).Alloc_Size;
 155    end Alloc_Size;
 156
 157    -----------------
 158    -- Enter_Frame --
 159    -----------------
 160
 161    function Enter_Frame
 162      (Addr : System.Address;
 163       Name : Name_Id;
 164       File : Name_Id;
 165       Line : Name_Id)
 166       return Frame_Id
 167    is
 168    begin
 169       Frames.Increment_Last;
 170       Frames.Table (Frames.Last) := Frame'(Name, File, Line);
 171
 172       Frame_HTable.Set (To_Integer (Addr), Frames.Last);
 173       return Frames.Last;
 174    end Enter_Frame;
 175
 176    ----------------
 177    -- Enter_Name --
 178    ----------------
 179
 180    function Enter_Name (S : String) return Name_Id is
 181       Old_L : constant Integer := Chars.Last;
 182       Len   : constant Integer := S'Length;
 183       F     : constant Integer := Chars.Allocate (Len);
 184       Res   : Name_Id;
 185
 186    begin
 187       Chars.Table (F .. F + Len - 1) := Chars.Table_Type (S);
 188       Names.Increment_Last;
 189       Names.Table (Names.Last) := Name'(F, F + Len - 1);
 190       Res := Name_HTable.Get (Names.Table (Names.Last));
 191
 192       if Res /= No_Name_Id then
 193          Names.Decrement_Last;
 194          Chars.Set_Last (Old_L);
 195          return Res;
 196
 197       else
 198          Name_HTable.Set (Names.Table (Names.Last), Names.Last);
 199          return Names.Last;
 200       end if;
 201    end Enter_Name;
 202
 203    ----------------
 204    -- Enter_Root --
 205    ----------------
 206
 207    function Enter_Root (Fr : Frame_Array) return Root_Id is
 208       Old_L : constant Integer  := Frames_In_Root.Last;
 209       Len   : constant Integer  := Fr'Length;
 210       F     : constant Integer  := Frames_In_Root.Allocate (Len);
 211       Res   : Root_Id;
 212
 213    begin
 214       Frames_In_Root.Table (F .. F + Len - 1) :=
 215         Frames_In_Root.Table_Type (Fr);
 216       Roots.Increment_Last;
 217       Roots.Table (Roots.Last) := Root'(F, F + Len - 1, 0, 0, 0);
 218       Res := Root_HTable.Get (Roots.Table (Roots.Last));
 219
 220       if Res /= No_Root_Id then
 221          Frames_In_Root.Set_Last (Old_L);
 222          Roots.Decrement_Last;
 223          return Res;
 224
 225       else
 226          Root_HTable.Set (Roots.Table (Roots.Last), Roots.Last);
 227          return Roots.Last;
 228       end if;
 229    end Enter_Root;
 230
 231    ---------------
 232    -- Frames_Of --
 233    ---------------
 234
 235    function Frames_Of (B : Root_Id) return Frame_Array is
 236    begin
 237       return Frame_Array (
 238         Frames_In_Root.Table (Roots.Table (B).First .. Roots.Table (B).Last));
 239    end Frames_Of;
 240
 241    ---------------
 242    -- Get_First --
 243    ---------------
 244
 245    function Get_First return Root_Id is
 246    begin
 247       return  Root_HTable.Get_First;
 248    end Get_First;
 249
 250    --------------
 251    -- Get_Next --
 252    --------------
 253
 254    function Get_Next return Root_Id is
 255    begin
 256       return Root_HTable.Get_Next;
 257    end Get_Next;
 258
 259    -------
 260    -- H --
 261    -------
 262
 263    function H (B : Root) return Root_Range is
 264
 265       type Uns is mod 2 ** 32;
 266
 267       function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
 268       pragma Import (Intrinsic, Rotate_Left);
 269
 270       Tmp : Uns := 0;
 271
 272    begin
 273       for J in B.First .. B.Last loop
 274          Tmp := Rotate_Left (Tmp, 1) + Uns (Frames_In_Root.Table (J));
 275       end loop;
 276
 277       return Root_Range'First
 278         + Root_Range'Base (Tmp mod Root_Range'Range_Length);
 279    end H;
 280
 281    function H (N : Name) return Name_Range is
 282       function H is new Hash (Name_Range);
 283
 284    begin
 285       return H (String (Chars.Table (N.First .. N.Last)));
 286    end H;
 287
 288    function H (N : Integer_Address) return Frame_Range is
 289    begin
 290       return Frame_Range (1 + N mod Frame_Range'Range_Length);
 291    end H;
 292
 293    ---------------------
 294    -- High_Water_Mark --
 295    ---------------------
 296
 297    function High_Water_Mark (B : Root_Id) return Storage_Count is
 298    begin
 299       return Roots.Table (B).High_Water_Mark;
 300    end High_Water_Mark;
 301
 302    -----------
 303    -- Image --
 304    -----------
 305
 306    function Image (N : Name_Id) return String is
 307       Nam : Name renames Names.Table (N);
 308
 309    begin
 310       return String (Chars.Table (Nam.First .. Nam.Last));
 311    end Image;
 312
 313    function Image
 314      (F       : Frame_Id;
 315       Max_Fil : Integer;
 316       Max_Lin : Integer;
 317       Short   : Boolean := False) return String
 318    is
 319       Fram : Frame renames Frames.Table (F);
 320       Fil  : Name renames Names.Table (Fram.File);
 321       Lin  : Name renames Names.Table (Fram.Line);
 322       Nam  : Name renames Names.Table (Fram.Name);
 323
 324       Fil_Len  : constant Integer := Fil.Last - Fil.First + 1;
 325       Lin_Len  : constant Integer := Lin.Last - Lin.First + 1;
 326
 327       use type Chars.Table_Type;
 328
 329       Spaces : constant String (1 .. 80) := (1 .. 80 => ' ');
 330
 331       Result : constant String :=
 332         String (Chars.Table (Fil.First .. Fil.Last))
 333         & ':'
 334         & String (Chars.Table (Lin.First .. Lin.Last));
 335    begin
 336       if Short then
 337          return Result;
 338       else
 339          return Result
 340            & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len)
 341            & String (Chars.Table (Nam.First .. Nam.Last));
 342       end if;
 343    end Image;
 344
 345    -------------
 346    -- Name_Eq --
 347    -------------
 348
 349    function Name_Eq (N1, N2 : Name) return Boolean is
 350       use type Chars.Table_Type;
 351    begin
 352       return
 353         Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last);
 354    end Name_Eq;
 355
 356    --------------
 357    -- Nb_Alloc --
 358    --------------
 359
 360    function Nb_Alloc (B : Root_Id) return Integer is
 361    begin
 362       return Roots.Table (B).Nb_Alloc;
 363    end Nb_Alloc;
 364
 365    --------------
 366    -- Print_BT --
 367    --------------
 368
 369    procedure Print_BT (B  : Root_Id; Short : Boolean := False) is
 370       Max_Col_Width : constant := 35;
 371       --  Largest filename length for which backtraces will be
 372       --  properly aligned. Frames containing longer names won't be
 373       --  truncated but they won't be properly aligned either.
 374
 375       F : constant Frame_Array := Frames_Of (B);
 376
 377       Max_Fil : Integer;
 378       Max_Lin : Integer;
 379
 380    begin
 381       Max_Fil := 0;
 382       Max_Lin := 0;
 383
 384       for J in F'Range loop
 385          declare
 386             Fram : Frame renames Frames.Table (F (J));
 387             Fil  : Name renames Names.Table (Fram.File);
 388             Lin  : Name renames Names.Table (Fram.Line);
 389
 390          begin
 391             Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1);
 392             Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1);
 393          end;
 394       end loop;
 395
 396       Max_Fil := Integer'Min (Max_Fil, Max_Col_Width);
 397
 398       for J in F'Range loop
 399          Put ("   ");
 400          Put_Line (Image (F (J), Max_Fil, Max_Lin, Short));
 401       end loop;
 402    end Print_BT;
 403
 404    -------------
 405    -- Read_BT --
 406    -------------
 407
 408    function Read_BT (BT_Depth : Integer) return Root_Id is
 409       Max_Line : constant Integer := 500;
 410       Curs1    : Integer;
 411       Curs2    : Integer;
 412       Line     : String (1 .. Max_Line);
 413       Last     : Integer := 0;
 414       Frames   : Frame_Array (1 .. BT_Depth);
 415       F        : Integer := Frames'First;
 416       Nam      : Name_Id;
 417       Fil      : Name_Id;
 418       Lin      : Name_Id;
 419       Add      : System.Address;
 420       Int_Add  : Integer_Address;
 421       Fr       : Frame_Id;
 422       Main_Found : Boolean := False;
 423       pragma Warnings (Off, Line);
 424
 425       procedure Find_File;
 426       pragma Inline (Find_File);
 427       --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
 428       --  the file name. The file name may not be on the current line since
 429       --  a frame may be printed on more than one line when there is a lot
 430       --  of parameters or names are long, so this subprogram can read new
 431       --  lines of input.
 432
 433       procedure Find_Line;
 434       pragma Inline (Find_Line);
 435       --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
 436       --  the line number.
 437
 438       procedure Find_Name;
 439       pragma Inline (Find_Name);
 440       --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
 441       --  the subprogram name.
 442
 443       function Skip_To_Space (Pos : Integer) return Integer;
 444       pragma Inline (Skip_To_Space);
 445       --  Scans Line starting with position Pos, returning the position
 446       --  immediately before the first space, or the value of Last if no
 447       --  spaces were found
 448
 449       ---------------
 450       -- Find_File --
 451       ---------------
 452
 453       procedure Find_File is
 454       begin
 455          --  Skip " at "
 456
 457          Curs1 := Curs2 + 5;
 458          Curs2 := Last;
 459
 460          --  Scan backwards from end of line until ':' is encountered
 461
 462          for J in reverse Curs1 .. Last loop
 463             if Line (J) = ':' then
 464                Curs2 := J - 1;
 465             end if;
 466          end loop;
 467       end Find_File;
 468
 469       ---------------
 470       -- Find_Line --
 471       ---------------
 472
 473       procedure Find_Line is
 474       begin
 475          Curs1 := Curs2 + 2;
 476          Curs2 := Last;
 477
 478          --  Check for Curs1 too large. Should never happen with non-corrupt
 479          --  output. If it does happen, just reset it to the highest value.
 480
 481          if Curs1 > Last then
 482             Curs1 := Last;
 483          end if;
 484       end Find_Line;
 485
 486       ---------------
 487       -- Find_Name --
 488       ---------------
 489
 490       procedure Find_Name is
 491       begin
 492          --  Skip the address value and " in "
 493
 494          Curs1 := Skip_To_Space (1) + 5;
 495          Curs2 := Skip_To_Space (Curs1);
 496       end Find_Name;
 497
 498       -------------------
 499       -- Skip_To_Space --
 500       -------------------
 501
 502       function Skip_To_Space (Pos : Integer) return Integer is
 503       begin
 504          for Cur in Pos .. Last loop
 505             if Line (Cur) = ' ' then
 506                return Cur - 1;
 507             end if;
 508          end loop;
 509
 510          return Last;
 511       end Skip_To_Space;
 512
 513       procedure Gmem_Read_Next_Frame (Addr : out System.Address);
 514       pragma Import (C, Gmem_Read_Next_Frame, "__gnat_gmem_read_next_frame");
 515       --  Read the next frame in the current traceback. Addr is set to 0 if
 516       --  there are no more addresses in this traceback. The pointer is moved
 517       --  to the next frame.
 518
 519       procedure Gmem_Symbolic
 520         (Addr : System.Address; Buf : String; Last : out Natural);
 521       pragma Import (C, Gmem_Symbolic, "__gnat_gmem_symbolic");
 522       --  Get the symbolic traceback for Addr. Note: we cannot use
 523       --  GNAT.Tracebacks.Symbolic, since the latter will only work with the
 524       --  current executable.
 525       --
 526       --  "__gnat_gmem_symbolic" will work with the executable whose name is
 527       --  given in gnat_argv[0], as initialized by Gnatmem.Gmem_A21_Initialize.
 528
 529    --  Start of processing for Read_BT
 530
 531    begin
 532       while F <= BT_Depth and then not Main_Found loop
 533          Gmem_Read_Next_Frame (Add);
 534          Int_Add := To_Integer (Add);
 535          exit when Int_Add = 0;
 536
 537          Fr := Frame_HTable.Get (Int_Add);
 538
 539          if Fr = No_Frame_Id then
 540             Gmem_Symbolic (Add, Line, Last);
 541             Last := Last - 1; -- get rid of the trailing line-feed
 542             Find_Name;
 543
 544             --  Skip the __gnat_malloc frame itself
 545
 546             if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then
 547                Nam := Enter_Name (Line (Curs1 .. Curs2));
 548                Main_Found := (Nam = Main_Name_Id);
 549
 550                Find_File;
 551                Fil := Enter_Name (Line (Curs1 .. Curs2));
 552                Find_Line;
 553                Lin := Enter_Name (Line (Curs1 .. Curs2));
 554
 555                Frames (F) := Enter_Frame (Add, Nam, Fil, Lin);
 556                F := F + 1;
 557             end if;
 558
 559          else
 560             Frames (F) := Fr;
 561             Main_Found := (Memroot.Frames.Table (Fr).Name = Main_Name_Id);
 562             F := F + 1;
 563          end if;
 564       end loop;
 565
 566       return Enter_Root (Frames (1 .. F - 1));
 567    end Read_BT;
 568
 569    -------------
 570    -- Root_Eq --
 571    -------------
 572
 573    function Root_Eq (N1, N2 : Root) return Boolean is
 574       use type Frames_In_Root.Table_Type;
 575
 576    begin
 577       return
 578         Frames_In_Root.Table (N1.First .. N1.Last)
 579           = Frames_In_Root.Table (N2.First .. N2.Last);
 580    end Root_Eq;
 581
 582    --------------------
 583    -- Set_Alloc_Size --
 584    --------------------
 585
 586    procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is
 587    begin
 588       Roots.Table (B).Alloc_Size := V;
 589    end Set_Alloc_Size;
 590
 591    -------------------------
 592    -- Set_High_Water_Mark --
 593    -------------------------
 594
 595    procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is
 596    begin
 597       Roots.Table (B).High_Water_Mark := V;
 598    end Set_High_Water_Mark;
 599
 600    ------------------
 601    -- Set_Nb_Alloc --
 602    ------------------
 603
 604    procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is
 605    begin
 606       Roots.Table (B).Nb_Alloc := V;
 607    end Set_Nb_Alloc;
 608
 609 begin
 610    --  Initialize name for No_Name_ID
 611
 612    Names.Increment_Last;
 613    Names.Table (Names.Last) := Name'(1, 0);
 614    Main_Name_Id := Enter_Name ("main");
 615 end Memroot;