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