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-2003 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-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with GNAT.Table; 28with GNAT.HTable; use GNAT.HTable; 29with Ada.Text_IO; use Ada.Text_IO; 30with System.Storage_Elements; use System.Storage_Elements; 31 32package body Memroot is 33 34 Main_Name_Id : Name_Id; 35 -- The constant "main" where we should stop the backtraces 36 37 ------------- 38 -- Name_Id -- 39 ------------- 40 41 package Chars is new GNAT.Table ( 42 Table_Component_Type => Character, 43 Table_Index_Type => Integer, 44 Table_Low_Bound => 1, 45 Table_Initial => 10_000, 46 Table_Increment => 100); 47 -- The actual character container for names 48 49 type Name is record 50 First, Last : Integer; 51 end record; 52 53 package Names is new GNAT.Table ( 54 Table_Component_Type => Name, 55 Table_Index_Type => Name_Id, 56 Table_Low_Bound => 0, 57 Table_Initial => 400, 58 Table_Increment => 100); 59 60 type Name_Range is range 1 .. 1023; 61 62 function Name_Eq (N1, N2 : Name) return Boolean; 63 -- compare 2 names 64 65 function H (N : Name) return Name_Range; 66 67 package Name_HTable is new GNAT.HTable.Simple_HTable ( 68 Header_Num => Name_Range, 69 Element => Name_Id, 70 No_Element => No_Name_Id, 71 Key => Name, 72 Hash => H, 73 Equal => Name_Eq); 74 75 -------------- 76 -- Frame_Id -- 77 -------------- 78 79 type Frame is record 80 Name, File, Line : Name_Id; 81 end record; 82 83 function Image 84 (F : Frame_Id; 85 Max_Fil : Integer; 86 Max_Lin : Integer; 87 Short : Boolean := False) return String; 88 -- Returns an image for F containing the file name, the Line number, 89 -- and if 'Short' is not true, the subprogram name. When possible, spaces 90 -- are inserted between the line number and the subprogram name in order 91 -- to align images of the same frame. Alignement is cimputed with Max_Fil 92 -- & Max_Lin representing the max number of character in a filename or 93 -- length in a given frame. 94 95 package Frames is new GNAT.Table ( 96 Table_Component_Type => Frame, 97 Table_Index_Type => Frame_Id, 98 Table_Low_Bound => 1, 99 Table_Initial => 400, 100 Table_Increment => 100); 101 102 type Frame_Range is range 1 .. 10000; 103 function H (N : Integer_Address) return Frame_Range; 104 105 package Frame_HTable is new GNAT.HTable.Simple_HTable ( 106 Header_Num => Frame_Range, 107 Element => Frame_Id, 108 No_Element => No_Frame_Id, 109 Key => Integer_Address, 110 Hash => H, 111 Equal => "="); 112 113 ------------- 114 -- Root_Id -- 115 ------------- 116 117 type Root is record 118 First, Last : Integer; 119 Nb_Alloc : Integer; 120 Alloc_Size : Storage_Count; 121 High_Water_Mark : Storage_Count; 122 end record; 123 124 package Frames_In_Root is new GNAT.Table ( 125 Table_Component_Type => Frame_Id, 126 Table_Index_Type => Integer, 127 Table_Low_Bound => 1, 128 Table_Initial => 400, 129 Table_Increment => 100); 130 131 package Roots is new GNAT.Table ( 132 Table_Component_Type => Root, 133 Table_Index_Type => Root_Id, 134 Table_Low_Bound => 1, 135 Table_Initial => 200, 136 Table_Increment => 100); 137 type Root_Range is range 1 .. 513; 138 139 function Root_Eq (N1, N2 : Root) return Boolean; 140 function H (B : Root) return Root_Range; 141 142 package Root_HTable is new GNAT.HTable.Simple_HTable ( 143 Header_Num => Root_Range, 144 Element => Root_Id, 145 No_Element => No_Root_Id, 146 Key => Root, 147 Hash => H, 148 Equal => Root_Eq); 149 150 ---------------- 151 -- Alloc_Size -- 152 ---------------- 153 154 function Alloc_Size (B : Root_Id) return Storage_Count is 155 begin 156 return Roots.Table (B).Alloc_Size; 157 end Alloc_Size; 158 159 ----------------- 160 -- Enter_Frame -- 161 ----------------- 162 163 function Enter_Frame 164 (Addr : System.Address; 165 Name : Name_Id; 166 File : Name_Id; 167 Line : Name_Id) 168 return Frame_Id 169 is 170 begin 171 Frames.Increment_Last; 172 Frames.Table (Frames.Last) := Frame'(Name, File, Line); 173 174 Frame_HTable.Set (To_Integer (Addr), Frames.Last); 175 return Frames.Last; 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 : Integer_Address) return Frame_Range is 291 begin 292 return Frame_Range (1 + N 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 Short : Boolean := False) return String 320 is 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 Result : constant String := 334 String (Chars.Table (Fil.First .. Fil.Last)) 335 & ':' 336 & String (Chars.Table (Lin.First .. Lin.Last)); 337 begin 338 if Short then 339 return Result; 340 else 341 return Result 342 & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len) 343 & String (Chars.Table (Nam.First .. Nam.Last)); 344 end if; 345 end Image; 346 347 ------------- 348 -- Name_Eq -- 349 ------------- 350 351 function Name_Eq (N1, N2 : Name) return Boolean is 352 use type Chars.Table_Type; 353 begin 354 return 355 Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last); 356 end Name_Eq; 357 358 -------------- 359 -- Nb_Alloc -- 360 -------------- 361 362 function Nb_Alloc (B : Root_Id) return Integer is 363 begin 364 return Roots.Table (B).Nb_Alloc; 365 end Nb_Alloc; 366 367 -------------- 368 -- Print_BT -- 369 -------------- 370 371 procedure Print_BT (B : Root_Id; Short : Boolean := False) is 372 Max_Col_Width : constant := 35; 373 -- Largest filename length for which backtraces will be 374 -- properly aligned. Frames containing longer names won't be 375 -- truncated but they won't be properly aligned either. 376 377 F : constant Frame_Array := Frames_Of (B); 378 379 Max_Fil : Integer; 380 Max_Lin : Integer; 381 382 begin 383 Max_Fil := 0; 384 Max_Lin := 0; 385 386 for J in F'Range loop 387 declare 388 Fram : Frame renames Frames.Table (F (J)); 389 Fil : Name renames Names.Table (Fram.File); 390 Lin : Name renames Names.Table (Fram.Line); 391 392 begin 393 Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1); 394 Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1); 395 end; 396 end loop; 397 398 Max_Fil := Integer'Min (Max_Fil, Max_Col_Width); 399 400 for J in F'Range loop 401 Put (" "); 402 Put_Line (Image (F (J), Max_Fil, Max_Lin, Short)); 403 end loop; 404 end Print_BT; 405 406 ------------- 407 -- Read_BT -- 408 ------------- 409 410 function Read_BT (BT_Depth : Integer) return Root_Id is 411 Max_Line : constant Integer := 500; 412 Curs1 : Integer; 413 Curs2 : Integer; 414 Line : String (1 .. Max_Line); 415 Last : Integer := 0; 416 Frames : Frame_Array (1 .. BT_Depth); 417 F : Integer := Frames'First; 418 Nam : Name_Id; 419 Fil : Name_Id; 420 Lin : Name_Id; 421 Add : System.Address; 422 Int_Add : Integer_Address; 423 Fr : Frame_Id; 424 Main_Found : Boolean := False; 425 pragma Warnings (Off, Line); 426 427 procedure Find_File; 428 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains 429 -- the file name. The file name may not be on the current line since 430 -- a frame may be printed on more than one line when there is a lot 431 -- of parameters or names are long, so this subprogram can read new 432 -- lines of input. 433 434 procedure Find_Line; 435 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains 436 -- the line number. 437 438 procedure Find_Name; 439 -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains 440 -- the subprogram name. 441 442 function Skip_To_Space (Pos : Integer) return Integer; 443 -- Scans Line starting with position Pos, returning the position 444 -- immediately before the first space, or the value of Last if no 445 -- spaces were found 446 447 448 pragma Inline (Find_File, Find_Line, Find_Name, Skip_To_Space); 449 450 --------------- 451 -- Find_File -- 452 --------------- 453 454 procedure Find_File is 455 begin 456 -- Skip " at " 457 458 Curs1 := Curs2 + 5; 459 Curs2 := Last; 460 461 -- Scan backwards from end of line until ':' is encountered 462 463 for J in reverse Curs1 .. Last loop 464 if Line (J) = ':' then 465 Curs2 := J - 1; 466 end if; 467 end loop; 468 end Find_File; 469 470 --------------- 471 -- Find_Line -- 472 --------------- 473 474 procedure Find_Line is 475 begin 476 Curs1 := Curs2 + 2; 477 Curs2 := Last; 478 479 -- Check for Curs1 too large. Should never happen with non-corrupt 480 -- output. If it does happen, just reset it to the highest value. 481 482 if Curs1 > Last then 483 Curs1 := Last; 484 end if; 485 end Find_Line; 486 487 --------------- 488 -- Find_Name -- 489 --------------- 490 491 procedure Find_Name is 492 begin 493 -- Skip the address value and " in " 494 495 Curs1 := Skip_To_Space (1) + 5; 496 Curs2 := Skip_To_Space (Curs1); 497 end Find_Name; 498 499 ------------------- 500 -- Skip_To_Space -- 501 ------------------- 502 503 function Skip_To_Space (Pos : Integer) return Integer is 504 begin 505 for Cur in Pos .. Last loop 506 if Line (Cur) = ' ' then 507 return Cur - 1; 508 end if; 509 end loop; 510 511 return Last; 512 end Skip_To_Space; 513 514 procedure Gmem_Read_Next_Frame (Addr : out System.Address); 515 pragma Import (C, Gmem_Read_Next_Frame, "__gnat_gmem_read_next_frame"); 516 -- Read the next frame in the current traceback. Addr is set to 0 if 517 -- there are no more addresses in this traceback. The pointer is moved 518 -- to the next frame. 519 520 procedure Gmem_Symbolic 521 (Addr : System.Address; Buf : String; Last : out Natural); 522 pragma Import (C, Gmem_Symbolic, "__gnat_gmem_symbolic"); 523 -- Get the symbolic traceback for Addr. Note: we cannot use 524 -- GNAT.Tracebacks.Symbolic, since the latter will only work with the 525 -- current executable. 526 -- 527 -- "__gnat_gmem_symbolic" will work with the executable whose name is 528 -- given in gnat_argv[0], as initialized by Gnatmem.Gmem_A21_Initialize. 529 530 -- Start of processing for Read_BT 531 532 begin 533 while F <= BT_Depth and then not Main_Found loop 534 Gmem_Read_Next_Frame (Add); 535 Int_Add := To_Integer (Add); 536 exit when Int_Add = 0; 537 538 Fr := Frame_HTable.Get (Int_Add); 539 540 if Fr = No_Frame_Id then 541 Gmem_Symbolic (Add, Line, Last); 542 Last := Last - 1; -- get rid of the trailing line-feed 543 Find_Name; 544 545 -- Skip the __gnat_malloc frame itself 546 547 if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then 548 Nam := Enter_Name (Line (Curs1 .. Curs2)); 549 Main_Found := (Nam = Main_Name_Id); 550 551 Find_File; 552 Fil := Enter_Name (Line (Curs1 .. Curs2)); 553 Find_Line; 554 Lin := Enter_Name (Line (Curs1 .. Curs2)); 555 556 Frames (F) := Enter_Frame (Add, Nam, Fil, Lin); 557 F := F + 1; 558 end if; 559 560 else 561 Frames (F) := Fr; 562 Main_Found := (Memroot.Frames.Table (Fr).Name = Main_Name_Id); 563 F := F + 1; 564 end if; 565 end loop; 566 567 return Enter_Root (Frames (1 .. F - 1)); 568 end Read_BT; 569 570 ------------- 571 -- Root_Eq -- 572 ------------- 573 574 function Root_Eq (N1, N2 : Root) return Boolean is 575 use type Frames_In_Root.Table_Type; 576 577 begin 578 return 579 Frames_In_Root.Table (N1.First .. N1.Last) 580 = Frames_In_Root.Table (N2.First .. N2.Last); 581 end Root_Eq; 582 583 -------------------- 584 -- Set_Alloc_Size -- 585 -------------------- 586 587 procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is 588 begin 589 Roots.Table (B).Alloc_Size := V; 590 end Set_Alloc_Size; 591 592 ------------------------- 593 -- Set_High_Water_Mark -- 594 ------------------------- 595 596 procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is 597 begin 598 Roots.Table (B).High_Water_Mark := V; 599 end Set_High_Water_Mark; 600 601 ------------------ 602 -- Set_Nb_Alloc -- 603 ------------------ 604 605 procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is 606 begin 607 Roots.Table (B).Nb_Alloc := V; 608 end Set_Nb_Alloc; 609 610begin 611 -- Initialize name for No_Name_ID 612 613 Names.Increment_Last; 614 Names.Table (Names.Last) := Name'(1, 0); 615 Main_Name_Id := Enter_Name ("main"); 616end Memroot; 617