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-2019, 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
274   ------------------
275   -- C_Call_Chain --
276   ------------------
277
278   function C_Call_Chain
279     (Traceback : System.Address;
280      Max_Len   : Natural) return Natural
281   is
282      Val : Natural;
283   begin
284      Call_Chain (Traceback, Max_Len, Val);
285      return Val;
286   end C_Call_Chain;
287
288   ----------------
289   -- Call_Chain --
290   ----------------
291
292   procedure Call_Chain
293     (Traceback   : System.Address;
294      Max_Len     : Natural;
295      Len         : out Natural;
296      Exclude_Min : System.Address := System.Null_Address;
297      Exclude_Max : System.Address := System.Null_Address;
298      Skip_Frames : Natural := 1)
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 : not null 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 : not null 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 : not null 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
343        (Frame : not null access CFD) return Boolean;
344      --  Perform the necessary adaptations to the machine state before
345      --  calling the unwinder. Currently used for the specific case of
346      --  dynamically sized previous frames.
347      --
348      --  Return True if everything went fine, or False otherwise.
349
350      Program_UWT : constant UWT := U_get_unwind_table;
351
352      ---------------
353      -- Pop_Frame --
354      ---------------
355
356      function Pop_Frame (Frame : not null access CFD) return Boolean is
357         Up_Frame    : aliased PFD;
358         State_Ready : Boolean;
359
360      begin
361         --  Check/adapt the state before calling the unwinder and return
362         --  if anything went wrong.
363
364         State_Ready := Prepare_For_Unwind_Of (Frame);
365
366         if not State_Ready then
367            return False;
368         end if;
369
370         --  Now, safely call the unwinder and use the results
371
372         if U_get_previous_frame_x (Frame,
373                                    Up_Frame'Access,
374                                    Up_Frame'Size) /= 0
375         then
376            return False;
377         end if;
378
379         --  In case a stub is on the way, the usual previous return location
380         --  (the one in prev_rlo) is the one in the stub and the "real" one
381         --  is placed in the "current" record, so let's take this one into
382         --  account.
383
384         Frame.out_rlo := Frame.cur_rlo;
385
386         Frame.cur_fsz := Up_Frame.prev_fsz;
387         Frame.cur_sp  := Up_Frame.prev_sp;
388         Frame.cur_rls := Up_Frame.prev_rls;
389         Frame.cur_rlo := Up_Frame.prev_rlo;
390         Frame.cur_dp  := Up_Frame.prev_dp;
391         Frame.cur_r19 := Up_Frame.prev_r19;
392         Frame.top_r3  := Up_Frame.top_r3;
393         Frame.top_r4  := Up_Frame.top_r4;
394
395         return True;
396      end Pop_Frame;
397
398      ---------------------------
399      -- Prepare_For_Unwind_Of --
400      ---------------------------
401
402      function Prepare_For_Unwind_Of
403        (Frame : not null access CFD) return Boolean
404      is
405         Caller_UWD    : UWD_Ptr;
406         FP_Adjustment : Integer;
407
408      begin
409         --  No need to bother doing anything if the stack is already fully
410         --  unwound.
411
412         if Frame.cur_rlo = 0 then
413            return False;
414         end if;
415
416         --  When ALLOCA_FRAME is set in an unwind descriptor, the unwinder
417         --  uses the value provided in current.top_r3 or current.top_r4 as
418         --  a frame pointer to compute the size of the frame. What decides
419         --  between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with
420         --  r4 chosen if the bit is set.
421
422         --  The size computed by the unwinder is STATIC_PART + (SP - FP),
423         --  which is correct with HP's frame pointer convention, but not
424         --  with GCC's one since we end up with the static part accounted
425         --  for twice.
426
427         --  We have to compute r4 when it is required because the unwinder
428         --  has looked for it at a place where it was not if we went through
429         --  GCC frames.
430
431         --  The size of the static part of a frame can be found in the
432         --  associated unwind descriptor.
433
434         Caller_UWD := UWD_For_Caller_Of (Frame);
435
436         --  If we cannot get it, we are unable to compute the potentially
437         --  necessary adjustments. We'd better not try to go on then.
438
439         if Caller_UWD = null then
440            return False;
441         end if;
442
443         --  If the caller frame is a GCC one, r3 is its frame pointer and
444         --  points to the bottom of the frame. The value to provide for r4
445         --  can then be computed directly from the one of r3, compensating
446         --  for the static part of the frame.
447
448         --  If the caller frame is an HP one, r3 is used to locate the
449         --  previous frame marker, that is it also points to the bottom of
450         --  the frame (this is why r3 cannot be used as the frame pointer in
451         --  the HP sense for large frames). The value to provide for r4 can
452         --  then also be computed from the one of r3 with the compensation
453         --  for the static part of the frame.
454
455         FP_Adjustment := Integer (Caller_UWD.frame_size * 8);
456         Frame.top_r4  := Address (Integer (Frame.top_r3) + FP_Adjustment);
457
458         return True;
459      end Prepare_For_Unwind_Of;
460
461      -----------------------
462      -- UWD_For_Caller_Of --
463      -----------------------
464
465      function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr
466      is
467         UWD_Access : UWD_Ptr;
468
469      begin
470         --  First try the most direct path, using the return location data
471         --  associated with the frame.
472
473         UWD_Access := UWD_For_RLO_Of (Frame);
474
475         if UWD_Access /= null then
476            return UWD_Access;
477         end if;
478
479         --  If we did not get a result, we might face an in-stub return
480         --  address. In this case U_get_previous_frame can tell us what the
481         --  first not-in-stub return point is. We cannot call it directly,
482         --  though, because we haven't computed the potentially necessary
483         --  frame pointer adjustments, which might lead to SEGV in some
484         --  circumstances. Instead, we directly call the libcl routine which
485         --  is called by U_get_previous_frame and which only requires few
486         --  information. Take care, however, that the information is provided
487         --  in the "current" argument, so we need to work on a copy to avoid
488         --  disturbing our caller.
489
490         declare
491            U_Current  : aliased CFD := Frame.all;
492            U_Previous : aliased PFD;
493
494         begin
495            U_Previous.prev_dp  := U_Current.cur_dp;
496            U_Previous.prev_rls := U_Current.cur_rls;
497            U_Previous.prev_sp  := U_Current.cur_sp - U_Current.cur_fsz;
498
499            if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then
500               UWD_Access := UWD_For_RLO_Of (U_Current'Access);
501            end if;
502         end;
503
504         return UWD_Access;
505      end UWD_For_Caller_Of;
506
507      --------------------
508      -- UWD_For_RLO_Of --
509      --------------------
510
511      function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr
512      is
513         UWD_Address : Address;
514
515         --  The addresses returned by the library point to full descriptors
516         --  including the frame information bits but also the applicable PC
517         --  range. We need to account for this.
518
519         Frame_Info_Offset  : constant := 8;
520
521      begin
522         --  First try to locate the descriptor in the program's unwind table
523
524         UWD_Address := U_get_unwind_entry (Frame.cur_rlo,
525                                            Frame.cur_rls,
526                                            Program_UWT.Table_Start,
527                                            Program_UWT.Table_End);
528
529         --  If we did not get it, we might have a frame from code in a
530         --  stub or shared library. For code in stub we would have to
531         --  compute the first non-stub return location but this is not
532         --  the role of this subprogram, so let's just try to see if we
533         --  can get a result from the tables in shared libraries.
534
535         if UWD_Address = -1
536           and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
537         then
538            declare
539               Shlib_UWT   : constant UWT     :=
540                               U_get_shLib_unwind_table (Frame.cur_r19);
541               Shlib_Start : constant Address :=
542                               U_get_shLib_text_addr (Frame.cur_r19);
543               Rlo_Offset  : constant Address :=
544                               Frame.cur_rlo - Shlib_Start;
545            begin
546               UWD_Address := U_get_unwind_entry (Rlo_Offset,
547                                                  Frame.cur_rls,
548                                                  Shlib_UWT.Table_Start,
549                                                  Shlib_UWT.Table_End);
550            end;
551         end if;
552
553         if UWD_Address /= -1 then
554            return To_UWD_Access (UWD_Address + Frame_Info_Offset);
555         else
556            return null;
557         end if;
558      end UWD_For_RLO_Of;
559
560   --  Start of processing for Call_Chain
561
562   begin
563      --  Fetch the state for this subprogram's frame and pop it so that we
564      --  start with an initial out_rlo "here".
565
566      U_init_frame_record (Frame'Access);
567      Frame.top_sr0 := 0;
568      Frame.top_sr4 := 0;
569
570      U_prep_frame_rec_for_unwind (Frame'Access);
571
572      Pop_Success := Pop_Frame (Frame'Access);
573
574      --  Skip the requested number of frames
575
576      for I in 1 .. Skip_Frames loop
577         Pop_Success := Pop_Frame (Frame'Access);
578      end loop;
579
580      --  Loop popping frames and storing locations until either a problem
581      --  occurs, or the top of the call chain is reached, or the provided
582      --  array is full.
583
584      loop
585         --  We have to test some conditions against the return location
586         --  as it is returned, so get it as is first.
587
588         Code := Frame.out_rlo;
589
590         exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1;
591
592         --  Compute the call point from the retrieved return location :
593         --  Mask the privilege bits and account for the delta between the
594         --  call site and the return point.
595
596         Code := (Code and not Priv_Mask) - Rlo_Offset;
597
598         if Code < Exclude_Min or else Code > Exclude_Max then
599            Trace (J) := Code;
600            J := J + 1;
601         end if;
602
603         Pop_Success := Pop_Frame (Frame'Access);
604      end loop;
605
606      Len := J - 1;
607   end Call_Chain;
608
609   procedure Call_Chain
610     (Traceback   : in out System.Traceback_Entries.Tracebacks_Array;
611      Max_Len     : Natural;
612      Len         : out Natural;
613      Exclude_Min : System.Address := System.Null_Address;
614      Exclude_Max : System.Address := System.Null_Address;
615      Skip_Frames : Natural := 1)
616   is
617   begin
618      Call_Chain
619        (Traceback'Address, Max_Len, Len,
620         Exclude_Min, Exclude_Max,
621
622         --  Skip one extra frame to skip the other Call_Chain entry as well
623
624         Skip_Frames => Skip_Frames + 1);
625   end Call_Chain;
626
627end System.Traceback;
628