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-2006, 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
  43    procedure Output_Result (Result_Id : Natural; Result : Task_Result);
  44
  45    function Report_Result (Analyzer : Stack_Analyzer) return Natural;
  46
  47    function Inner_Than
  48      (A1 : Stack_Address;
  49       A2 : Stack_Address) return Boolean;
  50    pragma Inline (Inner_Than);
  51    --  Return True if, according to the direction of the stack growth, A1 is
  52    --  inner than A2. Inlined to reduce the size of the stack used by the
  53    --  instrumentation code.
  54
  55    ----------------
  56    -- Inner_Than --
  57    ----------------
  58
  59    function Inner_Than
  60      (A1 : Stack_Address;
  61       A2 : Stack_Address) return Boolean
  62    is
  63    begin
  64       if System.Parameters.Stack_Grows_Down then
  65          return A1 > A2;
  66       else
  67          return A2 > A1;
  68       end if;
  69    end Inner_Than;
  70
  71    ----------------
  72    -- Initialize --
  73    ----------------
  74
  75    --  Add comments to this procedure ???
  76    --  Other subprograms also need more comment in code???
  77
  78    procedure Initialize (Buffer_Size : Natural) is
  79       Bottom_Of_Stack : aliased Integer;
  80
  81       Stack_Size_Chars : System.Address;
  82    begin
  83       Result_Array := new Result_Array_Type (1 .. Buffer_Size);
  84       Result_Array.all :=
  85         (others =>
  86            (Task_Name =>
  87               (others => ASCII.NUL),
  88             Measure => 0,
  89             Max_Size => 0));
  90
  91       Is_Enabled := True;
  92
  93       Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
  94
  95       --  If variable GNAT_STACK_LIMIT is set, then we will take care of the
  96       --  environment task, using GNAT_STASK_LIMIT as the size of the stack.
  97       --  It doens't make sens to process the stack when no bound is set (e.g.
  98       --  limit is typically up to 4 GB).
  99
 100       if Stack_Size_Chars /= Null_Address then
 101          declare
 102             Stack_Size : Integer;
 103
 104          begin
 105             Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
 106
 107             Initialize_Analyzer (Environment_Task_Analyzer,
 108                                  "ENVIRONMENT TASK",
 109                                  Stack_Size,
 110                                  System.Storage_Elements.To_Integer
 111                                    (Bottom_Of_Stack'Address));
 112
 113             Fill_Stack (Environment_Task_Analyzer);
 114
 115             Compute_Environment_Task := True;
 116          end;
 117
 118       --  GNAT_STACK_LIMIT not set
 119
 120       else
 121          Compute_Environment_Task := False;
 122       end if;
 123    end Initialize;
 124
 125    ----------------
 126    -- Fill_Stack --
 127    ----------------
 128
 129    procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is
 130
 131       --  Change the local variables and parameters of this function with
 132       --  super-extra care. The more the stack frame size of this function is
 133       --  big, the more an "instrumentation threshold at writing" error is
 134       --  likely to happen.
 135
 136       type Word_32_Arr is
 137         array (1 .. Analyzer.Size / (Word_32_Size / Byte_Size)) of Word_32;
 138       pragma Pack (Word_32_Arr);
 139
 140       package Arr_Addr is
 141         new System.Address_To_Access_Conversions (Word_32_Arr);
 142
 143       Arr : aliased Word_32_Arr;
 144
 145    begin
 146       for J in Word_32_Arr'Range loop
 147          Arr (J) := Analyzer.Pattern;
 148       end loop;
 149       Analyzer.Array_Address := Arr_Addr.To_Address (Arr'Access);
 150       Analyzer.Inner_Pattern_Mark := To_Stack_Address (Arr (1)'Address);
 151       Analyzer.Outer_Pattern_Mark :=
 152         To_Stack_Address (Arr (Word_32_Arr'Last)'Address);
 153
 154       if Inner_Than (Analyzer.Outer_Pattern_Mark,
 155                      Analyzer.Inner_Pattern_Mark) then
 156          Analyzer.Inner_Pattern_Mark := Analyzer.Outer_Pattern_Mark;
 157          Analyzer.Outer_Pattern_Mark := To_Stack_Address (Arr (1)'Address);
 158          Analyzer.First_Is_Outermost := True;
 159       else
 160          Analyzer.First_Is_Outermost := False;
 161       end if;
 162
 163       --  If Arr has been packed, the following assertion must be true (we add
 164       --  the size of the element whose address is:
 165       --
 166       --    Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):
 167
 168       pragma Assert
 169         (Analyzer.Size =
 170            Stack_Size
 171              (Analyzer.Outer_Pattern_Mark, Analyzer.Inner_Pattern_Mark) +
 172            Word_32_Size / Byte_Size);
 173    end Fill_Stack;
 174
 175    -------------------------
 176    -- Initialize_Analyzer --
 177    -------------------------
 178
 179    procedure Initialize_Analyzer
 180      (Analyzer  : in out Stack_Analyzer;
 181       Task_Name : String;
 182       Size      : Natural;
 183       Bottom    : Stack_Address;
 184       Pattern   : Word_32 := 16#DEAD_BEEF#)
 185    is
 186    begin
 187       Analyzer.Bottom_Of_Stack := Bottom;
 188       Analyzer.Size := Size;
 189       Analyzer.Pattern := Pattern;
 190       Analyzer.Result_Id := Next_Id;
 191
 192       Analyzer.Task_Name := (others => ' ');
 193
 194       if Task_Name'Length <= Task_Name_Length then
 195          Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
 196       else
 197          Analyzer.Task_Name :=
 198            Task_Name (Task_Name'First ..
 199                         Task_Name'First + Task_Name_Length - 1);
 200       end if;
 201
 202       if Next_Id in Result_Array'Range then
 203          Result_Array (Analyzer.Result_Id).Task_Name := Analyzer.Task_Name;
 204       end if;
 205
 206       Result_Array (Analyzer.Result_Id).Max_Size := Size;
 207       Next_Id := Next_Id + 1;
 208    end Initialize_Analyzer;
 209
 210    ----------------
 211    -- Stack_Size --
 212    ----------------
 213
 214    function Stack_Size
 215      (SP_Low  : Stack_Address;
 216       SP_High : Stack_Address) return Natural
 217    is
 218    begin
 219       if SP_Low > SP_High then
 220          return Natural (SP_Low - SP_High + 4);
 221       else
 222          return Natural (SP_High - SP_Low + 4);
 223       end if;
 224    end Stack_Size;
 225
 226    --------------------
 227    -- Compute_Result --
 228    --------------------
 229
 230    procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
 231
 232       --  Change the local variables and parameters of this function with
 233       --  super-extra care. The larger the stack frame size of this function
 234       --  is, the more an "instrumentation threshold at reading" error is
 235       --  likely to happen.
 236
 237       type Word_32_Arr is
 238         array (1 .. Analyzer.Size / (Word_32_Size / Byte_Size)) of Word_32;
 239       pragma Pack (Word_32_Arr);
 240
 241       package Arr_Addr is
 242         new System.Address_To_Access_Conversions (Word_32_Arr);
 243
 244       Arr_Access : Arr_Addr.Object_Pointer;
 245
 246    begin
 247       Arr_Access := Arr_Addr.To_Pointer (Analyzer.Array_Address);
 248       Analyzer.Outermost_Touched_Mark := Analyzer.Inner_Pattern_Mark;
 249
 250       for J in Word_32_Arr'Range loop
 251          if Arr_Access (J) /= Analyzer.Pattern then
 252             Analyzer.Outermost_Touched_Mark :=
 253               To_Stack_Address (Arr_Access (J)'Address);
 254
 255             if Analyzer.First_Is_Outermost then
 256                exit;
 257             end if;
 258          end if;
 259       end loop;
 260    end Compute_Result;
 261
 262    ---------------------
 263    --  Output_Result --
 264    ---------------------
 265
 266    procedure Output_Result (Result_Id : Natural; Result : Task_Result) is
 267    begin
 268       Set_Output (Standard_Error);
 269       Put (Natural'Image (Result_Id));
 270       Put (" | ");
 271       Put (Result.Task_Name);
 272       Put (" | ");
 273       Put (Natural'Image (Result.Max_Size));
 274       Put (" | ");
 275       Put (Natural'Image (Result.Measure));
 276       New_Line;
 277    end Output_Result;
 278
 279    ---------------------
 280    --  Output_Results --
 281    ---------------------
 282
 283    procedure Output_Results is
 284    begin
 285       if Compute_Environment_Task then
 286          Compute_Result (Environment_Task_Analyzer);
 287          Report_Result (Environment_Task_Analyzer);
 288       end if;
 289
 290       Set_Output (Standard_Error);
 291       Put ("Index | Task Name | Stack Size | Actual Use");
 292       New_Line;
 293
 294       for J in Result_Array'Range loop
 295          exit when J >= Next_Id;
 296
 297          Output_Result (J, Result_Array (J));
 298       end loop;
 299    end Output_Results;
 300
 301    -------------------
 302    -- Report_Result --
 303    -------------------
 304
 305    procedure Report_Result (Analyzer : Stack_Analyzer) is
 306    begin
 307       if Analyzer.Result_Id in Result_Array'Range then
 308          Result_Array (Analyzer.Result_Id).Measure := Report_Result (Analyzer);
 309       else
 310          Output_Result
 311            (Analyzer.Result_Id,
 312             (Task_Name => Analyzer.Task_Name,
 313              Max_Size  => Analyzer.Size,
 314              Measure   => Report_Result (Analyzer)));
 315       end if;
 316    end Report_Result;
 317
 318    function Report_Result (Analyzer : Stack_Analyzer) return Natural is
 319    begin
 320       if Analyzer.Outermost_Touched_Mark = Analyzer.Inner_Pattern_Mark then
 321          return Stack_Size (Analyzer.Inner_Pattern_Mark,
 322                             Analyzer.Bottom_Of_Stack);
 323
 324       else
 325          return Stack_Size (Analyzer.Outermost_Touched_Mark,
 326                             Analyzer.Bottom_Of_Stack);
 327       end if;
 328    end Report_Result;
 329
 330 end System.Stack_Usage;