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