diff options
Diffstat (limited to 'gcc/ada/memroot.adb')
| -rw-r--r-- | gcc/ada/memroot.adb | 663 |
1 files changed, 663 insertions, 0 deletions
diff --git a/gcc/ada/memroot.adb b/gcc/ada/memroot.adb new file mode 100644 index 00000000000..d8db62b751b --- /dev/null +++ b/gcc/ada/memroot.adb @@ -0,0 +1,663 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M E M R O O T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1997-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Table; +with GNAT.HTable; use GNAT.HTable; +with Ada.Text_IO; use Ada.Text_IO; + +package body Memroot is + + ------------- + -- Name_Id -- + ------------- + + package Chars is new GNAT.Table ( + Table_Component_Type => Character, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 10_000, + Table_Increment => 100); + -- The actual character container for names + + type Name is record + First, Last : Integer; + end record; + + package Names is new GNAT.Table ( + Table_Component_Type => Name, + Table_Index_Type => Name_Id, + Table_Low_Bound => 0, + Table_Initial => 400, + Table_Increment => 100); + + type Name_Range is range 1 .. 1023; + + function Name_Eq (N1, N2 : Name) return Boolean; + -- compare 2 names + + function H (N : Name) return Name_Range; + + package Name_HTable is new GNAT.HTable.Simple_HTable ( + Header_Num => Name_Range, + Element => Name_Id, + No_Element => No_Name_Id, + Key => Name, + Hash => H, + Equal => Name_Eq); + + -------------- + -- Frame_Id -- + -------------- + + type Frame is record + Name, File, Line : Name_Id; + end record; + + function Image + (F : Frame_Id; + Max_Fil : Integer; + Max_Lin : Integer) + return String; + -- Returns an image for F containing the file name, the Line number, + -- and the subprogram name. When possible, spaces are inserted between + -- the line number and the subprogram name in order to align images of the + -- same frame. Alignement is cimputed with Max_Fil & Max_Lin representing + -- the max number of character in a filename or length in a given frame. + + package Frames is new GNAT.Table ( + Table_Component_Type => Frame, + Table_Index_Type => Frame_Id, + Table_Low_Bound => 1, + Table_Initial => 400, + Table_Increment => 100); + + type Frame_Range is range 1 .. 513; + function H (N : Frame) return Frame_Range; + + package Frame_HTable is new GNAT.HTable.Simple_HTable ( + Header_Num => Frame_Range, + Element => Frame_Id, + No_Element => No_Frame_Id, + Key => Frame, + Hash => H, + Equal => "="); + + ------------- + -- Root_Id -- + ------------- + + type Root is record + First, Last : Integer; + Nb_Alloc : Integer; + Alloc_Size : Storage_Count; + High_Water_Mark : Storage_Count; + end record; + + package Frames_In_Root is new GNAT.Table ( + Table_Component_Type => Frame_Id, + Table_Index_Type => Integer, + Table_Low_Bound => 1, + Table_Initial => 400, + Table_Increment => 100); + + package Roots is new GNAT.Table ( + Table_Component_Type => Root, + Table_Index_Type => Root_Id, + Table_Low_Bound => 1, + Table_Initial => 200, + Table_Increment => 100); + type Root_Range is range 1 .. 513; + + function Root_Eq (N1, N2 : Root) return Boolean; + function H (B : Root) return Root_Range; + + package Root_HTable is new GNAT.HTable.Simple_HTable ( + Header_Num => Root_Range, + Element => Root_Id, + No_Element => No_Root_Id, + Key => Root, + Hash => H, + Equal => Root_Eq); + + ---------------- + -- Alloc_Size -- + ---------------- + + function Alloc_Size (B : Root_Id) return Storage_Count is + begin + return Roots.Table (B).Alloc_Size; + end Alloc_Size; + + ----------------- + -- Enter_Frame -- + ----------------- + + function Enter_Frame (Name, File, Line : Name_Id) return Frame_Id is + Res : Frame_Id; + + begin + Frames.Increment_Last; + Frames.Table (Frames.Last) := Frame'(Name, File, Line); + Res := Frame_HTable.Get (Frames.Table (Frames.Last)); + + if Res /= No_Frame_Id then + Frames.Decrement_Last; + return Res; + + else + Frame_HTable.Set (Frames.Table (Frames.Last), Frames.Last); + return Frames.Last; + end if; + end Enter_Frame; + + ---------------- + -- Enter_Name -- + ---------------- + + function Enter_Name (S : String) return Name_Id is + Old_L : constant Integer := Chars.Last; + Len : constant Integer := S'Length; + F : constant Integer := Chars.Allocate (Len); + Res : Name_Id; + + begin + Chars.Table (F .. F + Len - 1) := Chars.Table_Type (S); + Names.Increment_Last; + Names.Table (Names.Last) := Name'(F, F + Len - 1); + Res := Name_HTable.Get (Names.Table (Names.Last)); + + if Res /= No_Name_Id then + Names.Decrement_Last; + Chars.Set_Last (Old_L); + return Res; + + else + Name_HTable.Set (Names.Table (Names.Last), Names.Last); + return Names.Last; + end if; + end Enter_Name; + + ---------------- + -- Enter_Root -- + ---------------- + + function Enter_Root (Fr : Frame_Array) return Root_Id is + Old_L : constant Integer := Frames_In_Root.Last; + Len : constant Integer := Fr'Length; + F : constant Integer := Frames_In_Root.Allocate (Len); + Res : Root_Id; + + begin + Frames_In_Root.Table (F .. F + Len - 1) := + Frames_In_Root.Table_Type (Fr); + Roots.Increment_Last; + Roots.Table (Roots.Last) := Root'(F, F + Len - 1, 0, 0, 0); + Res := Root_HTable.Get (Roots.Table (Roots.Last)); + + if Res /= No_Root_Id then + Frames_In_Root.Set_Last (Old_L); + Roots.Decrement_Last; + return Res; + + else + Root_HTable.Set (Roots.Table (Roots.Last), Roots.Last); + return Roots.Last; + end if; + end Enter_Root; + + --------------- + -- Frames_Of -- + --------------- + + function Frames_Of (B : Root_Id) return Frame_Array is + begin + return Frame_Array ( + Frames_In_Root.Table (Roots.Table (B).First .. Roots.Table (B).Last)); + end Frames_Of; + + --------------- + -- Get_First -- + --------------- + + function Get_First return Root_Id is + begin + return Root_HTable.Get_First; + end Get_First; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next return Root_Id is + begin + return Root_HTable.Get_Next; + end Get_Next; + + ------- + -- H -- + ------- + + function H (B : Root) return Root_Range is + + type Uns is mod 2 ** 32; + + function Rotate_Left (Value : Uns; Amount : Natural) return Uns; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Uns := 0; + + begin + for J in B.First .. B.Last loop + Tmp := Rotate_Left (Tmp, 1) + Uns (Frames_In_Root.Table (J)); + end loop; + + return Root_Range'First + + Root_Range'Base (Tmp mod Root_Range'Range_Length); + end H; + + function H (N : Name) return Name_Range is + function H is new Hash (Name_Range); + + begin + return H (String (Chars.Table (N.First .. N.Last))); + end H; + + function H (N : Frame) return Frame_Range is + begin + return Frame_Range (1 + (7 * N.Name + 13 * N.File + 17 * N.Line) + mod Frame_Range'Range_Length); + end H; + + --------------------- + -- High_Water_Mark -- + --------------------- + + function High_Water_Mark (B : Root_Id) return Storage_Count is + begin + return Roots.Table (B).High_Water_Mark; + end High_Water_Mark; + + ----------- + -- Image -- + ----------- + + function Image (N : Name_Id) return String is + Nam : Name renames Names.Table (N); + + begin + return String (Chars.Table (Nam.First .. Nam.Last)); + end Image; + + function Image + (F : Frame_Id; + Max_Fil : Integer; + Max_Lin : Integer) + return String is + + Fram : Frame renames Frames.Table (F); + Fil : Name renames Names.Table (Fram.File); + Lin : Name renames Names.Table (Fram.Line); + Nam : Name renames Names.Table (Fram.Name); + + Fil_Len : constant Integer := Fil.Last - Fil.First + 1; + Lin_Len : constant Integer := Lin.Last - Lin.First + 1; + + use type Chars.Table_Type; + + Spaces : constant String (1 .. 80) := (1 .. 80 => ' '); + + begin + return String (Chars.Table (Fil.First .. Fil.Last)) + & ':' + & String (Chars.Table (Lin.First .. Lin.Last)) + & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len) + & String (Chars.Table (Nam.First .. Nam.Last)); + end Image; + + ------------- + -- Name_Eq -- + ------------- + + function Name_Eq (N1, N2 : Name) return Boolean is + use type Chars.Table_Type; + begin + return + Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last); + end Name_Eq; + + -------------- + -- Nb_Alloc -- + -------------- + + function Nb_Alloc (B : Root_Id) return Integer is + begin + return Roots.Table (B).Nb_Alloc; + end Nb_Alloc; + + -------------- + -- Print_BT -- + -------------- + + procedure Print_BT (B : Root_Id) is + Max_Col_Width : constant := 35; + -- Largest filename length for which backtraces will be + -- properly aligned. Frames containing longer names won't be + -- truncated but they won't be properly aligned either. + + F : constant Frame_Array := Frames_Of (B); + + Max_Fil : Integer; + Max_Lin : Integer; + + begin + Max_Fil := 0; + Max_Lin := 0; + + for J in F'Range loop + declare + Fram : Frame renames Frames.Table (F (J)); + Fil : Name renames Names.Table (Fram.File); + Lin : Name renames Names.Table (Fram.Line); + + begin + Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1); + Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1); + end; + end loop; + + Max_Fil := Integer'Min (Max_Fil, Max_Col_Width); + + for J in F'Range loop + Put (" "); + Put_Line (Image (F (J), Max_Fil, Max_Lin)); + end loop; + end Print_BT; + + ------------- + -- Read_BT -- + ------------- + + function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id is + Max_Line : constant Integer := 500; + Curs1 : Integer; + Curs2 : Integer; + Line : String (1 .. Max_Line); + Last : Integer := 0; + Frames : Frame_Array (1 .. BT_Depth); + F : Integer := Frames'First; + Nam : Name_Id; + Fil : Name_Id; + Lin : Name_Id; + + No_File : Boolean := False; + Main_Found : Boolean := False; + + procedure Find_File; + -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains + -- the file name. The file name may not be on the current line since + -- a frame may be printed on more than one line when there is a lot + -- of parameters or names are long, so this subprogram can read new + -- lines of input. + + procedure Find_Line; + -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains + -- the line number. + + procedure Find_Name; + -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains + -- the subprogram name. + + procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural); + -- GMEM functionality binding + + --------------- + -- Find_File -- + --------------- + + procedure Find_File is + Match_Parent : Integer; + + begin + -- Skip parameters + + Curs1 := Curs2 + 3; + Match_Parent := 1; + while Curs1 <= Last loop + if Line (Curs1) = '(' then + Match_Parent := Match_Parent + 1; + elsif Line (Curs1) = ')' then + Match_Parent := Match_Parent - 1; + exit when Match_Parent = 0; + end if; + + Curs1 := Curs1 + 1; + end loop; + + -- Skip " at " + + Curs1 := Curs1 + 5; + + if Curs1 >= Last then + + -- Maybe the file reference is on one of the next lines + + Read : loop + Get_Line (FT, Line, Last); + + -- If we have another Frame or if the backtrace is finished + -- the file reference was just missing + + if Last <= 1 or else Line (1) = '#' then + No_File := True; + Curs2 := Curs1 - 1; + return; + + else + Curs1 := 1; + while Curs1 <= Last - 2 loop + if Line (Curs1) = '(' then + Match_Parent := Match_Parent + 1; + elsif Line (Curs1) = ')' then + Match_Parent := Match_Parent - 1; + end if; + + if Match_Parent = 0 + and then Line (Curs1 .. Curs1 + 1) = "at" + then + Curs1 := Curs1 + 3; + exit Read; + end if; + + Curs1 := Curs1 + 1; + end loop; + end if; + end loop Read; + end if; + + -- Let's assume that the filename length is greater than 1 + -- it simplifies dealing with the potential drive ':' on + -- windows systems + + Curs2 := Curs1 + 1; + while Line (Curs2 + 1) /= ':' loop Curs2 := Curs2 + 1; end loop; + end Find_File; + + --------------- + -- Find_Line -- + --------------- + + procedure Find_Line is + begin + Curs1 := Curs2 + 2; + Curs2 := Last; + if Curs2 - Curs1 > 5 then + raise Constraint_Error; + end if; + end Find_Line; + + --------------- + -- Find_Name -- + --------------- + + procedure Find_Name is + begin + Curs1 := 3; + + -- Skip Frame # + + while Line (Curs1) /= ' ' loop Curs1 := Curs1 + 1; end loop; + + -- Skip spaces + + while Line (Curs1) = ' ' loop Curs1 := Curs1 + 1; end loop; + + Curs2 := Curs1; + while Line (Curs2 + 1) /= ' ' loop Curs2 := Curs2 + 1; end loop; + end Find_Name; + + ------------------------ + -- Gmem_Read_BT_Frame -- + ------------------------ + + procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural) is + procedure Read_BT_Frame (buf : System.Address); + pragma Import (C, Read_BT_Frame, "__gnat_gmem_read_bt_frame"); + + function Strlen (chars : System.Address) return Natural; + pragma Import (C, Strlen, "strlen"); + + S : String (1 .. 1000); + begin + Read_BT_Frame (S'Address); + Last := Strlen (S'Address); + Buf (1 .. Last) := S (1 .. Last); + end Gmem_Read_BT_Frame; + + -- Start of processing for Read_BT + + begin + + if Gmem_Mode then + Gmem_Read_BT_Frame (Line, Last); + else + Line (1) := ' '; + while Line (1) /= '#' loop + Get_Line (FT, Line, Last); + end loop; + end if; + + while Last >= 1 and then Line (1) = '#' and then not Main_Found loop + if F <= BT_Depth then + Find_Name; + Nam := Enter_Name (Line (Curs1 .. Curs2)); + Main_Found := Line (Curs1 .. Curs2) = "main"; + + Find_File; + + if No_File then + Fil := No_Name_Id; + Lin := No_Name_Id; + else + Fil := Enter_Name (Line (Curs1 .. Curs2)); + + Find_Line; + Lin := Enter_Name (Line (Curs1 .. Curs2)); + end if; + + Frames (F) := Enter_Frame (Nam, Fil, Lin); + F := F + 1; + end if; + + if No_File then + + -- If no file reference was found, the next line has already + -- been read because, it may sometimes be found on the next + -- line + + No_File := False; + + else + if Gmem_Mode then + Gmem_Read_BT_Frame (Line, Last); + else + Get_Line (FT, Line, Last); + exit when End_Of_File (FT); + end if; + end if; + + end loop; + + return Enter_Root (Frames (1 .. F - 1)); + end Read_BT; + + ------------- + -- Root_Eq -- + ------------- + + function Root_Eq (N1, N2 : Root) return Boolean is + use type Frames_In_Root.Table_Type; + + begin + return + Frames_In_Root.Table (N1.First .. N1.Last) + = Frames_In_Root.Table (N2.First .. N2.Last); + end Root_Eq; + + -------------------- + -- Set_Alloc_Size -- + -------------------- + + procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is + begin + Roots.Table (B).Alloc_Size := V; + end Set_Alloc_Size; + + ------------------------- + -- Set_High_Water_Mark -- + ------------------------- + + procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is + begin + Roots.Table (B).High_Water_Mark := V; + end Set_High_Water_Mark; + + ------------------ + -- Set_Nb_Alloc -- + ------------------ + + procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is + begin + Roots.Table (B).Nb_Alloc := V; + end Set_Nb_Alloc; + +begin + -- Initialize name for No_Name_ID + + Names.Increment_Last; + Names.Table (Names.Last) := Name'(1, 0); +end Memroot; |