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    Index_Str               : constant String  := "Index";
  45    Task_Name_Str           : constant String  := "Task Name";
  46    Stack_Size_Str          : constant String  := "Stack Size";
  47    Actual_Size_Str         : constant String  := "Stack usage [min - max]";
  48    Pattern_Array_Elem_Size : constant Natural :=
  49                                (Unsigned_32_Size / Byte_Size);
  50
  51    function Get_Usage_Range (Result : Task_Result) return String;
  52    --  Return string representing the range of possible result of stack usage
  53
  54    procedure Output_Result
  55      (Result_Id          : Natural;
  56       Result             : Task_Result;
  57       Max_Stack_Size_Len : Natural;
  58       Max_Actual_Use_Len : Natural);
  59    --  Prints the result on the standard output. Result Id is the number of
  60    --  the result in the array, and Result the contents of the actual result.
  61    --  Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
  62    --  proper layout. They hold the maximum length of the string representing
  63    --  the Stack_Size and Actual_Use values.
  64
  65    function Closer_To_Bottom
  66      (A1 : Stack_Address;
  67       A2 : Stack_Address) return Boolean;
  68    pragma Inline (Closer_To_Bottom);
  69    --  Return True if, according to the direction of the stack growth, A1 is
  70    --  closer to the bottom than A2. Inlined to reduce the size of the stack
  71    --  used by the instrumentation code.
  72
  73    ----------------------
  74    -- Closer_To_Bottom --
  75    ----------------------
  76
  77    function Closer_To_Bottom
  78      (A1 : Stack_Address;
  79       A2 : Stack_Address) return Boolean
  80    is
  81    begin
  82       if System.Parameters.Stack_Grows_Down then
  83          return A1 > A2;
  84       else
  85          return A2 > A1;
  86       end if;
  87    end Closer_To_Bottom;
  88
  89    ----------------
  90    -- Initialize --
  91    ----------------
  92
  93    procedure Initialize (Buffer_Size : Natural) is
  94       Bottom_Of_Stack  : aliased Integer;
  95       Stack_Size_Chars : System.Address;
  96
  97    begin
  98       --  Initialize the buffered result array
  99
 100       Result_Array := new Result_Array_Type (1 .. Buffer_Size);
 101       Result_Array.all :=
 102         (others =>
 103            (Task_Name      => (others => ASCII.NUL),
 104             Measure        => 0,
 105             Max_Size       => 0,
 106             Overflow_Guard => 0));
 107
 108       --  Set the Is_Enabled flag to true, so that the task wrapper knows that
 109       --  it has to handle dynamic stack analysis
 110
 111       Is_Enabled := True;
 112
 113       Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
 114
 115       --  If variable GNAT_STACK_LIMIT is set, then we will take care of the
 116       --  environment task, using GNAT_STASK_LIMIT as the size of the stack.
 117       --  It doens't make sens to process the stack when no bound is set (e.g.
 118       --  limit is typically up to 4 GB).
 119
 120       if Stack_Size_Chars /= Null_Address then
 121          declare
 122             Stack_Size : Integer;
 123
 124          begin
 125             Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
 126
 127             Initialize_Analyzer
 128               (Environment_Task_Analyzer,
 129                "ENVIRONMENT TASK",
 130                Stack_Size,
 131                0,
 132                System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address));
 133
 134             Fill_Stack (Environment_Task_Analyzer);
 135
 136             Compute_Environment_Task := True;
 137          end;
 138
 139       --  GNAT_STACK_LIMIT not set
 140
 141       else
 142          Compute_Environment_Task := False;
 143       end if;
 144    end Initialize;
 145
 146    ----------------
 147    -- Fill_Stack --
 148    ----------------
 149
 150    procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is
 151
 152       --  Change the local variables and parameters of this function with
 153       --  super-extra care. The more the stack frame size of this function is
 154       --  big, the more an "instrumentation threshold at writing" error is
 155       --  likely to happen.
 156
 157       type Unsigned_32_Arr is
 158         array (1 .. Analyzer.Size / Pattern_Array_Elem_Size) of Unsigned_32;
 159       for Unsigned_32_Arr'Component_Size use 32;
 160
 161       package Arr_Addr is
 162         new System.Address_To_Access_Conversions (Unsigned_32_Arr);
 163
 164       Arr : aliased Unsigned_32_Arr;
 165
 166    begin
 167       --  Fill the stack with the pattern
 168
 169       for J in Unsigned_32_Arr'Range loop
 170          Arr (J) := Analyzer.Pattern;
 171       end loop;
 172
 173       --  Initialize the analyzer value
 174
 175       Analyzer.Array_Address := Arr_Addr.To_Address (Arr'Access);
 176       Analyzer.Bottom_Pattern_Mark := To_Stack_Address (Arr (1)'Address);
 177       Analyzer.Top_Pattern_Mark :=
 178         To_Stack_Address (Arr (Unsigned_32_Arr'Last)'Address);
 179
 180       if
 181         Closer_To_Bottom
 182           (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark)
 183       then
 184          Analyzer.Bottom_Pattern_Mark := Analyzer.Top_Pattern_Mark;
 185          Analyzer.Top_Pattern_Mark := To_Stack_Address (Arr (1)'Address);
 186          Analyzer.First_Is_Topmost := True;
 187       else
 188          Analyzer.First_Is_Topmost := False;
 189       end if;
 190
 191       --  If Arr has been packed, the following assertion must be true (we add
 192       --  the size of the element whose address is:
 193       --    Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):
 194
 195       pragma Assert
 196         (Analyzer.Size =
 197            Stack_Size
 198              (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark));
 199    end Fill_Stack;
 200
 201    -------------------------
 202    -- Initialize_Analyzer --
 203    -------------------------
 204
 205    procedure Initialize_Analyzer
 206      (Analyzer       : in out Stack_Analyzer;
 207       Task_Name      : String;
 208       Size           : Natural;
 209       Overflow_Guard : Natural;
 210       Bottom         : Stack_Address;
 211       Pattern        : Unsigned_32 := 16#DEAD_BEEF#)
 212    is
 213    begin
 214       --  Initialize the analyzer fields
 215
 216       Analyzer.Bottom_Of_Stack := Bottom;
 217       Analyzer.Size := Size;
 218       Analyzer.Pattern := Pattern;
 219       Analyzer.Result_Id := Next_Id;
 220
 221       Analyzer.Task_Name := (others => ' ');
 222
 223       --  Compute the task name, and truncate it if it's bigger than
 224       --  Task_Name_Length
 225
 226       if Task_Name'Length <= Task_Name_Length then
 227          Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
 228       else
 229          Analyzer.Task_Name :=
 230            Task_Name (Task_Name'First ..
 231                         Task_Name'First + Task_Name_Length - 1);
 232       end if;
 233
 234       Analyzer.Overflow_Guard := Overflow_Guard;
 235
 236       Next_Id := Next_Id + 1;
 237    end Initialize_Analyzer;
 238
 239    ----------------
 240    -- Stack_Size --
 241    ----------------
 242
 243    function Stack_Size
 244      (SP_Low  : Stack_Address;
 245       SP_High : Stack_Address) return Natural
 246    is
 247    begin
 248       if SP_Low > SP_High then
 249          return Natural (SP_Low - SP_High + 4);
 250       else
 251          return Natural (SP_High - SP_Low + 4);
 252       end if;
 253    end Stack_Size;
 254
 255    --------------------
 256    -- Compute_Result --
 257    --------------------
 258
 259    procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
 260
 261       --  Change the local variables and parameters of this function with
 262       --  super-extra care. The larger the stack frame size of this function
 263       --  is, the more an "instrumentation threshold at reading" error is
 264       --  likely to happen.
 265
 266       type Unsigned_32_Arr is
 267         array (1 .. Analyzer.Size / Pattern_Array_Elem_Size) of Unsigned_32;
 268       for Unsigned_32_Arr'Component_Size use 32;
 269
 270       package Arr_Addr is
 271         new System.Address_To_Access_Conversions (Unsigned_32_Arr);
 272
 273       Arr_Access : Arr_Addr.Object_Pointer;
 274
 275    begin
 276       Arr_Access := Arr_Addr.To_Pointer (Analyzer.Array_Address);
 277       Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark;
 278
 279       --  Look backward from the end of the stack to the beginning. The first
 280       --  index not equals to the patterns marks the beginning of the used
 281       --  stack.
 282
 283       for J in Unsigned_32_Arr'Range loop
 284          if Arr_Access (J) /= Analyzer.Pattern then
 285             Analyzer.Topmost_Touched_Mark :=
 286               To_Stack_Address (Arr_Access (J)'Address);
 287
 288             if Analyzer.First_Is_Topmost then
 289                exit;
 290             end if;
 291          end if;
 292       end loop;
 293    end Compute_Result;
 294
 295    ---------------------
 296    -- Get_Usage_Range --
 297    ---------------------
 298
 299    function Get_Usage_Range (Result : Task_Result) return String is
 300       Min_Used_Str : constant String :=
 301                        Natural'Image (Result.Measure);
 302       Max_Used_Str : constant String :=
 303                        Natural'Image (Result.Measure + Result.Overflow_Guard);
 304    begin
 305       return "[" & Min_Used_Str (2 .. Min_Used_Str'Last) & " -"
 306         & Max_Used_Str & "]";
 307    end Get_Usage_Range;
 308
 309    ---------------------
 310    --  Output_Result --
 311    ---------------------
 312
 313    procedure Output_Result
 314      (Result_Id          : Natural;
 315       Result             : Task_Result;
 316       Max_Stack_Size_Len : Natural;
 317       Max_Actual_Use_Len : Natural)
 318    is
 319       Result_Id_Str  : constant String := Natural'Image (Result_Id);
 320       Stack_Size_Str : constant String := Natural'Image (Result.Max_Size);
 321       Actual_Use_Str : constant String := Get_Usage_Range (Result);
 322
 323       Result_Id_Blanks  : constant
 324         String (1 .. Index_Str'Length - Result_Id_Str'Length)    :=
 325           (others => ' ');
 326       Stack_Size_Blanks : constant
 327         String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
 328           (others => ' ');
 329       Actual_Use_Blanks : constant
 330         String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
 331           (others => ' ');
 332    begin
 333       Set_Output (Standard_Error);
 334       Put (Result_Id_Blanks & Natural'Image (Result_Id));
 335       Put (" | ");
 336       Put (Result.Task_Name);
 337       Put (" | ");
 338       Put (Stack_Size_Blanks & Stack_Size_Str);
 339       Put (" | ");
 340       Put (Actual_Use_Blanks & Actual_Use_Str);
 341       New_Line;
 342    end Output_Result;
 343
 344    ---------------------
 345    --  Output_Results --
 346    ---------------------
 347
 348    procedure Output_Results is
 349       Max_Stack_Size                         : Natural := 0;
 350       Max_Actual_Use_Result_Id               : Natural := Result_Array'First;
 351       Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
 352
 353       Task_Name_Blanks :
 354         constant String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
 355                                                  (others => ' ');
 356
 357    begin
 358       Set_Output (Standard_Error);
 359
 360       if Compute_Environment_Task then
 361          Compute_Result (Environment_Task_Analyzer);
 362          Report_Result (Environment_Task_Analyzer);
 363       end if;
 364
 365       if Result_Array'Length > 0 then
 366
 367          --  Computes the size of the largest strings that will get displayed,
 368          --  in order to do correct column alignment.
 369
 370          for J in Result_Array'Range loop
 371             exit when J >= Next_Id;
 372
 373             if Result_Array (J).Measure
 374               > Result_Array (Max_Actual_Use_Result_Id).Measure
 375             then
 376                Max_Actual_Use_Result_Id := J;
 377             end if;
 378
 379             if Result_Array (J).Max_Size > Max_Stack_Size then
 380                Max_Stack_Size := Result_Array (J).Max_Size;
 381             end if;
 382          end loop;
 383
 384          Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
 385
 386          Max_Actual_Use_Len :=
 387            Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'Length;
 388
 389          --  Display the output header. Blanks will be added in front of the
 390          --  labels if needed.
 391
 392          declare
 393             Stack_Size_Blanks  : constant
 394               String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
 395               (others => ' ');
 396             Stack_Usage_Blanks : constant
 397               String (1 .. Max_Actual_Use_Len - Actual_Size_Str'Length) :=
 398               (others => ' ');
 399
 400          begin
 401             if Stack_Size_Str'Length > Max_Stack_Size_Len then
 402                Max_Stack_Size_Len := Stack_Size_Str'Length;
 403             end if;
 404
 405             if Actual_Size_Str'Length > Max_Actual_Use_Len then
 406                Max_Actual_Use_Len := Actual_Size_Str'Length;
 407             end if;
 408
 409             Put
 410               (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 411                & Stack_Size_Str & Stack_Size_Blanks & " | "
 412                & Stack_Usage_Blanks & Actual_Size_Str);
 413          end;
 414
 415          New_Line;
 416
 417          --  Now display the individual results
 418
 419          for J in Result_Array'Range loop
 420             exit when J >= Next_Id;
 421             Output_Result
 422               (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
 423          end loop;
 424       else
 425          --  If there are no result stored, we'll still display the labels
 426
 427          Put
 428            (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 429             & Stack_Size_Str & " | " & Actual_Size_Str);
 430          New_Line;
 431       end if;
 432    end Output_Results;
 433
 434    -------------------
 435    -- Report_Result --
 436    -------------------
 437
 438    procedure Report_Result (Analyzer : Stack_Analyzer) is
 439       Result : constant Task_Result :=
 440         (Task_Name      => Analyzer.Task_Name,
 441          Max_Size       => Analyzer.Size + Analyzer.Overflow_Guard,
 442          Measure        => Stack_Size
 443                              (Analyzer.Topmost_Touched_Mark,
 444                               Analyzer.Bottom_Of_Stack),
 445          Overflow_Guard => Analyzer.Overflow_Guard -
 446                              Natural (Analyzer.Bottom_Of_Stack -
 447                                Analyzer.Bottom_Pattern_Mark));
 448    begin
 449       if Analyzer.Result_Id in Result_Array'Range then
 450
 451          --  If the result can be stored, then store it in Result_Array
 452
 453          Result_Array (Analyzer.Result_Id) := Result;
 454
 455       else
 456
 457          --  If the result cannot be stored, then we display it right away
 458
 459          declare
 460             Result_Str_Len : constant Natural :=
 461                                Get_Usage_Range (Result)'Length;
 462             Size_Str_Len   : constant Natural :=
 463                                Natural'Image (Analyzer.Size)'Length;
 464
 465             Max_Stack_Size_Len : Natural;
 466             Max_Actual_Use_Len : Natural;
 467
 468          begin
 469             --  Take either the label size or the number image size for the
 470             --  size of the column "Stack Size".
 471
 472             if Size_Str_Len > Stack_Size_Str'Length then
 473                Max_Stack_Size_Len := Size_Str_Len;
 474             else
 475                Max_Stack_Size_Len := Stack_Size_Str'Length;
 476             end if;
 477
 478             --  Take either the label size or the number image size for the
 479             --  size of the column "Stack Usage"
 480
 481             if Result_Str_Len > Actual_Size_Str'Length then
 482                Max_Actual_Use_Len := Result_Str_Len;
 483             else
 484                Max_Actual_Use_Len := Actual_Size_Str'Length;
 485             end if;
 486
 487             Output_Result
 488               (Analyzer.Result_Id,
 489                Result,
 490                Max_Stack_Size_Len,
 491                Max_Actual_Use_Len);
 492          end;
 493       end if;
 494    end Report_Result;
 495
 496 end System.Stack_Usage;