1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . T R A C E B A C K -- 6-- (HP/UX Version) -- 7-- -- 8-- B o d y -- 9-- -- 10-- Copyright (C) 1999-2003 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-- As a special exception, if other files instantiate generics from this -- 24-- unit, or you link this unit with other files to produce an executable, -- 25-- this unit does not by itself cause the resulting executable to be -- 26-- covered by the GNU General Public License. This exception does not -- 27-- however invalidate any other reasons why the executable file might be -- 28-- covered by the GNU Public License. -- 29-- -- 30-- GNAT was originally developed by the GNAT team at New York University. -- 31-- Extensive contributions were provided by Ada Core Technologies Inc. -- 32-- -- 33------------------------------------------------------------------------------ 34 35with Ada.Unchecked_Conversion; 36 37package body System.Traceback is 38 39 -- This package implements the backtracing facility by way of a dedicated 40 -- HP library for stack unwinding described in the "Runtime Architecture 41 -- Document". 42 43 pragma Linker_Options ("/usr/lib/libcl.a"); 44 45 -- The library basically offers services to fetch information about a 46 -- "previous" frame based on information about a "current" one. 47 48 type Current_Frame_Descriptor is record 49 cur_fsz : Address; -- Frame size of current routine. 50 cur_sp : Address; -- The current value of stack pointer. 51 cur_rls : Address; -- PC-space of the caller. 52 cur_rlo : Address; -- PC-offset of the caller. 53 cur_dp : Address; -- Data Pointer of the current routine. 54 top_rp : Address; -- Initial value of RP. 55 top_mrp : Address; -- Initial value of MRP. 56 top_sr0 : Address; -- Initial value of sr0. 57 top_sr4 : Address; -- Initial value of sr4. 58 top_r3 : Address; -- Initial value of gr3. 59 cur_r19 : Address; -- GR19 value of the calling routine. 60 top_r4 : Address; -- Initial value of gr4. 61 dummy : Address; -- Reserved. 62 out_rlo : Address; -- PC-offset of the caller after get_previous. 63 end record; 64 65 type Previous_Frame_Descriptor is record 66 prev_fsz : Address; -- frame size of calling routine. 67 prev_sp : Address; -- SP of calling routine. 68 prev_rls : Address; -- PC_space of calling routine's caller. 69 prev_rlo : Address; -- PC_offset of calling routine's caller. 70 prev_dp : Address; -- DP of calling routine. 71 udescr0 : Address; -- low word of calling routine's unwind desc. 72 udescr1 : Address; -- high word of calling routine's unwind desc. 73 ustart : Address; -- start of the unwind region. 74 uend : Address; -- end of the unwind region. 75 uw_index : Address; -- index into the unwind table. 76 prev_r19 : Address; -- GR19 value of the caller's caller. 77 top_r3 : Address; -- Caller's initial gr3. 78 top_r4 : Address; -- Caller's initial gr4. 79 end record; 80 81 -- Provide useful shortcuts for the names 82 83 subtype CFD is Current_Frame_Descriptor; 84 subtype PFD is Previous_Frame_Descriptor; 85 86 -- Frames with dynamic stack allocation are handled using the associated 87 -- frame pointer, but HP compilers and GCC setup this pointer differently. 88 -- HP compilers set it to point at the top (highest address) of the static 89 -- part of the frame, wheras GCC sets it to point at the bottom of this 90 -- region. We have to fake the unwinder to compensate for this difference, 91 -- for which we'll need to access some subprograms unwind descriptors. 92 93 type Bits_2_Value is mod 2 ** 2; 94 for Bits_2_Value'Size use 2; 95 96 type Bits_4_Value is mod 2 ** 4; 97 for Bits_4_Value'Size use 4; 98 99 type Bits_5_Value is mod 2 ** 5; 100 for Bits_5_Value'Size use 5; 101 102 type Bits_27_Value is mod 2 ** 27; 103 for Bits_27_Value'Size use 27; 104 105 type Unwind_Descriptor is record 106 cannot_unwind : Boolean; 107 mcode : Boolean; 108 mcode_save_restore : Boolean; 109 region_desc : Bits_2_Value; 110 reserved0 : Boolean; 111 entry_sr : Boolean; 112 entry_fr : Bits_4_Value; 113 entry_gr : Bits_5_Value; 114 115 args_stored : Boolean; 116 variable_frame : Boolean; 117 separate_package_body : Boolean; 118 frame_extension_mcode : Boolean; 119 120 stack_overflow_check : Boolean; 121 two_steps_sp_adjust : Boolean; 122 sr4_export : Boolean; 123 cxx_info : Boolean; 124 125 cxx_try_catch : Boolean; 126 sched_entry_seq : Boolean; 127 reserved1 : Boolean; 128 save_sp : Boolean; 129 130 save_rp : Boolean; 131 save_mrp : Boolean; 132 save_r19 : Boolean; 133 cleanups : Boolean; 134 135 hpe_interrupt_marker : Boolean; 136 hpux_interrupt_marker : Boolean; 137 large_frame : Boolean; 138 alloca_frame : Boolean; 139 140 reserved2 : Boolean; 141 frame_size : Bits_27_Value; 142 end record; 143 144 for Unwind_Descriptor'Size use 64; 145 146 for Unwind_Descriptor use record 147 cannot_unwind at 0 range 0 .. 0; 148 mcode at 0 range 1 .. 1; 149 mcode_save_restore at 0 range 2 .. 2; 150 region_desc at 0 range 3 .. 4; 151 reserved0 at 0 range 5 .. 5; 152 entry_sr at 0 range 6 .. 6; 153 entry_fr at 0 range 7 .. 10; 154 155 entry_gr at 1 range 3 .. 7; 156 157 args_stored at 2 range 0 .. 0; 158 variable_frame at 2 range 1 .. 1; 159 separate_package_body at 2 range 2 .. 2; 160 frame_extension_mcode at 2 range 3 .. 3; 161 stack_overflow_check at 2 range 4 .. 4; 162 two_steps_sp_adjust at 2 range 5 .. 5; 163 sr4_export at 2 range 6 .. 6; 164 cxx_info at 2 range 7 .. 7; 165 166 cxx_try_catch at 3 range 0 .. 0; 167 sched_entry_seq at 3 range 1 .. 1; 168 reserved1 at 3 range 2 .. 2; 169 save_sp at 3 range 3 .. 3; 170 save_rp at 3 range 4 .. 4; 171 save_mrp at 3 range 5 .. 5; 172 save_r19 at 3 range 6 .. 6; 173 cleanups at 3 range 7 .. 7; 174 175 hpe_interrupt_marker at 4 range 0 .. 0; 176 hpux_interrupt_marker at 4 range 1 .. 1; 177 large_frame at 4 range 2 .. 2; 178 alloca_frame at 4 range 3 .. 3; 179 180 reserved2 at 4 range 4 .. 4; 181 frame_size at 4 range 5 .. 31; 182 end record; 183 184 subtype UWD is Unwind_Descriptor; 185 type UWD_Ptr is access all UWD; 186 187 function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr); 188 189 -- The descriptor associated with a given code location is retrieved 190 -- using functions imported from the HP library, requiring the definition 191 -- of additional structures. 192 193 type Unwind_Table_Region is record 194 Table_Start : Address; 195 Table_End : Address; 196 end record; 197 -- An Unwind Table region, which is a memory area containing Unwind 198 -- Descriptors. 199 200 subtype UWT is Unwind_Table_Region; 201 202 -- The subprograms imported below are provided by the HP library 203 204 function U_get_unwind_table return UWT; 205 pragma Import (C, U_get_unwind_table, "U_get_unwind_table"); 206 -- Get the unwind table region associated with the current executable. 207 -- This function is actually documented as having an argument, but which 208 -- is only used for the MPE/iX targets. 209 210 function U_get_shLib_unwind_table (r19 : Address) return UWT; 211 pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl"); 212 -- Return the unwind table region associated with a possible shared 213 -- library, as determined by the provided r19 value. 214 215 function U_get_shLib_text_addr (r19 : Address) return Address; 216 pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr"); 217 -- Return the address at which the code for a shared library begins, or 218 -- -1 if the value provided for r19 does not identify shared library code. 219 220 function U_get_unwind_entry 221 (Pc : Address; 222 Space : Address; 223 Table_Start : Address; 224 Table_End : Address) return Address; 225 pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); 226 -- Given the bounds of an unwind table, return the address of the 227 -- unwind descriptor associated with a code location/space. In the case 228 -- of shared library code, the offset from the beginning of the library 229 -- is expected as Pc. 230 231 procedure U_init_frame_record (Frame : access CFD); 232 pragma Import (C, U_init_frame_record, "U_init_frame_record"); 233 234 procedure U_prep_frame_rec_for_unwind (Frame : access CFD); 235 pragma Import (C, U_prep_frame_rec_for_unwind, 236 "U_prep_frame_rec_for_unwind"); 237 238 -- Fetch the description data of the frame in which these two procedures 239 -- are called. 240 241 function U_get_u_rlo (Cur : access CFD; Prev : access PFD) return Integer; 242 pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX"); 243 -- From a complete current frame with a return location possibly located 244 -- into a linker generated stub, and basic information about the previous 245 -- frame, place the first non stub return location into the current frame. 246 -- Return -1 if something went wrong during the computation. 247 248 function U_is_shared_pc (rlo : Address; r19 : Address) return Address; 249 pragma Import (C, U_is_shared_pc, "U_is_shared_pc"); 250 -- Return 0 if the provided return location does not correspond to code 251 -- in a shared library, or something non null otherwise. 252 253 function U_get_previous_frame_x 254 (current_frame : access CFD; 255 previous_frame : access PFD; 256 previous_size : Integer) return Integer; 257 pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); 258 -- Fetch the data describing the "previous" frame relatively to the 259 -- "current" one. "previous_size" should be the size of the "previous" 260 -- frame descriptor provided. 261 -- 262 -- The library provides a simpler interface without the size parameter 263 -- but it is not usable when frames with dynamically allocated space are 264 -- on the way. 265 266 ------------------ 267 -- C_Call_Chain -- 268 ------------------ 269 270 function C_Call_Chain 271 (Traceback : System.Address; 272 Max_Len : Natural) return Natural 273 is 274 Val : Natural; 275 276 begin 277 Call_Chain (Traceback, Max_Len, Val); 278 return Val; 279 end C_Call_Chain; 280 281 ---------------- 282 -- Call_Chain -- 283 ---------------- 284 285 procedure Call_Chain 286 (Traceback : System.Address; 287 Max_Len : Natural; 288 Len : out Natural; 289 Exclude_Min : System.Address := System.Null_Address; 290 Exclude_Max : System.Address := System.Null_Address; 291 Skip_Frames : Natural := 1) 292 is 293 type Tracebacks_Array is array (1 .. Max_Len) of System.Address; 294 pragma Suppress_Initialization (Tracebacks_Array); 295 296 -- The code location returned by the unwinder is a return location but 297 -- what we need is a call point. Under HP-UX call instructions are 4 298 -- bytes long and the return point they specify is 4 bytes beyond the 299 -- next instruction because of the delay slot. 300 301 Call_Size : constant := 4; 302 DSlot_Size : constant := 4; 303 Rlo_Offset : constant := Call_Size + DSlot_Size; 304 305 -- Moreover, the return point is passed via a register which two least 306 -- significant bits specify a privilege level that we will have to mask. 307 308 Priv_Mask : constant := 16#00000003#; 309 310 Frame : aliased CFD; 311 Code : System.Address; 312 J : Natural := 1; 313 Pop_Success : Boolean; 314 Trace : Tracebacks_Array; 315 for Trace'Address use Traceback; 316 317 -- The backtracing process needs a set of subprograms : 318 319 function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr; 320 -- Return an access to the unwind descriptor for the caller of 321 -- a given frame, using only the provided return location. 322 323 function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr; 324 -- Return an access to the unwind descriptor for the user code caller 325 -- of a given frame, or null if the information is not available. 326 327 function Pop_Frame (Frame : access CFD) return Boolean; 328 -- Update the provided machine state structure so that it reflects 329 -- the state one call frame "above" the initial one. 330 -- 331 -- Return True if the operation has been successful, False otherwise. 332 -- Failure typically occurs when the top of the call stack has been 333 -- reached. 334 335 function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean; 336 -- Perform the necessary adaptations to the machine state before 337 -- calling the unwinder. Currently used for the specific case of 338 -- dynamically sized previous frames. 339 -- 340 -- Return True if everything went fine, or False otherwise. 341 342 Program_UWT : constant UWT := U_get_unwind_table; 343 344 --------------- 345 -- Pop_Frame -- 346 --------------- 347 348 function Pop_Frame (Frame : access CFD) return Boolean is 349 Up_Frame : aliased PFD; 350 State_Ready : Boolean; 351 352 begin 353 -- Check/adapt the state before calling the unwinder and return 354 -- if anything went wrong. 355 356 State_Ready := Prepare_For_Unwind_Of (Frame); 357 358 if not State_Ready then 359 return False; 360 end if; 361 362 -- Now, safely call the unwinder and use the results. 363 364 if U_get_previous_frame_x (Frame, 365 Up_Frame'Access, 366 Up_Frame'Size) /= 0 367 then 368 return False; 369 end if; 370 371 -- In case a stub is on the way, the usual previous return location 372 -- (the one in prev_rlo) is the one in the stub and the "real" one 373 -- is placed in the "current" record, so let's take this one into 374 -- account. 375 376 Frame.out_rlo := Frame.cur_rlo; 377 378 Frame.cur_fsz := Up_Frame.prev_fsz; 379 Frame.cur_sp := Up_Frame.prev_sp; 380 Frame.cur_rls := Up_Frame.prev_rls; 381 Frame.cur_rlo := Up_Frame.prev_rlo; 382 Frame.cur_dp := Up_Frame.prev_dp; 383 Frame.cur_r19 := Up_Frame.prev_r19; 384 Frame.top_r3 := Up_Frame.top_r3; 385 Frame.top_r4 := Up_Frame.top_r4; 386 387 return True; 388 end Pop_Frame; 389 390 --------------------------------- 391 -- Prepare_State_For_Unwind_Of -- 392 --------------------------------- 393 394 function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean 395 is 396 Caller_UWD : UWD_Ptr; 397 FP_Adjustment : Integer; 398 399 begin 400 -- No need to bother doing anything if the stack is already fully 401 -- unwound. 402 403 if Frame.cur_rlo = 0 then 404 return False; 405 end if; 406 407 -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder 408 -- uses the value provided in current.top_r3 or current.top_r4 as 409 -- a frame pointer to compute the size of the frame. What decides 410 -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with 411 -- r4 chosen if the bit is set. 412 413 -- The size computed by the unwinder is STATIC_PART + (SP - FP), 414 -- which is correct with HP's frame pointer convention, but not 415 -- with GCC's one since we end up with the static part accounted 416 -- for twice. 417 418 -- We have to compute r4 when it is required because the unwinder 419 -- has looked for it at a place where it was not if we went through 420 -- GCC frames. 421 422 -- The size of the static part of a frame can be found in the 423 -- associated unwind descriptor. 424 425 Caller_UWD := UWD_For_Caller_Of (Frame); 426 427 -- If we cannot get it, we are unable to compute the potentially 428 -- necessary adjustments. We'd better not try to go on then. 429 430 if Caller_UWD = null then 431 return False; 432 end if; 433 434 -- If the caller frame is a GCC one, r3 is its frame pointer and 435 -- points to the bottom of the frame. The value to provide for r4 436 -- can then be computed directly from the one of r3, compensating 437 -- for the static part of the frame. 438 439 -- If the caller frame is an HP one, r3 is used to locate the 440 -- previous frame marker, that is it also points to the bottom of 441 -- the frame (this is why r3 cannot be used as the frame pointer in 442 -- the HP sense for large frames). The value to provide for r4 can 443 -- then also be computed from the one of r3 with the compensation 444 -- for the static part of the frame. 445 446 FP_Adjustment := Integer (Caller_UWD.frame_size * 8); 447 Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment); 448 449 return True; 450 end Prepare_For_Unwind_Of; 451 452 ----------------------- 453 -- UWD_For_Caller_Of -- 454 ----------------------- 455 456 function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr 457 is 458 UWD_Access : UWD_Ptr; 459 460 begin 461 -- First try the most direct path, using the return location data 462 -- associated with the frame. 463 464 UWD_Access := UWD_For_RLO_Of (Frame); 465 466 if UWD_Access /= null then 467 return UWD_Access; 468 end if; 469 470 -- If we did not get a result, we might face an in-stub return 471 -- address. In this case U_get_previous_frame can tell us what the 472 -- first not-in-stub return point is. We cannot call it directly, 473 -- though, because we haven't computed the potentially necessary 474 -- frame pointer adjustments, which might lead to SEGV in some 475 -- circumstances. Instead, we directly call the libcl routine which 476 -- is called by U_get_previous_frame and which only requires few 477 -- information. Take care, however, that the information is provided 478 -- in the "current" argument, so we need to work on a copy to avoid 479 -- disturbing our caller. 480 481 declare 482 U_Current : aliased CFD := Frame.all; 483 U_Previous : aliased PFD; 484 485 begin 486 U_Previous.prev_dp := U_Current.cur_dp; 487 U_Previous.prev_rls := U_Current.cur_rls; 488 U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz; 489 490 if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then 491 UWD_Access := UWD_For_RLO_Of (U_Current'Access); 492 end if; 493 end; 494 495 return UWD_Access; 496 end UWD_For_Caller_Of; 497 498 -------------------- 499 -- UWD_For_RLO_Of -- 500 -------------------- 501 502 function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr 503 is 504 UWD_Address : Address; 505 506 -- The addresses returned by the library point to full descriptors 507 -- including the frame information bits but also the applicable PC 508 -- range. We need to account for this. 509 510 Frame_Info_Offset : constant := 8; 511 512 begin 513 -- First try to locate the descriptor in the program's unwind table. 514 515 UWD_Address := U_get_unwind_entry (Frame.cur_rlo, 516 Frame.cur_rls, 517 Program_UWT.Table_Start, 518 Program_UWT.Table_End); 519 520 -- If we did not get it, we might have a frame from code in a 521 -- stub or shared library. For code in stub we would have to 522 -- compute the first non-stub return location but this is not 523 -- the role of this subprogram, so let's just try to see if we 524 -- can get a result from the tables in shared libraries. 525 526 if UWD_Address = -1 527 and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 528 then 529 declare 530 Shlib_UWT : constant UWT := 531 U_get_shLib_unwind_table (Frame.cur_r19); 532 Shlib_Start : constant Address := 533 U_get_shLib_text_addr (Frame.cur_r19); 534 Rlo_Offset : constant Address := 535 Frame.cur_rlo - Shlib_Start; 536 begin 537 UWD_Address := U_get_unwind_entry (Rlo_Offset, 538 Frame.cur_rls, 539 Shlib_UWT.Table_Start, 540 Shlib_UWT.Table_End); 541 end; 542 end if; 543 544 if UWD_Address /= -1 then 545 return To_UWD_Access (UWD_Address + Frame_Info_Offset); 546 else 547 return null; 548 end if; 549 end UWD_For_RLO_Of; 550 551 -- Start of processing for Call_Chain 552 553 begin 554 -- Fetch the state for this subprogram's frame and pop it so that we 555 -- start with an initial out_rlo "here". 556 557 U_init_frame_record (Frame'Access); 558 Frame.top_sr0 := 0; 559 Frame.top_sr4 := 0; 560 561 U_prep_frame_rec_for_unwind (Frame'Access); 562 563 Pop_Success := Pop_Frame (Frame'Access); 564 565 -- Skip the requested number of frames. 566 567 for I in 1 .. Skip_Frames loop 568 Pop_Success := Pop_Frame (Frame'Access); 569 end loop; 570 571 -- Loop popping frames and storing locations until either a problem 572 -- occurs, or the top of the call chain is reached, or the provided 573 -- array is full. 574 575 loop 576 -- We have to test some conditions against the return location 577 -- as it is returned, so get it as is first. 578 579 Code := Frame.out_rlo; 580 581 exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1; 582 583 -- Compute the call point from the retrieved return location : 584 -- Mask the privilege bits and account for the delta between the 585 -- call site and the return point. 586 587 Code := (Code and not Priv_Mask) - Rlo_Offset; 588 589 if Code < Exclude_Min or else Code > Exclude_Max then 590 Trace (J) := Code; 591 J := J + 1; 592 end if; 593 594 Pop_Success := Pop_Frame (Frame'Access); 595 end loop; 596 597 Len := J - 1; 598 end Call_Chain; 599 600end System.Traceback; 601