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