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-2008, 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             Min_Measure => 0,
 210             Max_Measure => 0,
 211             Max_Size    => 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 doesn'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                Stack_Size,
 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       --  Change the local variables and parameters of this function with
 257       --  super-extra care. The more the stack frame size of this function is
 258       --  big, the more an "instrumentation threshold at writing" error is
 259       --  likely to happen.
 260
 261       Current_Stack_Level : aliased Integer;
 262    begin
 263       --  Reajust the pattern size. When we arrive in this function, there is
 264       --  already a given amount of stack used, that we won't analyze.
 265
 266       Analyzer.Stack_Used_When_Filling := Stack_Size
 267         (Analyzer.Bottom_Of_Stack,
 268          To_Stack_Address (Current_Stack_Level'Address))
 269         + Natural (Current_Stack_Level'Size);
 270
 271       Analyzer.Pattern_Size := Analyzer.Pattern_Size
 272         - Analyzer.Stack_Used_When_Filling;
 273
 274       declare
 275          Stack : aliased Stack_Slots
 276            (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
 277       begin
 278          Stack := (others => Analyzer.Pattern);
 279
 280          Analyzer.Stack_Overlay_Address := Stack'Address;
 281
 282          Analyzer.Bottom_Pattern_Mark :=
 283            To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address);
 284          Analyzer.Top_Pattern_Mark :=
 285            To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address);
 286
 287          --  If Arr has been packed, the following assertion must be true (we
 288          --  add the size of the element whose address is:
 289          --    Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):
 290
 291          pragma Assert
 292            (Analyzer.Pattern_Size =
 293               Stack_Size
 294                 (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark));
 295       end;
 296    end Fill_Stack;
 297
 298    -------------------------
 299    -- Initialize_Analyzer --
 300    -------------------------
 301
 302    procedure Initialize_Analyzer
 303      (Analyzer         : in out Stack_Analyzer;
 304       Task_Name        : String;
 305       Stack_Size       : Natural;
 306       Max_Pattern_Size : Natural;
 307       Bottom           : Stack_Address;
 308       Pattern          : Unsigned_32 := 16#DEAD_BEEF#)
 309    is
 310    begin
 311       --  Initialize the analyzer fields
 312
 313       Analyzer.Bottom_Of_Stack := Bottom;
 314       Analyzer.Stack_Size := Stack_Size;
 315       Analyzer.Pattern_Size := Max_Pattern_Size;
 316       Analyzer.Pattern := Pattern;
 317       Analyzer.Result_Id := Next_Id;
 318
 319       Analyzer.Task_Name := (others => ' ');
 320
 321       --  Compute the task name, and truncate it if it's bigger than
 322       --  Task_Name_Length
 323
 324       if Task_Name'Length <= Task_Name_Length then
 325          Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
 326       else
 327          Analyzer.Task_Name :=
 328            Task_Name (Task_Name'First ..
 329                         Task_Name'First + Task_Name_Length - 1);
 330       end if;
 331
 332       Next_Id := Next_Id + 1;
 333    end Initialize_Analyzer;
 334
 335    ----------------
 336    -- Stack_Size --
 337    ----------------
 338
 339    function Stack_Size
 340      (SP_Low  : Stack_Address;
 341       SP_High : Stack_Address) return Natural
 342    is
 343    begin
 344       if SP_Low > SP_High then
 345          return Natural (SP_Low - SP_High + 4);
 346       else
 347          return Natural (SP_High - SP_Low + 4);
 348       end if;
 349    end Stack_Size;
 350
 351    --------------------
 352    -- Compute_Result --
 353    --------------------
 354
 355    procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
 356
 357       --  Change the local variables and parameters of this function with
 358       --  super-extra care. The larger the stack frame size of this function
 359       --  is, the more an "instrumentation threshold at reading" error is
 360       --  likely to happen.
 361
 362       Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
 363       for Stack'Address use Analyzer.Stack_Overlay_Address;
 364
 365    begin
 366       Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark;
 367
 368       --  Look backward from the topmost possible end of the marked stack to
 369       --  the bottom of it. The first index not equals to the patterns marks
 370       --  the beginning of the used stack.
 371
 372       declare
 373          Top_Index    : constant Integer := Top_Slot_Index_In (Stack);
 374          Bottom_Index : constant Integer := Bottom_Slot_Index_In (Stack);
 375          Step         : constant Integer := Pop_Index_Step_For (Stack);
 376          J            : Integer;
 377
 378       begin
 379          J := Top_Index;
 380          loop
 381             if Stack (J) /= Analyzer.Pattern then
 382                Analyzer.Topmost_Touched_Mark
 383                  := To_Stack_Address (Stack (J)'Address);
 384                exit;
 385             end if;
 386
 387             exit when J = Bottom_Index;
 388             J := J + Step;
 389          end loop;
 390       end;
 391    end Compute_Result;
 392
 393    ---------------------
 394    -- Get_Usage_Range --
 395    ---------------------
 396
 397    function Get_Usage_Range (Result : Task_Result) return String is
 398       Min_Used_Str : constant String := Natural'Image (Result.Min_Measure);
 399       Max_Used_Str : constant String := Natural'Image (Result.Max_Measure);
 400    begin
 401       return "[" & Min_Used_Str (2 .. Min_Used_Str'Last) & " -"
 402              & Max_Used_Str & "]";
 403    end Get_Usage_Range;
 404
 405    ---------------------
 406    --  Output_Result --
 407    ---------------------
 408
 409    procedure Output_Result
 410      (Result_Id          : Natural;
 411       Result             : Task_Result;
 412       Max_Stack_Size_Len : Natural;
 413       Max_Actual_Use_Len : Natural)
 414    is
 415       Result_Id_Str  : constant String := Natural'Image (Result_Id);
 416       Stack_Size_Str : constant String := Natural'Image (Result.Max_Size);
 417       Actual_Use_Str : constant String := Get_Usage_Range (Result);
 418
 419       Result_Id_Blanks  : constant
 420         String (1 .. Index_Str'Length - Result_Id_Str'Length)    :=
 421           (others => ' ');
 422
 423       Stack_Size_Blanks : constant
 424         String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
 425           (others => ' ');
 426
 427       Actual_Use_Blanks : constant
 428         String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
 429           (others => ' ');
 430
 431    begin
 432       Set_Output (Standard_Error);
 433       Put (Result_Id_Blanks & Natural'Image (Result_Id));
 434       Put (" | ");
 435       Put (Result.Task_Name);
 436       Put (" | ");
 437       Put (Stack_Size_Blanks & Stack_Size_Str);
 438       Put (" | ");
 439       Put (Actual_Use_Blanks & Actual_Use_Str);
 440       New_Line;
 441    end Output_Result;
 442
 443    ---------------------
 444    --  Output_Results --
 445    ---------------------
 446
 447    procedure Output_Results is
 448       Max_Stack_Size                         : Natural := 0;
 449       Max_Actual_Use_Result_Id               : Natural := Result_Array'First;
 450       Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
 451
 452       Task_Name_Blanks : constant
 453         String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
 454           (others => ' ');
 455
 456    begin
 457       Set_Output (Standard_Error);
 458
 459       if Compute_Environment_Task then
 460          Compute_Result (Environment_Task_Analyzer);
 461          Report_Result (Environment_Task_Analyzer);
 462       end if;
 463
 464       if Result_Array'Length > 0 then
 465
 466          --  Computes the size of the largest strings that will get displayed,
 467          --  in order to do correct column alignment.
 468
 469          for J in Result_Array'Range loop
 470             exit when J >= Next_Id;
 471
 472             if Result_Array (J).Max_Measure
 473               > Result_Array (Max_Actual_Use_Result_Id).Max_Measure
 474             then
 475                Max_Actual_Use_Result_Id := J;
 476             end if;
 477
 478             if Result_Array (J).Max_Size > Max_Stack_Size then
 479                Max_Stack_Size := Result_Array (J).Max_Size;
 480             end if;
 481          end loop;
 482
 483          Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
 484
 485          Max_Actual_Use_Len :=
 486            Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'Length;
 487
 488          --  Display the output header. Blanks will be added in front of the
 489          --  labels if needed.
 490
 491          declare
 492             Stack_Size_Blanks  : constant
 493               String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
 494                 (others => ' ');
 495
 496             Stack_Usage_Blanks : constant
 497               String (1 .. Max_Actual_Use_Len - Actual_Size_Str'Length) :=
 498                 (others => ' ');
 499
 500          begin
 501             if Stack_Size_Str'Length > Max_Stack_Size_Len then
 502                Max_Stack_Size_Len := Stack_Size_Str'Length;
 503             end if;
 504
 505             if Actual_Size_Str'Length > Max_Actual_Use_Len then
 506                Max_Actual_Use_Len := Actual_Size_Str'Length;
 507             end if;
 508
 509             Put
 510               (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 511                & Stack_Size_Str & Stack_Size_Blanks & " | "
 512                & Stack_Usage_Blanks & Actual_Size_Str);
 513          end;
 514
 515          New_Line;
 516
 517          --  Now display the individual results
 518
 519          for J in Result_Array'Range loop
 520             exit when J >= Next_Id;
 521             Output_Result
 522               (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
 523          end loop;
 524
 525       --  Case of no result stored, still display the labels
 526
 527       else
 528          Put
 529            (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 530             & Stack_Size_Str & " | " & Actual_Size_Str);
 531          New_Line;
 532       end if;
 533    end Output_Results;
 534
 535    -------------------
 536    -- Report_Result --
 537    -------------------
 538
 539    procedure Report_Result (Analyzer : Stack_Analyzer) is
 540       Measure : constant Natural :=
 541         Stack_Size
 542           (Analyzer.Topmost_Touched_Mark,
 543            Analyzer.Bottom_Of_Stack)
 544         + Analyzer.Stack_Used_When_Filling;
 545       Result : constant Task_Result :=
 546         (Task_Name      => Analyzer.Task_Name,
 547          Max_Size       => Analyzer.Stack_Size,
 548          Min_Measure    => Measure,
 549          Max_Measure    => Measure + Analyzer.Stack_Size
 550          - Analyzer.Pattern_Size);
 551    begin
 552       if Analyzer.Result_Id in Result_Array'Range then
 553
 554          --  If the result can be stored, then store it in Result_Array
 555
 556          Result_Array (Analyzer.Result_Id) := Result;
 557
 558       else
 559          --  If the result cannot be stored, then we display it right away
 560
 561          declare
 562             Result_Str_Len : constant Natural :=
 563                                Get_Usage_Range (Result)'Length;
 564             Size_Str_Len   : constant Natural :=
 565                                Natural'Image (Analyzer.Stack_Size)'Length;
 566
 567             Max_Stack_Size_Len : Natural;
 568             Max_Actual_Use_Len : Natural;
 569
 570          begin
 571             --  Take either the label size or the number image size for the
 572             --  size of the column "Stack Size".
 573
 574             if Size_Str_Len > Stack_Size_Str'Length then
 575                Max_Stack_Size_Len := Size_Str_Len;
 576             else
 577                Max_Stack_Size_Len := Stack_Size_Str'Length;
 578             end if;
 579
 580             --  Take either the label size or the number image size for the
 581             --  size of the column "Stack Usage"
 582
 583             if Result_Str_Len > Actual_Size_Str'Length then
 584                Max_Actual_Use_Len := Result_Str_Len;
 585             else
 586                Max_Actual_Use_Len := Actual_Size_Str'Length;
 587             end if;
 588
 589             Output_Result
 590               (Analyzer.Result_Id,
 591                Result,
 592                Max_Stack_Size_Len,
 593                Max_Actual_Use_Len);
 594          end;
 595       end if;
 596    end Report_Result;
 597
 598 end System.Stack_Usage;