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