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