1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2002 Ada Core Technologies, Inc. --
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. --
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). --
25 ------------------------------------------------------------------------------
28 with GNAT
.HTable
; use GNAT
.HTable
;
29 with Ada
.Text_IO
; use Ada
.Text_IO
;
31 package body Memroot
is
37 package Chars
is new GNAT
.Table
(
38 Table_Component_Type
=> Character,
39 Table_Index_Type
=> Integer,
41 Table_Initial
=> 10_000
,
42 Table_Increment
=> 100);
43 -- The actual character container for names
46 First
, Last
: Integer;
49 package Names
is new GNAT
.Table
(
50 Table_Component_Type
=> Name
,
51 Table_Index_Type
=> Name_Id
,
54 Table_Increment
=> 100);
56 type Name_Range
is range 1 .. 1023;
58 function Name_Eq
(N1
, N2
: Name
) return Boolean;
61 function H
(N
: Name
) return Name_Range
;
63 package Name_HTable
is new GNAT
.HTable
.Simple_HTable
(
64 Header_Num
=> Name_Range
,
66 No_Element
=> No_Name_Id
,
76 Name
, File
, Line
: Name_Id
;
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.
90 package Frames
is new GNAT
.Table
(
91 Table_Component_Type
=> Frame
,
92 Table_Index_Type
=> Frame_Id
,
95 Table_Increment
=> 100);
97 type Frame_Range
is range 1 .. 513;
98 function H
(N
: Frame
) return Frame_Range
;
100 package Frame_HTable
is new GNAT
.HTable
.Simple_HTable
(
101 Header_Num
=> Frame_Range
,
103 No_Element
=> No_Frame_Id
,
113 First
, Last
: Integer;
115 Alloc_Size
: Storage_Count
;
116 High_Water_Mark
: Storage_Count
;
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);
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;
134 function Root_Eq
(N1
, N2
: Root
) return Boolean;
135 function H
(B
: Root
) return Root_Range
;
137 package Root_HTable
is new GNAT
.HTable
.Simple_HTable
(
138 Header_Num
=> Root_Range
,
140 No_Element
=> No_Root_Id
,
149 function Alloc_Size
(B
: Root_Id
) return Storage_Count
is
151 return Roots
.Table
(B
).Alloc_Size
;
158 function Enter_Frame
(Name
, File
, Line
: Name_Id
) return Frame_Id
is
162 Frames
.Increment_Last
;
163 Frames
.Table
(Frames
.Last
) := Frame
'(Name, File, Line);
164 Res := Frame_HTable.Get (Frames.Table (Frames.Last));
166 if Res /= No_Frame_Id then
167 Frames.Decrement_Last;
171 Frame_HTable.Set (Frames.Table (Frames.Last), Frames.Last);
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);
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
));
192 if Res
/= No_Name_Id
then
193 Names
.Decrement_Last
;
194 Chars
.Set_Last
(Old_L
);
198 Name_HTable
.Set
(Names
.Table
(Names
.Last
), Names
.Last
);
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
);
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));
220 if Res /= No_Root_Id then
221 Frames_In_Root.Set_Last (Old_L);
222 Roots.Decrement_Last;
226 Root_HTable.Set (Roots.Table (Roots.Last), Roots.Last);
235 function Frames_Of (B : Root_Id) return Frame_Array is
238 Frames_In_Root.Table (Roots.Table (B).First .. Roots.Table (B).Last));
245 function Get_First return Root_Id is
247 return Root_HTable.Get_First;
254 function Get_Next return Root_Id is
256 return Root_HTable.Get_Next;
263 function H (B : Root) return Root_Range is
265 type Uns is mod 2 ** 32;
267 function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
268 pragma Import (Intrinsic, Rotate_Left);
273 for J in B.First .. B.Last loop
274 Tmp := Rotate_Left (Tmp, 1) + Uns (Frames_In_Root.Table (J));
277 return Root_Range'First
278 + Root_Range'Base (Tmp mod Root_Range'Range_Length);
281 function H (N : Name) return Name_Range is
282 function H is new Hash (Name_Range);
285 return H (String (Chars.Table (N.First .. N.Last)));
288 function H (N : Frame) return Frame_Range is
290 return Frame_Range (1 + (7 * N.Name + 13 * N.File + 17 * N.Line)
291 mod Frame_Range'Range_Length);
294 ---------------------
295 -- High_Water_Mark --
296 ---------------------
298 function High_Water_Mark (B : Root_Id) return Storage_Count is
300 return Roots.Table (B).High_Water_Mark;
307 function Image (N : Name_Id) return String is
308 Nam : Name renames Names.Table (N);
311 return String (Chars.Table (Nam.First .. Nam.Last));
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);
325 Fil_Len : constant Integer := Fil.Last - Fil.First + 1;
326 Lin_Len : constant Integer := Lin.Last - Lin.First + 1;
328 use type Chars.Table_Type;
330 Spaces : constant String (1 .. 80) := (1 .. 80 => ' ');
333 return String (Chars.Table (Fil.First .. Fil.Last))
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));
344 function Name_Eq (N1, N2 : Name) return Boolean is
345 use type Chars.Table_Type;
348 Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last);
355 function Nb_Alloc (B : Root_Id) return Integer is
357 return Roots.Table (B).Nb_Alloc;
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.
370 F : constant Frame_Array := Frames_Of (B);
379 for J in F'Range loop
381 Fram : Frame renames Frames.Table (F (J));
382 Fil : Name renames Names.Table (Fram.File);
383 Lin : Name renames Names.Table (Fram.Line);
386 Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1);
387 Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1);
391 Max_Fil := Integer'Min (Max_Fil, Max_Col_Width);
393 for J in F'Range loop
395 Put_Line (Image (F (J), Max_Fil, Max_Lin));
403 function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id is
404 Max_Line : constant Integer := 500;
407 Line : String (1 .. Max_Line);
409 Frames : Frame_Array (1 .. BT_Depth);
410 F : Integer := Frames'First;
415 No_File : Boolean := False;
416 Main_Found : Boolean := False;
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
426 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
430 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
431 -- the subprogram name.
433 procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural);
434 -- GMEM functionality binding
440 procedure Find_File is
441 Match_Parent : Integer;
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;
463 if Curs1 >= Last then
465 -- Maybe the file reference is on one of the next lines
468 Get_Line (FT, Line, Last);
470 -- If we have another Frame or if the backtrace is finished
471 -- the file reference was just missing
473 if Last <= 1 or else Line (1) = '#
' then
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;
488 and then Line (Curs1 .. Curs1 + 1) = "at"
500 -- Let's assume that the filename length is greater than 1
501 -- it simplifies dealing with the potential drive ':' on
505 while Line (Curs2 + 1) /= ':' loop Curs2 := Curs2 + 1; end loop;
512 procedure Find_Line is
516 if Curs2 - Curs1 > 5 then
517 raise Constraint_Error;
525 procedure Find_Name is
531 while Line (Curs1) /= ' ' loop Curs1 := Curs1 + 1; end loop;
535 while Line (Curs1) = ' ' loop Curs1 := Curs1 + 1; end loop;
538 while Line (Curs2 + 1) /= ' ' loop Curs2 := Curs2 + 1; end loop;
541 ------------------------
542 -- Gmem_Read_BT_Frame --
543 ------------------------
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");
549 function Strlen (chars : System.Address) return Natural;
550 pragma Import (C, Strlen, "strlen");
552 S : String (1 .. 1000);
554 Read_BT_Frame (S'Address);
555 Last := Strlen (S'Address);
556 Buf (1 .. Last) := S (1 .. Last);
557 end Gmem_Read_BT_Frame;
559 -- Start of processing for Read_BT
564 Gmem_Read_BT_Frame (Line, Last);
567 while Line (1) /= '#
' loop
568 Get_Line (FT, Line, Last);
572 while Last >= 1 and then Line (1) = '#
' and then not Main_Found loop
573 if F <= BT_Depth then
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";
586 Fil := Enter_Name (Line (Curs1 .. Curs2));
589 Lin := Enter_Name (Line (Curs1 .. Curs2));
592 Frames (F) := Enter_Frame (Nam, Fil, Lin);
599 -- If no file reference was found, the next line has already
600 -- been read because, it may sometimes be found on the next
607 Gmem_Read_BT_Frame (Line, Last);
609 Get_Line (FT, Line, Last);
610 exit when End_Of_File (FT);
616 return Enter_Root (Frames (1 .. F - 1));
623 function Root_Eq (N1, N2 : Root) return Boolean is
624 use type Frames_In_Root.Table_Type;
628 Frames_In_Root.Table (N1.First .. N1.Last)
629 = Frames_In_Root.Table (N2.First .. N2.Last);
636 procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is
638 Roots.Table (B).Alloc_Size := V;
641 -------------------------
642 -- Set_High_Water_Mark --
643 -------------------------
645 procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is
647 Roots.Table (B).High_Water_Mark := V;
648 end Set_High_Water_Mark;
654 procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is
656 Roots.Table (B).Nb_Alloc := V;
660 -- Initialize name for No_Name_ID
662 Names.Increment_Last;
663 Names.Table (Names.Last) := Name'(1, 0);