gcc/ada/libgnat/s-stausa.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --                   S Y S T E M - S T A C K _ U S A G E                    --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --         Copyright (C) 2004-2019, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with System.Parameters;
  33 with System.CRTL;
  34 with System.IO;
  35
  36 package body System.Stack_Usage is
  37    use System.Storage_Elements;
  38    use System.IO;
  39    use Interfaces;
  40
  41    -----------------
  42    -- Stack_Slots --
  43    -----------------
  44
  45    --  Stack_Slots is an internal data type to represent a sequence of real
  46    --  stack slots initialized with a provided pattern, with operations to
  47    --  abstract away the target call stack growth direction.
  48
  49    type Stack_Slots is array (Integer range <>) of Pattern_Type;
  50    for Stack_Slots'Component_Size use Pattern_Type'Object_Size;
  51
  52    --  We will carefully handle the initializations ourselves and might want
  53    --  to remap an initialized overlay later on with an address clause.
  54
  55    pragma Suppress_Initialization (Stack_Slots);
  56
  57    --  The abstract Stack_Slots operations all operate over the simple array
  58    --  memory model:
  59
  60    --  memory addresses increasing ---->
  61
  62    --  Slots('First)                                           Slots('Last)
  63    --    |                                                             |
  64    --    V                                                             V
  65    --  +------------------------------------------------------------------+
  66    --  |####|                                                        |####|
  67    --  +------------------------------------------------------------------+
  68
  69    --  What we call Top or Bottom always denotes call chain leaves or entry
  70    --  points respectively, and their relative positions in the stack array
  71    --  depends on the target stack growth direction:
  72
  73    --                           Stack_Grows_Down
  74
  75    --                <----- calls push frames towards decreasing addresses
  76
  77    --   Top(most) Slot                                   Bottom(most) Slot
  78    --    |                                                            |
  79    --    V                                                            V
  80    --  +------------------------------------------------------------------+
  81    --  |####|                            | leaf frame | ... | entry frame |
  82    --  +------------------------------------------------------------------+
  83
  84    --                           Stack_Grows_Up
  85
  86    --   calls push frames towards increasing addresses ----->
  87
  88    --   Bottom(most) Slot                                    Top(most) Slot
  89    --    |                                                             |
  90    --    V                                                             V
  91    --  +------------------------------------------------------------------+
  92    --  | entry frame | ... | leaf frame |                            |####|
  93    --  +------------------------------------------------------------------+
  94
  95    -------------------
  96    -- Unit Services --
  97    -------------------
  98
  99    --  Now the implementation of the services offered by this unit, on top of
 100    --  the Stack_Slots abstraction above.
 101
 102    Index_Str       : constant String  := "Index";
 103    Task_Name_Str   : constant String  := "Task Name";
 104    Stack_Size_Str  : constant String  := "Stack Size";
 105    Actual_Size_Str : constant String  := "Stack usage";
 106
 107    procedure Output_Result
 108      (Result_Id          : Natural;
 109       Result             : Task_Result;
 110       Max_Stack_Size_Len : Natural;
 111       Max_Actual_Use_Len : Natural);
 112    --  Prints the result on the standard output. Result Id is the number of
 113    --  the result in the array, and Result the contents of the actual result.
 114    --  Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
 115    --  proper layout. They hold the maximum length of the string representing
 116    --  the Stack_Size and Actual_Use values.
 117
 118    ----------------
 119    -- Initialize --
 120    ----------------
 121
 122    procedure Initialize (Buffer_Size : Natural) is
 123       Stack_Size_Chars : System.Address;
 124
 125    begin
 126       --  Initialize the buffered result array
 127
 128       Result_Array := new Result_Array_Type (1 .. Buffer_Size);
 129       Result_Array.all :=
 130         (others =>
 131            (Task_Name   => (others => ASCII.NUL),
 132             Value       => 0,
 133             Stack_Size  => 0));
 134
 135       --  Set the Is_Enabled flag to true, so that the task wrapper knows that
 136       --  it has to handle dynamic stack analysis
 137
 138       Is_Enabled := True;
 139
 140       Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
 141
 142       --  If variable GNAT_STACK_LIMIT is set, then we will take care of the
 143       --  environment task, using GNAT_STASK_LIMIT as the size of the stack.
 144       --  It doesn't make sens to process the stack when no bound is set (e.g.
 145       --  limit is typically up to 4 GB).
 146
 147       if Stack_Size_Chars /= Null_Address then
 148          declare
 149             My_Stack_Size : Integer;
 150
 151          begin
 152             My_Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
 153
 154             Initialize_Analyzer
 155               (Environment_Task_Analyzer,
 156                "ENVIRONMENT TASK",
 157                My_Stack_Size,
 158                0,
 159                My_Stack_Size);
 160
 161             Fill_Stack (Environment_Task_Analyzer);
 162
 163             Compute_Environment_Task := True;
 164          end;
 165
 166       --  GNAT_STACK_LIMIT not set
 167
 168       else
 169          Compute_Environment_Task := False;
 170       end if;
 171    end Initialize;
 172
 173    ----------------
 174    -- Fill_Stack --
 175    ----------------
 176
 177    procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is
 178
 179       --  Change the local variables and parameters of this function with
 180       --  super-extra care. The more the stack frame size of this function is
 181       --  big, the more an "instrumentation threshold at writing" error is
 182       --  likely to happen.
 183
 184       Current_Stack_Level : aliased Integer;
 185
 186       Guard : constant := 256;
 187       --  Guard space between the Current_Stack_Level'Address and the last
 188       --  allocated byte on the stack.
 189    begin
 190       if Parameters.Stack_Grows_Down then
 191          if Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size) >
 192               To_Stack_Address (Current_Stack_Level'Address) - Guard
 193          then
 194             --  No room for a pattern
 195
 196             Analyzer.Pattern_Size := 0;
 197             return;
 198          end if;
 199
 200          Analyzer.Pattern_Limit :=
 201            Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size);
 202
 203          if Analyzer.Stack_Base >
 204               To_Stack_Address (Current_Stack_Level'Address) - Guard
 205          then
 206             --  Reduce pattern size to prevent local frame overwrite
 207
 208             Analyzer.Pattern_Size :=
 209               Integer (To_Stack_Address (Current_Stack_Level'Address) - Guard
 210                          - Analyzer.Pattern_Limit);
 211          end if;
 212
 213          Analyzer.Pattern_Overlay_Address :=
 214            To_Address (Analyzer.Pattern_Limit);
 215       else
 216          if Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size) <
 217               To_Stack_Address (Current_Stack_Level'Address) + Guard
 218          then
 219             --  No room for a pattern
 220
 221             Analyzer.Pattern_Size := 0;
 222             return;
 223          end if;
 224
 225          Analyzer.Pattern_Limit :=
 226            Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size);
 227
 228          if Analyzer.Stack_Base <
 229            To_Stack_Address (Current_Stack_Level'Address) + Guard
 230          then
 231             --  Reduce pattern size to prevent local frame overwrite
 232
 233             Analyzer.Pattern_Size :=
 234               Integer
 235                 (Analyzer.Pattern_Limit -
 236                   (To_Stack_Address (Current_Stack_Level'Address) + Guard));
 237          end if;
 238
 239          Analyzer.Pattern_Overlay_Address :=
 240            To_Address (Analyzer.Pattern_Limit -
 241                          Stack_Address (Analyzer.Pattern_Size));
 242       end if;
 243
 244       --  Declare and fill the pattern buffer
 245
 246       declare
 247          Pattern : aliased Stack_Slots
 248                      (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
 249          for Pattern'Address use Analyzer.Pattern_Overlay_Address;
 250
 251       begin
 252          if System.Parameters.Stack_Grows_Down then
 253             for J in reverse Pattern'Range loop
 254                Pattern (J) := Analyzer.Pattern;
 255             end loop;
 256
 257          else
 258             for J in Pattern'Range loop
 259                Pattern (J) := Analyzer.Pattern;
 260             end loop;
 261          end if;
 262       end;
 263    end Fill_Stack;
 264
 265    -------------------------
 266    -- Initialize_Analyzer --
 267    -------------------------
 268
 269    procedure Initialize_Analyzer
 270      (Analyzer         : in out Stack_Analyzer;
 271       Task_Name        : String;
 272       Stack_Size       : Natural;
 273       Stack_Base       : Stack_Address;
 274       Pattern_Size     : Natural;
 275       Pattern          : Interfaces.Unsigned_32 := 16#DEAD_BEEF#)
 276    is
 277    begin
 278       --  Initialize the analyzer fields
 279
 280       Analyzer.Stack_Base    := Stack_Base;
 281       Analyzer.Stack_Size    := Stack_Size;
 282       Analyzer.Pattern_Size  := Pattern_Size;
 283       Analyzer.Pattern       := Pattern;
 284       Analyzer.Result_Id     := Next_Id;
 285       Analyzer.Task_Name     := (others => ' ');
 286
 287       --  Compute the task name, and truncate if bigger than Task_Name_Length
 288
 289       if Task_Name'Length <= Task_Name_Length then
 290          Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
 291       else
 292          Analyzer.Task_Name :=
 293            Task_Name (Task_Name'First ..
 294                       Task_Name'First + Task_Name_Length - 1);
 295       end if;
 296
 297       Next_Id := Next_Id + 1;
 298    end Initialize_Analyzer;
 299
 300    ----------------
 301    -- Stack_Size --
 302    ----------------
 303
 304    function Stack_Size
 305      (SP_Low  : Stack_Address;
 306       SP_High : Stack_Address) return Natural
 307    is
 308    begin
 309       if SP_Low > SP_High then
 310          return Natural (SP_Low - SP_High);
 311       else
 312          return Natural (SP_High - SP_Low);
 313       end if;
 314    end Stack_Size;
 315
 316    --------------------
 317    -- Compute_Result --
 318    --------------------
 319
 320    procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
 321
 322       --  Change the local variables and parameters of this function with
 323       --  super-extra care. The larger the stack frame size of this function
 324       --  is, the more an "instrumentation threshold at reading" error is
 325       --  likely to happen.
 326
 327       Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
 328       for Stack'Address use Analyzer.Pattern_Overlay_Address;
 329
 330    begin
 331       --  Value if the pattern was not modified
 332
 333       if Parameters.Stack_Grows_Down then
 334          Analyzer.Topmost_Touched_Mark :=
 335            Analyzer.Pattern_Limit + Stack_Address (Analyzer.Pattern_Size);
 336       else
 337          Analyzer.Topmost_Touched_Mark :=
 338            Analyzer.Pattern_Limit - Stack_Address (Analyzer.Pattern_Size);
 339       end if;
 340
 341       if Analyzer.Pattern_Size = 0 then
 342          return;
 343       end if;
 344
 345       --  Look backward from the topmost possible end of the marked stack to
 346       --  the bottom of it. The first index not equals to the patterns marks
 347       --  the beginning of the used stack.
 348
 349       if System.Parameters.Stack_Grows_Down then
 350          for J in Stack'Range loop
 351             if Stack (J) /= Analyzer.Pattern then
 352                Analyzer.Topmost_Touched_Mark :=
 353                  To_Stack_Address (Stack (J)'Address);
 354                exit;
 355             end if;
 356          end loop;
 357
 358       else
 359          for J in reverse Stack'Range loop
 360             if Stack (J) /= Analyzer.Pattern then
 361                Analyzer.Topmost_Touched_Mark :=
 362                  To_Stack_Address (Stack (J)'Address);
 363                exit;
 364             end if;
 365          end loop;
 366
 367       end if;
 368    end Compute_Result;
 369
 370    ---------------------
 371    --  Output_Result --
 372    ---------------------
 373
 374    procedure Output_Result
 375      (Result_Id          : Natural;
 376       Result             : Task_Result;
 377       Max_Stack_Size_Len : Natural;
 378       Max_Actual_Use_Len : Natural)
 379    is
 380       Result_Id_Str  : constant String := Natural'Image (Result_Id);
 381       Stack_Size_Str : constant String := Natural'Image (Result.Stack_Size);
 382       Actual_Use_Str : constant String := Natural'Image (Result.Value);
 383
 384       Result_Id_Blanks  : constant
 385         String (1 .. Index_Str'Length - Result_Id_Str'Length)    :=
 386           (others => ' ');
 387
 388       Stack_Size_Blanks : constant
 389         String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
 390           (others => ' ');
 391
 392       Actual_Use_Blanks : constant
 393         String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
 394           (others => ' ');
 395
 396    begin
 397       Set_Output (Standard_Error);
 398       Put (Result_Id_Blanks & Natural'Image (Result_Id));
 399       Put (" | ");
 400       Put (Result.Task_Name);
 401       Put (" | ");
 402       Put (Stack_Size_Blanks & Stack_Size_Str);
 403       Put (" | ");
 404       Put (Actual_Use_Blanks & Actual_Use_Str);
 405       New_Line;
 406    end Output_Result;
 407
 408    ---------------------
 409    --  Output_Results --
 410    ---------------------
 411
 412    procedure Output_Results is
 413       Max_Stack_Size                         : Natural := 0;
 414       Max_Stack_Usage                        : Natural := 0;
 415       Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
 416
 417       Task_Name_Blanks : constant
 418                            String
 419                              (1 .. Task_Name_Length - Task_Name_Str'Length) :=
 420                                (others => ' ');
 421
 422    begin
 423       Set_Output (Standard_Error);
 424
 425       if Compute_Environment_Task then
 426          Compute_Result (Environment_Task_Analyzer);
 427          Report_Result (Environment_Task_Analyzer);
 428       end if;
 429
 430       if Result_Array'Length > 0 then
 431
 432          --  Computes the size of the largest strings that will get displayed,
 433          --  in order to do correct column alignment.
 434
 435          for J in Result_Array'Range loop
 436             exit when J >= Next_Id;
 437
 438             if Result_Array (J).Value > Max_Stack_Usage then
 439                Max_Stack_Usage := Result_Array (J).Value;
 440             end if;
 441
 442             if Result_Array (J).Stack_Size > Max_Stack_Size then
 443                Max_Stack_Size := Result_Array (J).Stack_Size;
 444             end if;
 445          end loop;
 446
 447          Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
 448
 449          Max_Actual_Use_Len := Natural'Image (Max_Stack_Usage)'Length;
 450
 451          --  Display the output header. Blanks will be added in front of the
 452          --  labels if needed.
 453
 454          declare
 455             Stack_Size_Blanks  : constant
 456                                    String (1 .. Max_Stack_Size_Len -
 457                                                   Stack_Size_Str'Length) :=
 458                                       (others => ' ');
 459
 460             Stack_Usage_Blanks : constant
 461                                    String (1 .. Max_Actual_Use_Len -
 462                                                   Actual_Size_Str'Length) :=
 463                                       (others => ' ');
 464
 465          begin
 466             if Stack_Size_Str'Length > Max_Stack_Size_Len then
 467                Max_Stack_Size_Len := Stack_Size_Str'Length;
 468             end if;
 469
 470             if Actual_Size_Str'Length > Max_Actual_Use_Len then
 471                Max_Actual_Use_Len := Actual_Size_Str'Length;
 472             end if;
 473
 474             Put
 475               (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 476                & Stack_Size_Str & Stack_Size_Blanks & " | "
 477                & Stack_Usage_Blanks & Actual_Size_Str);
 478          end;
 479
 480          New_Line;
 481
 482          --  Now display the individual results
 483
 484          for J in Result_Array'Range loop
 485             exit when J >= Next_Id;
 486             Output_Result
 487               (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
 488          end loop;
 489
 490       --  Case of no result stored, still display the labels
 491
 492       else
 493          Put
 494            (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 495             & Stack_Size_Str & " | " & Actual_Size_Str);
 496          New_Line;
 497       end if;
 498    end Output_Results;
 499
 500    -------------------
 501    -- Report_Result --
 502    -------------------
 503
 504    procedure Report_Result (Analyzer : Stack_Analyzer) is
 505       Result : Task_Result := (Task_Name  => Analyzer.Task_Name,
 506                                Stack_Size => Analyzer.Stack_Size,
 507                                Value      => 0);
 508    begin
 509       if Analyzer.Pattern_Size = 0 then
 510
 511          --  If we have that result, it means that we didn't do any computation
 512          --  at all (i.e. we used at least everything (and possibly more).
 513
 514          Result.Value := Analyzer.Stack_Size;
 515
 516       else
 517          Result.Value := Stack_Size (Analyzer.Topmost_Touched_Mark,
 518                                      Analyzer.Stack_Base);
 519       end if;
 520
 521       if Analyzer.Result_Id in Result_Array'Range then
 522
 523          --  If the result can be stored, then store it in Result_Array
 524
 525          Result_Array (Analyzer.Result_Id) := Result;
 526
 527       else
 528          --  If the result cannot be stored, then we display it right away
 529
 530          declare
 531             Result_Str_Len : constant Natural :=
 532                                Natural'Image (Result.Value)'Length;
 533             Size_Str_Len   : constant Natural :=
 534                                Natural'Image (Analyzer.Stack_Size)'Length;
 535
 536             Max_Stack_Size_Len : Natural;
 537             Max_Actual_Use_Len : Natural;
 538
 539          begin
 540             --  Take either the label size or the number image size for the
 541             --  size of the column "Stack Size".
 542
 543             Max_Stack_Size_Len :=
 544               (if Size_Str_Len > Stack_Size_Str'Length
 545                then Size_Str_Len
 546                else Stack_Size_Str'Length);
 547
 548             --  Take either the label size or the number image size for the
 549             --  size of the column "Stack Usage".
 550
 551             Max_Actual_Use_Len :=
 552               (if Result_Str_Len > Actual_Size_Str'Length
 553                then Result_Str_Len
 554                else Actual_Size_Str'Length);
 555
 556             Output_Result
 557               (Analyzer.Result_Id,
 558                Result,
 559                Max_Stack_Size_Len,
 560                Max_Actual_Use_Len);
 561          end;
 562       end if;
 563    end Report_Result;
 564
 565 end System.Stack_Usage;