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