source: trunk/src/gcc/gcc/ada/5htraceb.adb@ 2

Last change on this file since 2 was 2, checked in by bird, 22 years ago

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