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