path: root/gcc/ada/s-stausa.adb

------------------------------------------------------------------------------
--                                                                          --
--                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--                   S Y S T E M - S T A C K _ U S A G E                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 2004-2006, Free Software Foundation, Inc.          --
--                                                                          --
-- GNARL is free software; you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNARL; see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
------------------------------------------------------------------------------

with System.Parameters;
with System.CRTL;
with System.IO;

package body System.Stack_Usage is
   use System.Storage_Elements;
   use System;
   use System.IO;

   procedure Output_Result (Result_Id : Natural; Result : Task_Result);

   function Report_Result (Analyzer : Stack_Analyzer) return Natural;

   function Inner_Than
     (A1 : Stack_Address;
      A2 : Stack_Address) return Boolean;
   pragma Inline (Inner_Than);
   --  Return True if, according to the direction of the stack growth, A1 is
   --  inner than A2. Inlined to reduce the size of the stack used by the
   --  instrumentation code.

   ----------------
   -- Inner_Than --
   ----------------

   function Inner_Than
     (A1 : Stack_Address;
      A2 : Stack_Address) return Boolean
   is
   begin
      if System.Parameters.Stack_Grows_Down then
         return A1 > A2;
      else
         return A2 > A1;
      end if;
   end Inner_Than;

   ----------------
   -- Initialize --
   ----------------

   --  Add comments to this procedure ???
   --  Other subprograms also need more comment in code???

   procedure Initialize (Buffer_Size : Natural) is
      Bottom_Of_Stack : aliased Integer;

      Stack_Size_Chars : System.Address;
   begin
      Result_Array := new Result_Array_Type (1 .. Buffer_Size);
      Result_Array.all :=
        (others =>
           (Task_Name =>
              (others => ASCII.NUL),
            Measure => 0,
            Max_Size => 0));

      Is_Enabled := True;

      Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);

      --  If variable GNAT_STACK_LIMIT is set, then we will take care of the
      --  environment task, using GNAT_STASK_LIMIT as the size of the stack.
      --  It doens't make sens to process the stack when no bound is set (e.g.
      --  limit is typically up to 4 GB).

      if Stack_Size_Chars /= Null_Address then
         declare
            Stack_Size : Integer;

         begin
            Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;

            Initialize_Analyzer (Environment_Task_Analyzer,
                                 "ENVIRONMENT TASK",
                                 Stack_Size,
                                 System.Storage_Elements.To_Integer
                                   (Bottom_Of_Stack'Address));

            Fill_Stack (Environment_Task_Analyzer);

            Compute_Environment_Task := True;
         end;

      --  GNAT_STACK_LIMIT not set

      else
         Compute_Environment_Task := False;
      end if;
   end Initialize;

   ----------------
   -- Fill_Stack --
   ----------------

   procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is

      --  Change the local variables and parameters of this function with
      --  super-extra care. The more the stack frame size of this function is
      --  big, the more an "instrumentation threshold at writing" error is
      --  likely to happen.

      type Word_32_Arr is
        array (1 .. Analyzer.Size / (Word_32_Size / Byte_Size)) of Word_32;
      pragma Pack (Word_32_Arr);

      package Arr_Addr is
        new System.Address_To_Access_Conversions (Word_32_Arr);

      Arr : aliased Word_32_Arr;

   begin
      for J in Word_32_Arr'Range loop
         Arr (J) := Analyzer.Pattern;
      end loop;
      Analyzer.Array_Address := Arr_Addr.To_Address (Arr'Access);
      Analyzer.Inner_Pattern_Mark := To_Stack_Address (Arr (1)'Address);
      Analyzer.Outer_Pattern_Mark :=
        To_Stack_Address (Arr (Word_32_Arr'Last)'Address);

      if Inner_Than (Analyzer.Outer_Pattern_Mark,
                     Analyzer.Inner_Pattern_Mark) then
         Analyzer.Inner_Pattern_Mark := Analyzer.Outer_Pattern_Mark;
         Analyzer.Outer_Pattern_Mark := To_Stack_Address (Arr (1)'Address);
         Analyzer.First_Is_Outermost := True;
      else
         Analyzer.First_Is_Outermost := False;
      end if;

      --  If Arr has been packed, the following assertion must be true (we add
      --  the size of the element whose address is:
      --
      --    Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):

      pragma Assert
        (Analyzer.Size =
           Stack_Size
             (Analyzer.Outer_Pattern_Mark, Analyzer.Inner_Pattern_Mark) +
           Word_32_Size / Byte_Size);
   end Fill_Stack;

   -------------------------
   -- Initialize_Analyzer --
   -------------------------

   procedure Initialize_Analyzer
     (Analyzer  : in out Stack_Analyzer;
      Task_Name : String;
      Size      : Natural;
      Bottom    : Stack_Address;
      Pattern   : Word_32 := 16#DEAD_BEEF#)
   is
   begin
      Analyzer.Bottom_Of_Stack := Bottom;
      Analyzer.Size := Size;
      Analyzer.Pattern := Pattern;
      Analyzer.Result_Id := Next_Id;

      Analyzer.Task_Name := (others => ' ');

      if Task_Name'Length <= Task_Name_Length then
         Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
      else
         Analyzer.Task_Name :=
           Task_Name (Task_Name'First ..
                        Task_Name'First + Task_Name_Length - 1);
      end if;

      if Next_Id in Result_Array'Range then
         Result_Array (Analyzer.Result_Id).Task_Name := Analyzer.Task_Name;
      end if;

      Result_Array (Analyzer.Result_Id).Max_Size := Size;
      Next_Id := Next_Id + 1;
   end Initialize_Analyzer;

   ----------------
   -- Stack_Size --
   ----------------

   function Stack_Size
     (SP_Low  : Stack_Address;
      SP_High : Stack_Address) return Natural
   is
   begin
      if SP_Low > SP_High then
         return Natural (SP_Low - SP_High + 4);
      else
         return Natural (SP_High - SP_Low + 4);
      end if;
   end Stack_Size;

   --------------------
   -- Compute_Result --
   --------------------

   procedure Compute_Result (Analyzer : in out Stack_Analyzer) is

      --  Change the local variables and parameters of this function with
      --  super-extra care. The larger the stack frame size of this function
      --  is, the more an "instrumentation threshold at reading" error is
      --  likely to happen.

      type Word_32_Arr is
        array (1 .. Analyzer.Size / (Word_32_Size / Byte_Size)) of Word_32;
      pragma Pack (Word_32_Arr);

      package Arr_Addr is
        new System.Address_To_Access_Conversions (Word_32_Arr);

      Arr_Access : Arr_Addr.Object_Pointer;

   begin
      Arr_Access := Arr_Addr.To_Pointer (Analyzer.Array_Address);
      Analyzer.Outermost_Touched_Mark := Analyzer.Inner_Pattern_Mark;

      for J in Word_32_Arr'Range loop
         if Arr_Access (J) /= Analyzer.Pattern then
            Analyzer.Outermost_Touched_Mark :=
              To_Stack_Address (Arr_Access (J)'Address);

            if Analyzer.First_Is_Outermost then
               exit;
            end if;
         end if;
      end loop;
   end Compute_Result;

   ---------------------
   --  Output_Result --
   ---------------------

   procedure Output_Result (Result_Id : Natural; Result : Task_Result) is
   begin
      Set_Output (Standard_Error);
      Put (Natural'Image (Result_Id));
      Put (" | ");
      Put (Result.Task_Name);
      Put (" | ");
      Put (Natural'Image (Result.Max_Size));
      Put (" | ");
      Put (Natural'Image (Result.Measure));
      New_Line;
   end Output_Result;

   ---------------------
   --  Output_Results --
   ---------------------

   procedure Output_Results is
   begin
      if Compute_Environment_Task then
         Compute_Result (Environment_Task_Analyzer);
         Report_Result (Environment_Task_Analyzer);
      end if;

      Set_Output (Standard_Error);
      Put ("Index | Task Name | Stack Size | Actual Use");
      New_Line;

      for J in Result_Array'Range loop
         exit when J >= Next_Id;

         Output_Result (J, Result_Array (J));
      end loop;
   end Output_Results;

   -------------------
   -- Report_Result --
   -------------------

   procedure Report_Result (Analyzer : Stack_Analyzer) is
   begin
      if Analyzer.Result_Id in Result_Array'Range then
         Result_Array (Analyzer.Result_Id).Measure := Report_Result (Analyzer);
      else
         Output_Result
           (Analyzer.Result_Id,
            (Task_Name => Analyzer.Task_Name,
             Max_Size  => Analyzer.Size,
             Measure   => Report_Result (Analyzer)));
      end if;
   end Report_Result;

   function Report_Result (Analyzer : Stack_Analyzer) return Natural is
   begin
      if Analyzer.Outermost_Touched_Mark = Analyzer.Inner_Pattern_Mark then
         return Stack_Size (Analyzer.Inner_Pattern_Mark,
                            Analyzer.Bottom_Of_Stack);

      else
         return Stack_Size (Analyzer.Outermost_Touched_Mark,
                            Analyzer.Bottom_Of_Stack);
      end if;
   end Report_Result;

end System.Stack_Usage;