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