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-2009, 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    function Top_Slot_Index_In (Stack : Stack_Slots) return Integer;
  97    --  Index of the stack Top slot in the Slots array, denoting the latest
  98    --  possible slot available to call chain leaves.
  99
 100    function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer;
 101    --  Index of the stack Bottom slot in the Slots array, denoting the first
 102    --  possible slot available to call chain entry points.
 103
 104    function Push_Index_Step_For (Stack : Stack_Slots) return Integer;
 105    --  By how much do we need to update a Slots index to Push a single slot on
 106    --  the stack.
 107
 108    function Pop_Index_Step_For (Stack : Stack_Slots) return Integer;
 109    --  By how much do we need to update a Slots index to Pop a single slot off
 110    --  the stack.
 111
 112    pragma Inline_Always (Top_Slot_Index_In);
 113    pragma Inline_Always (Bottom_Slot_Index_In);
 114    pragma Inline_Always (Push_Index_Step_For);
 115    pragma Inline_Always (Pop_Index_Step_For);
 116
 117    -----------------------
 118    -- Top_Slot_Index_In --
 119    -----------------------
 120
 121    function Top_Slot_Index_In (Stack : Stack_Slots) return Integer is
 122    begin
 123       if System.Parameters.Stack_Grows_Down then
 124          return Stack'First;
 125       else
 126          return Stack'Last;
 127       end if;
 128    end Top_Slot_Index_In;
 129
 130    ----------------------------
 131    --  Bottom_Slot_Index_In  --
 132    ----------------------------
 133
 134    function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer is
 135    begin
 136       if System.Parameters.Stack_Grows_Down then
 137          return Stack'Last;
 138       else
 139          return Stack'First;
 140       end if;
 141    end Bottom_Slot_Index_In;
 142
 143    -------------------------
 144    -- Push_Index_Step_For --
 145    -------------------------
 146
 147    function Push_Index_Step_For (Stack : Stack_Slots) return Integer is
 148       pragma Unreferenced (Stack);
 149    begin
 150       if System.Parameters.Stack_Grows_Down then
 151          return -1;
 152       else
 153          return +1;
 154       end if;
 155    end Push_Index_Step_For;
 156
 157    ------------------------
 158    -- Pop_Index_Step_For --
 159    ------------------------
 160
 161    function Pop_Index_Step_For (Stack : Stack_Slots) return Integer is
 162    begin
 163       return -Push_Index_Step_For (Stack);
 164    end Pop_Index_Step_For;
 165
 166    -------------------
 167    -- Unit Services --
 168    -------------------
 169
 170    --  Now the implementation of the services offered by this unit, on top of
 171    --  the Stack_Slots abstraction above.
 172
 173    Index_Str       : constant String  := "Index";
 174    Task_Name_Str   : constant String  := "Task Name";
 175    Stack_Size_Str  : constant String  := "Stack Size";
 176    Actual_Size_Str : constant String  := "Stack usage";
 177
 178    function Get_Usage_Range (Result : Task_Result) return String;
 179    --  Return string representing the range of possible result of stack usage
 180
 181    procedure Output_Result
 182      (Result_Id          : Natural;
 183       Result             : Task_Result;
 184       Max_Stack_Size_Len : Natural;
 185       Max_Actual_Use_Len : Natural);
 186    --  Prints the result on the standard output. Result Id is the number of
 187    --  the result in the array, and Result the contents of the actual result.
 188    --  Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
 189    --  proper layout. They hold the maximum length of the string representing
 190    --  the Stack_Size and Actual_Use values.
 191
 192    ----------------
 193    -- Initialize --
 194    ----------------
 195
 196    procedure Initialize (Buffer_Size : Natural) is
 197       Bottom_Of_Stack  : aliased Integer;
 198       Stack_Size_Chars : System.Address;
 199
 200    begin
 201       --  Initialize the buffered result array
 202
 203       Result_Array := new Result_Array_Type (1 .. Buffer_Size);
 204       Result_Array.all :=
 205         (others =>
 206            (Task_Name => (others => ASCII.NUL),
 207             Variation => 0,
 208             Value     => 0,
 209             Max_Size  => 0));
 210
 211       --  Set the Is_Enabled flag to true, so that the task wrapper knows that
 212       --  it has to handle dynamic stack analysis
 213
 214       Is_Enabled := True;
 215
 216       Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
 217
 218       --  If variable GNAT_STACK_LIMIT is set, then we will take care of the
 219       --  environment task, using GNAT_STASK_LIMIT as the size of the stack.
 220       --  It doesn't make sens to process the stack when no bound is set (e.g.
 221       --  limit is typically up to 4 GB).
 222
 223       if Stack_Size_Chars /= Null_Address then
 224          declare
 225             My_Stack_Size : Integer;
 226
 227          begin
 228             My_Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
 229
 230             Initialize_Analyzer
 231               (Environment_Task_Analyzer,
 232                "ENVIRONMENT TASK",
 233                My_Stack_Size,
 234                My_Stack_Size,
 235                System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address));
 236
 237             Fill_Stack (Environment_Task_Analyzer);
 238
 239             Compute_Environment_Task := True;
 240          end;
 241
 242       --  GNAT_STACK_LIMIT not set
 243
 244       else
 245          Compute_Environment_Task := False;
 246       end if;
 247    end Initialize;
 248
 249    ----------------
 250    -- Fill_Stack --
 251    ----------------
 252
 253    procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is
 254       --  Change the local variables and parameters of this function with
 255       --  super-extra care. The more the stack frame size of this function is
 256       --  big, the more an "instrumentation threshold at writing" error is
 257       --  likely to happen.
 258
 259       Stack_Used_When_Filling : Integer;
 260       Current_Stack_Level     : aliased Integer;
 261
 262    begin
 263       --  Readjust 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       Stack_Used_When_Filling :=
 267         Stack_Size
 268          (Analyzer.Bottom_Of_Stack,
 269           To_Stack_Address (Current_Stack_Level'Address))
 270           + Natural (Current_Stack_Level'Size);
 271
 272       if Stack_Used_When_Filling > Analyzer.Pattern_Size then
 273          --  In this case, the known size of the stack is too small, we've
 274          --  already taken more than expected, so there's no possible
 275          --  computation
 276
 277          Analyzer.Pattern_Size := 0;
 278       else
 279          Analyzer.Pattern_Size :=
 280            Analyzer.Pattern_Size - Stack_Used_When_Filling;
 281       end if;
 282
 283       declare
 284          Stack : aliased Stack_Slots
 285                            (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
 286
 287       begin
 288          Stack := (others => Analyzer.Pattern);
 289
 290          Analyzer.Stack_Overlay_Address := Stack'Address;
 291
 292          if Analyzer.Pattern_Size /= 0 then
 293             Analyzer.Bottom_Pattern_Mark :=
 294               To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address);
 295             Analyzer.Top_Pattern_Mark :=
 296               To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address);
 297          else
 298             Analyzer.Bottom_Pattern_Mark := To_Stack_Address (Stack'Address);
 299             Analyzer.Top_Pattern_Mark := To_Stack_Address (Stack'Address);
 300          end if;
 301
 302          --  If Arr has been packed, the following assertion must be true (we
 303          --  add the size of the element whose address is:
 304          --    Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):
 305
 306          pragma Assert
 307            (Analyzer.Pattern_Size = 0 or else
 308             Analyzer.Pattern_Size =
 309               Stack_Size
 310                 (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark));
 311       end;
 312    end Fill_Stack;
 313
 314    -------------------------
 315    -- Initialize_Analyzer --
 316    -------------------------
 317
 318    procedure Initialize_Analyzer
 319      (Analyzer         : in out Stack_Analyzer;
 320       Task_Name        : String;
 321       My_Stack_Size    : Natural;
 322       Max_Pattern_Size : Natural;
 323       Bottom           : Stack_Address;
 324       Pattern          : Unsigned_32 := 16#DEAD_BEEF#)
 325    is
 326    begin
 327       --  Initialize the analyzer fields
 328
 329       Analyzer.Bottom_Of_Stack := Bottom;
 330       Analyzer.Stack_Size      := My_Stack_Size;
 331       Analyzer.Pattern_Size    := Max_Pattern_Size;
 332       Analyzer.Pattern         := Pattern;
 333       Analyzer.Result_Id       := Next_Id;
 334       Analyzer.Task_Name       := (others => ' ');
 335
 336       --  Compute the task name, and truncate if bigger than Task_Name_Length
 337
 338       if Task_Name'Length <= Task_Name_Length then
 339          Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
 340       else
 341          Analyzer.Task_Name :=
 342            Task_Name (Task_Name'First ..
 343                         Task_Name'First + Task_Name_Length - 1);
 344       end if;
 345
 346       Next_Id := Next_Id + 1;
 347    end Initialize_Analyzer;
 348
 349    ----------------
 350    -- Stack_Size --
 351    ----------------
 352
 353    function Stack_Size
 354      (SP_Low  : Stack_Address;
 355       SP_High : Stack_Address) return Natural
 356    is
 357    begin
 358       if SP_Low > SP_High then
 359          return Natural (SP_Low - SP_High + 4);
 360       else
 361          return Natural (SP_High - SP_Low + 4);
 362       end if;
 363    end Stack_Size;
 364
 365    --------------------
 366    -- Compute_Result --
 367    --------------------
 368
 369    procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
 370
 371       --  Change the local variables and parameters of this function with
 372       --  super-extra care. The larger the stack frame size of this function
 373       --  is, the more an "instrumentation threshold at reading" error is
 374       --  likely to happen.
 375
 376       Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
 377       for Stack'Address use Analyzer.Stack_Overlay_Address;
 378
 379    begin
 380       Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark;
 381
 382       if Analyzer.Pattern_Size = 0 then
 383          return;
 384       end if;
 385
 386       --  Look backward from the topmost possible end of the marked stack to
 387       --  the bottom of it. The first index not equals to the patterns marks
 388       --  the beginning of the used stack.
 389
 390       declare
 391          Top_Index    : constant Integer := Top_Slot_Index_In (Stack);
 392          Bottom_Index : constant Integer := Bottom_Slot_Index_In (Stack);
 393          Step         : constant Integer := Pop_Index_Step_For (Stack);
 394          J            : Integer;
 395
 396       begin
 397          J := Top_Index;
 398          loop
 399             if Stack (J) /= Analyzer.Pattern then
 400                Analyzer.Topmost_Touched_Mark
 401                  := To_Stack_Address (Stack (J)'Address);
 402                exit;
 403             end if;
 404
 405             exit when J = Bottom_Index;
 406             J := J + Step;
 407          end loop;
 408       end;
 409    end Compute_Result;
 410
 411    ---------------------
 412    -- Get_Usage_Range --
 413    ---------------------
 414
 415    function Get_Usage_Range (Result : Task_Result) return String is
 416       Variation_Used_Str : constant String :=
 417                              Natural'Image (Result.Variation);
 418       Value_Used_Str     : constant String :=
 419                              Natural'Image (Result.Value);
 420    begin
 421       return Value_Used_Str & " +/- " & Variation_Used_Str;
 422    end Get_Usage_Range;
 423
 424    ---------------------
 425    --  Output_Result --
 426    ---------------------
 427
 428    procedure Output_Result
 429      (Result_Id          : Natural;
 430       Result             : Task_Result;
 431       Max_Stack_Size_Len : Natural;
 432       Max_Actual_Use_Len : Natural)
 433    is
 434       Result_Id_Str     : constant String := Natural'Image (Result_Id);
 435       My_Stack_Size_Str : constant String := Natural'Image (Result.Max_Size);
 436       Actual_Use_Str    : constant String := Get_Usage_Range (Result);
 437
 438       Result_Id_Blanks  : constant
 439         String (1 .. Index_Str'Length - Result_Id_Str'Length)    :=
 440           (others => ' ');
 441
 442       Stack_Size_Blanks : constant
 443         String (1 .. Max_Stack_Size_Len - My_Stack_Size_Str'Length) :=
 444           (others => ' ');
 445
 446       Actual_Use_Blanks : constant
 447         String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
 448           (others => ' ');
 449
 450    begin
 451       Set_Output (Standard_Error);
 452       Put (Result_Id_Blanks & Natural'Image (Result_Id));
 453       Put (" | ");
 454       Put (Result.Task_Name);
 455       Put (" | ");
 456       Put (Stack_Size_Blanks & My_Stack_Size_Str);
 457       Put (" | ");
 458       Put (Actual_Use_Blanks & Actual_Use_Str);
 459       New_Line;
 460    end Output_Result;
 461
 462    ---------------------
 463    --  Output_Results --
 464    ---------------------
 465
 466    procedure Output_Results is
 467       Max_Stack_Size                         : Natural := 0;
 468       Max_Actual_Use_Result_Id               : Natural := Result_Array'First;
 469       Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
 470
 471       Task_Name_Blanks : constant
 472         String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
 473           (others => ' ');
 474
 475    begin
 476       Set_Output (Standard_Error);
 477
 478       if Compute_Environment_Task then
 479          Compute_Result (Environment_Task_Analyzer);
 480          Report_Result (Environment_Task_Analyzer);
 481       end if;
 482
 483       if Result_Array'Length > 0 then
 484
 485          --  Computes the size of the largest strings that will get displayed,
 486          --  in order to do correct column alignment.
 487
 488          for J in Result_Array'Range loop
 489             exit when J >= Next_Id;
 490
 491             if Result_Array (J).Value >
 492                Result_Array (Max_Actual_Use_Result_Id).Value
 493             then
 494                Max_Actual_Use_Result_Id := J;
 495             end if;
 496
 497             if Result_Array (J).Max_Size > Max_Stack_Size then
 498                Max_Stack_Size := Result_Array (J).Max_Size;
 499             end if;
 500          end loop;
 501
 502          Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
 503
 504          Max_Actual_Use_Len :=
 505            Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'Length;
 506
 507          --  Display the output header. Blanks will be added in front of the
 508          --  labels if needed.
 509
 510          declare
 511             Stack_Size_Blanks  : constant
 512               String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
 513                 (others => ' ');
 514
 515             Stack_Usage_Blanks : constant
 516               String (1 .. Max_Actual_Use_Len - Actual_Size_Str'Length) :=
 517                 (others => ' ');
 518
 519          begin
 520             if Stack_Size_Str'Length > Max_Stack_Size_Len then
 521                Max_Stack_Size_Len := Stack_Size_Str'Length;
 522             end if;
 523
 524             if Actual_Size_Str'Length > Max_Actual_Use_Len then
 525                Max_Actual_Use_Len := Actual_Size_Str'Length;
 526             end if;
 527
 528             Put
 529               (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 530                & Stack_Size_Str & Stack_Size_Blanks & " | "
 531                & Stack_Usage_Blanks & Actual_Size_Str);
 532          end;
 533
 534          New_Line;
 535
 536          --  Now display the individual results
 537
 538          for J in Result_Array'Range loop
 539             exit when J >= Next_Id;
 540             Output_Result
 541               (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
 542          end loop;
 543
 544       --  Case of no result stored, still display the labels
 545
 546       else
 547          Put
 548            (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
 549             & Stack_Size_Str & " | " & Actual_Size_Str);
 550          New_Line;
 551       end if;
 552    end Output_Results;
 553
 554    -------------------
 555    -- Report_Result --
 556    -------------------
 557
 558    procedure Report_Result (Analyzer : Stack_Analyzer) is
 559       Result  : Task_Result :=
 560                   (Task_Name      => Analyzer.Task_Name,
 561                    Max_Size       => Analyzer.Stack_Size,
 562                    Variation    => 0,
 563                    Value    => 0);
 564
 565       Overflow_Guard : constant Integer :=
 566         Analyzer.Stack_Size
 567           - Stack_Size (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Of_Stack);
 568       Max, Min : Positive;
 569
 570    begin
 571       if Analyzer.Pattern_Size = 0 then
 572
 573          --  If we have that result, it means that we didn't do any computation
 574          --  at all. In other words, we used at least everything (and possibly
 575          --  more).
 576
 577          Min := Analyzer.Stack_Size - Overflow_Guard;
 578          Max := Analyzer.Stack_Size;
 579
 580       else
 581          Min :=
 582            Stack_Size
 583              (Analyzer.Topmost_Touched_Mark, Analyzer.Bottom_Of_Stack);
 584          Max := Min + Overflow_Guard;
 585       end if;
 586
 587       Result.Value := (Max + Min) / 2;
 588       Result.Variation := (Max - Min) / 2;
 589
 590       if Analyzer.Result_Id in Result_Array'Range then
 591
 592          --  If the result can be stored, then store it in Result_Array
 593
 594          Result_Array (Analyzer.Result_Id) := Result;
 595
 596       else
 597          --  If the result cannot be stored, then we display it right away
 598
 599          declare
 600             Result_Str_Len : constant Natural :=
 601                                Get_Usage_Range (Result)'Length;
 602             Size_Str_Len   : constant Natural :=
 603                                Natural'Image (Analyzer.Stack_Size)'Length;
 604
 605             Max_Stack_Size_Len : Natural;
 606             Max_Actual_Use_Len : Natural;
 607
 608          begin
 609             --  Take either the label size or the number image size for the
 610             --  size of the column "Stack Size".
 611
 612             Max_Stack_Size_Len :=
 613               (if Size_Str_Len > Stack_Size_Str'Length
 614                then Size_Str_Len
 615                else Stack_Size_Str'Length);
 616
 617             --  Take either the label size or the number image size for the
 618             --  size of the column "Stack Usage".
 619
 620             Max_Actual_Use_Len :=
 621               (if Result_Str_Len > Actual_Size_Str'Length
 622                then Result_Str_Len
 623                else Actual_Size_Str'Length);
 624
 625             Output_Result
 626               (Analyzer.Result_Id,
 627                Result,
 628                Max_Stack_Size_Len,
 629                Max_Actual_Use_Len);
 630          end;
 631       end if;
 632    end Report_Result;
 633
 634 end System.Stack_Usage;