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-2002 Ada Core Technologies, Inc.           --
  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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  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    -------------
  34    -- Name_Id --
  35    -------------
  36
  37    package Chars is new GNAT.Table (
  38      Table_Component_Type => Character,
  39      Table_Index_Type     => Integer,
  40      Table_Low_Bound      => 1,
  41      Table_Initial        => 10_000,
  42      Table_Increment      => 100);
  43    --  The actual character container for names
  44
  45    type Name is  record
  46       First, Last : Integer;
  47    end record;
  48
  49    package Names is new GNAT.Table (
  50      Table_Component_Type => Name,
  51      Table_Index_Type     => Name_Id,
  52      Table_Low_Bound      => 0,
  53      Table_Initial        => 400,
  54      Table_Increment      => 100);
  55
  56    type Name_Range is range 1 .. 1023;
  57
  58    function Name_Eq (N1, N2 : Name) return Boolean;
  59    --  compare 2 names
  60
  61    function H (N : Name) return Name_Range;
  62
  63    package Name_HTable is new GNAT.HTable.Simple_HTable (
  64      Header_Num => Name_Range,
  65      Element    => Name_Id,
  66      No_Element => No_Name_Id,
  67      Key        => Name,
  68      Hash       => H,
  69      Equal      => Name_Eq);
  70
  71    --------------
  72    -- Frame_Id --
  73    --------------
  74
  75    type Frame is record
  76       Name, File, Line : Name_Id;
  77    end record;
  78
  79    function Image
  80      (F       : Frame_Id;
  81       Max_Fil : Integer;
  82       Max_Lin : Integer)
  83       return String;
  84    --  Returns an image for F containing the file name, the Line number,
  85    --  and the subprogram name. When possible, spaces are inserted between
  86    --  the line number and the subprogram name in order to align images of the
  87    --  same frame. Alignement is cimputed with Max_Fil & Max_Lin representing
  88    --  the max number of character in a filename or length in a given frame.
  89
  90    package Frames is new GNAT.Table (
  91      Table_Component_Type => Frame,
  92      Table_Index_Type     => Frame_Id,
  93      Table_Low_Bound      => 1,
  94      Table_Initial        => 400,
  95      Table_Increment      => 100);
  96
  97    type Frame_Range is range 1 .. 513;
  98    function H (N : Frame) return Frame_Range;
  99
 100    package Frame_HTable is new GNAT.HTable.Simple_HTable (
 101      Header_Num => Frame_Range,
 102      Element    => Frame_Id,
 103      No_Element => No_Frame_Id,
 104      Key        => Frame,
 105      Hash       => H,
 106      Equal      => "=");
 107
 108    -------------
 109    -- Root_Id --
 110    -------------
 111
 112    type Root is  record
 113      First, Last     : Integer;
 114      Nb_Alloc        : Integer;
 115      Alloc_Size      : Storage_Count;
 116      High_Water_Mark : Storage_Count;
 117    end record;
 118
 119    package Frames_In_Root is new GNAT.Table (
 120      Table_Component_Type => Frame_Id,
 121      Table_Index_Type     => Integer,
 122      Table_Low_Bound      => 1,
 123      Table_Initial        => 400,
 124      Table_Increment      => 100);
 125
 126    package Roots is new GNAT.Table (
 127      Table_Component_Type => Root,
 128      Table_Index_Type     => Root_Id,
 129      Table_Low_Bound      => 1,
 130      Table_Initial        => 200,
 131      Table_Increment      => 100);
 132    type Root_Range is range 1 .. 513;
 133
 134    function Root_Eq (N1, N2 : Root) return Boolean;
 135    function H     (B : Root)     return Root_Range;
 136
 137    package Root_HTable is new GNAT.HTable.Simple_HTable (
 138      Header_Num => Root_Range,
 139      Element    => Root_Id,
 140      No_Element => No_Root_Id,
 141      Key        => Root,
 142      Hash       => H,
 143      Equal      => Root_Eq);
 144
 145    ----------------
 146    -- Alloc_Size --
 147    ----------------
 148
 149    function Alloc_Size (B : Root_Id) return Storage_Count is
 150    begin
 151       return Roots.Table (B).Alloc_Size;
 152    end Alloc_Size;
 153
 154    -----------------
 155    -- Enter_Frame --
 156    -----------------
 157
 158    function Enter_Frame (Name, File, Line : Name_Id) return Frame_Id is
 159       Res   : Frame_Id;
 160
 161    begin
 162       Frames.Increment_Last;
 163       Frames.Table (Frames.Last) := Frame'(Name, File, Line);
 164       Res := Frame_HTable.Get (Frames.Table (Frames.Last));
 165
 166       if Res /= No_Frame_Id then
 167          Frames.Decrement_Last;
 168          return Res;
 169
 170       else
 171          Frame_HTable.Set (Frames.Table (Frames.Last), Frames.Last);
 172          return Frames.Last;
 173       end if;
 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 : Frame) return Frame_Range is
 289    begin
 290       return Frame_Range (1 + (7 * N.Name + 13 * N.File + 17 * N.Line)
 291                                 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       return String is
 319
 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    begin
 333       return String (Chars.Table (Fil.First .. Fil.Last))
 334         & ':'
 335         & String (Chars.Table (Lin.First .. Lin.Last))
 336         & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len)
 337         & String (Chars.Table (Nam.First .. Nam.Last));
 338    end Image;
 339
 340    -------------
 341    -- Name_Eq --
 342    -------------
 343
 344    function Name_Eq (N1, N2 : Name) return Boolean is
 345       use type Chars.Table_Type;
 346    begin
 347       return
 348         Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last);
 349    end Name_Eq;
 350
 351    --------------
 352    -- Nb_Alloc --
 353    --------------
 354
 355    function Nb_Alloc (B : Root_Id) return Integer is
 356    begin
 357       return Roots.Table (B).Nb_Alloc;
 358    end Nb_Alloc;
 359
 360    --------------
 361    -- Print_BT --
 362    --------------
 363
 364    procedure Print_BT (B  : Root_Id) is
 365       Max_Col_Width : constant := 35;
 366       --  Largest filename length for which backtraces will be
 367       --  properly aligned. Frames containing longer names won't be
 368       --  truncated but they won't be properly aligned either.
 369
 370       F : constant Frame_Array := Frames_Of (B);
 371
 372       Max_Fil : Integer;
 373       Max_Lin : Integer;
 374
 375    begin
 376       Max_Fil := 0;
 377       Max_Lin := 0;
 378
 379       for J in F'Range loop
 380          declare
 381             Fram : Frame renames Frames.Table (F (J));
 382             Fil  : Name renames Names.Table (Fram.File);
 383             Lin  : Name renames Names.Table (Fram.Line);
 384
 385          begin
 386             Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1);
 387             Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1);
 388          end;
 389       end loop;
 390
 391       Max_Fil := Integer'Min (Max_Fil, Max_Col_Width);
 392
 393       for J in F'Range loop
 394          Put ("   ");
 395          Put_Line (Image (F (J), Max_Fil, Max_Lin));
 396       end loop;
 397    end Print_BT;
 398
 399    -------------
 400    -- Read_BT --
 401    -------------
 402
 403    function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id is
 404       Max_Line : constant Integer := 500;
 405       Curs1    : Integer;
 406       Curs2    : Integer;
 407       Line     : String (1 .. Max_Line);
 408       Last     : Integer := 0;
 409       Frames   : Frame_Array (1 .. BT_Depth);
 410       F        : Integer := Frames'First;
 411       Nam      : Name_Id;
 412       Fil      : Name_Id;
 413       Lin      : Name_Id;
 414
 415       No_File    : Boolean := False;
 416       Main_Found : Boolean := False;
 417
 418       procedure Find_File;
 419       --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
 420       --  the file name. The file name may not be on the current line since
 421       --  a frame may be printed on more than one line when there is a lot
 422       --  of parameters or names are long, so this subprogram can read new
 423       --  lines of input.
 424
 425       procedure Find_Line;
 426       --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
 427       --  the line number.
 428
 429       procedure Find_Name;
 430       --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
 431       --  the subprogram name.
 432
 433       procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural);
 434       --  GMEM functionality binding
 435
 436       ---------------
 437       -- Find_File --
 438       ---------------
 439
 440       procedure Find_File is
 441          Match_Parent : Integer;
 442
 443       begin
 444          --  Skip parameters
 445
 446          Curs1 := Curs2 + 3;
 447          Match_Parent := 1;
 448          while Curs1 <= Last loop
 449             if Line (Curs1) = '(' then
 450                Match_Parent := Match_Parent + 1;
 451             elsif Line (Curs1) = ')' then
 452                Match_Parent := Match_Parent - 1;
 453                exit when Match_Parent = 0;
 454             end if;
 455
 456             Curs1 := Curs1 + 1;
 457          end loop;
 458
 459          --  Skip " at "
 460
 461          Curs1 := Curs1 + 5;
 462
 463          if Curs1 >= Last then
 464
 465             --  Maybe the file reference is on one of the next lines
 466
 467             Read : loop
 468                Get_Line (FT, Line, Last);
 469
 470                --  If we have another Frame or if the backtrace is finished
 471                --  the file reference was just missing
 472
 473                if Last <= 1 or else Line (1) = '#' then
 474                   No_File := True;
 475                   Curs2 := Curs1 - 1;
 476                   return;
 477
 478                else
 479                   Curs1 := 1;
 480                   while Curs1 <= Last - 2 loop
 481                      if Line (Curs1) = '(' then
 482                         Match_Parent := Match_Parent + 1;
 483                      elsif Line (Curs1) = ')' then
 484                         Match_Parent := Match_Parent - 1;
 485                      end if;
 486
 487                      if Match_Parent = 0
 488                        and then Line (Curs1 .. Curs1 + 1) = "at"
 489                      then
 490                         Curs1 := Curs1 + 3;
 491                         exit Read;
 492                      end if;
 493
 494                      Curs1 := Curs1 + 1;
 495                   end loop;
 496                end if;
 497             end loop Read;
 498          end if;
 499
 500          --  Let's assume that the filename length is greater than 1
 501          --  it simplifies dealing with the potential drive ':' on
 502          --  windows systems
 503
 504          Curs2 := Curs1 + 1;
 505          while Line (Curs2 + 1) /= ':' loop Curs2 := Curs2 + 1; end loop;
 506       end Find_File;
 507
 508       ---------------
 509       -- Find_Line --
 510       ---------------
 511
 512       procedure Find_Line is
 513       begin
 514          Curs1 := Curs2 + 2;
 515          Curs2 := Last;
 516          if Curs2 - Curs1 > 5 then
 517             raise Constraint_Error;
 518          end if;
 519       end Find_Line;
 520
 521       ---------------
 522       -- Find_Name --
 523       ---------------
 524
 525       procedure Find_Name is
 526       begin
 527          Curs1 := 3;
 528
 529          --  Skip Frame #
 530
 531          while Line (Curs1) /= ' ' loop Curs1 := Curs1 + 1; end loop;
 532
 533          --  Skip spaces
 534
 535          while Line (Curs1)  = ' ' loop Curs1 := Curs1 + 1; end loop;
 536
 537          Curs2 := Curs1;
 538          while Line (Curs2 + 1) /= ' ' loop Curs2 := Curs2 + 1; end loop;
 539       end Find_Name;
 540
 541       ------------------------
 542       -- Gmem_Read_BT_Frame --
 543       ------------------------
 544
 545       procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural) is
 546          procedure Read_BT_Frame (buf : System.Address);
 547          pragma Import (C, Read_BT_Frame, "__gnat_gmem_read_bt_frame");
 548
 549          function Strlen (chars : System.Address) return Natural;
 550          pragma Import (C, Strlen, "strlen");
 551
 552          S :  String (1 .. 1000);
 553       begin
 554          Read_BT_Frame (S'Address);
 555          Last := Strlen (S'Address);
 556          Buf (1 .. Last) := S (1 .. Last);
 557       end Gmem_Read_BT_Frame;
 558
 559    --  Start of processing for Read_BT
 560
 561    begin
 562
 563       if Gmem_Mode then
 564          Gmem_Read_BT_Frame (Line, Last);
 565       else
 566          Line (1) := ' ';
 567          while Line (1) /= '#' loop
 568                Get_Line (FT, Line, Last);
 569          end loop;
 570       end if;
 571
 572       while Last >= 1 and then Line (1) = '#' and then not Main_Found loop
 573          if F <= BT_Depth then
 574             Find_Name;
 575             --  Skip the __gnat_malloc frame itself
 576             if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then
 577                Nam := Enter_Name (Line (Curs1 .. Curs2));
 578                Main_Found := Line (Curs1 .. Curs2) = "main";
 579
 580                Find_File;
 581
 582                if No_File then
 583                   Fil := No_Name_Id;
 584                   Lin := No_Name_Id;
 585                else
 586                   Fil := Enter_Name (Line (Curs1 .. Curs2));
 587
 588                   Find_Line;
 589                   Lin := Enter_Name (Line (Curs1 .. Curs2));
 590                end if;
 591
 592                Frames (F) := Enter_Frame (Nam, Fil, Lin);
 593                F := F + 1;
 594             end if;
 595          end if;
 596
 597          if No_File then
 598
 599             --  If no file reference was found, the next line has already
 600             --  been read because, it may sometimes be found on the next
 601             --  line
 602
 603             No_File := False;
 604
 605          else
 606             if Gmem_Mode then
 607                Gmem_Read_BT_Frame (Line, Last);
 608             else
 609                Get_Line (FT, Line, Last);
 610                exit when End_Of_File (FT);
 611             end if;
 612          end if;
 613
 614       end loop;
 615
 616       return Enter_Root (Frames (1 .. F - 1));
 617    end Read_BT;
 618
 619    -------------
 620    -- Root_Eq --
 621    -------------
 622
 623    function Root_Eq (N1, N2 : Root) return Boolean is
 624       use type Frames_In_Root.Table_Type;
 625
 626    begin
 627       return
 628         Frames_In_Root.Table (N1.First .. N1.Last)
 629           = Frames_In_Root.Table (N2.First .. N2.Last);
 630    end Root_Eq;
 631
 632    --------------------
 633    -- Set_Alloc_Size --
 634    --------------------
 635
 636    procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is
 637    begin
 638       Roots.Table (B).Alloc_Size := V;
 639    end Set_Alloc_Size;
 640
 641    -------------------------
 642    -- Set_High_Water_Mark --
 643    -------------------------
 644
 645    procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is
 646    begin
 647       Roots.Table (B).High_Water_Mark := V;
 648    end Set_High_Water_Mark;
 649
 650    ------------------
 651    -- Set_Nb_Alloc --
 652    ------------------
 653
 654    procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is
 655    begin
 656       Roots.Table (B).Nb_Alloc := V;
 657    end Set_Nb_Alloc;
 658
 659 begin
 660    --  Initialize name for No_Name_ID
 661
 662    Names.Increment_Last;
 663    Names.Table (Names.Last) := Name'(1, 0);
 664 end Memroot;