aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.1/gcc/ada/s-stausa.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.1/gcc/ada/s-stausa.adb')
-rw-r--r--gcc-4.8.1/gcc/ada/s-stausa.adb566
1 files changed, 566 insertions, 0 deletions
diff --git a/gcc-4.8.1/gcc/ada/s-stausa.adb b/gcc-4.8.1/gcc/ada/s-stausa.adb
new file mode 100644
index 000000000..6ccc386c7
--- /dev/null
+++ b/gcc-4.8.1/gcc/ada/s-stausa.adb
@@ -0,0 +1,566 @@
+------------------------------------------------------------------------------
+-- --
+-- 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-2011, 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 3, or (at your option) any later ver- --
+-- sion. GNAT 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
+ use Interfaces;
+
+ -----------------
+ -- Stack_Slots --
+ -----------------
+
+ -- Stackl_Slots is an internal data type to represent a sequence of real
+ -- stack slots initialized with a provided pattern, with operations to
+ -- abstract away the target call stack growth direction.
+
+ type Stack_Slots is array (Integer range <>) of Pattern_Type;
+ for Stack_Slots'Component_Size use Pattern_Type'Object_Size;
+
+ -- We will carefully handle the initializations ourselves and might want
+ -- to remap an initialized overlay later on with an address clause.
+
+ pragma Suppress_Initialization (Stack_Slots);
+
+ -- The abstract Stack_Slots operations all operate over the simple array
+ -- memory model:
+
+ -- memory addresses increasing ---->
+
+ -- Slots('First) Slots('Last)
+ -- | |
+ -- V V
+ -- +------------------------------------------------------------------+
+ -- |####| |####|
+ -- +------------------------------------------------------------------+
+
+ -- What we call Top or Bottom always denotes call chain leaves or entry
+ -- points respectively, and their relative positions in the stack array
+ -- depends on the target stack growth direction:
+
+ -- Stack_Grows_Down
+
+ -- <----- calls push frames towards decreasing addresses
+
+ -- Top(most) Slot Bottom(most) Slot
+ -- | |
+ -- V V
+ -- +------------------------------------------------------------------+
+ -- |####| | leaf frame | ... | entry frame |
+ -- +------------------------------------------------------------------+
+
+ -- Stack_Grows_Up
+
+ -- calls push frames towards increasing addresses ----->
+
+ -- Bottom(most) Slot Top(most) Slot
+ -- | |
+ -- V V
+ -- +------------------------------------------------------------------+
+ -- | entry frame | ... | leaf frame | |####|
+ -- +------------------------------------------------------------------+
+
+ -------------------
+ -- Unit Services --
+ -------------------
+
+ -- Now the implementation of the services offered by this unit, on top of
+ -- the Stack_Slots abstraction above.
+
+ Index_Str : constant String := "Index";
+ Task_Name_Str : constant String := "Task Name";
+ Stack_Size_Str : constant String := "Stack Size";
+ Actual_Size_Str : constant String := "Stack usage";
+
+ procedure Output_Result
+ (Result_Id : Natural;
+ Result : Task_Result;
+ Max_Stack_Size_Len : Natural;
+ Max_Actual_Use_Len : Natural);
+ -- Prints the result on the standard output. Result Id is the number of
+ -- the result in the array, and Result the contents of the actual result.
+ -- Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
+ -- proper layout. They hold the maximum length of the string representing
+ -- the Stack_Size and Actual_Use values.
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Buffer_Size : Natural) is
+ Stack_Size_Chars : System.Address;
+
+ begin
+ -- Initialize the buffered result array
+
+ Result_Array := new Result_Array_Type (1 .. Buffer_Size);
+ Result_Array.all :=
+ (others =>
+ (Task_Name => (others => ASCII.NUL),
+ Value => 0,
+ Stack_Size => 0));
+
+ -- Set the Is_Enabled flag to true, so that the task wrapper knows that
+ -- it has to handle dynamic stack analysis
+
+ 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 doesn'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
+ My_Stack_Size : Integer;
+
+ begin
+ My_Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
+
+ Initialize_Analyzer
+ (Environment_Task_Analyzer,
+ "ENVIRONMENT TASK",
+ My_Stack_Size,
+ 0,
+ My_Stack_Size);
+
+ 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.
+
+ Current_Stack_Level : aliased Integer;
+
+ Guard : constant := 256;
+ -- Guard space between the Current_Stack_Level'Address and the last
+ -- allocated byte on the stack.
+ begin
+ if Parameters.Stack_Grows_Down then
+ if Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size) >
+ To_Stack_Address (Current_Stack_Level'Address) - Guard
+ then
+ -- No room for a pattern
+
+ Analyzer.Pattern_Size := 0;
+ return;
+ end if;
+
+ Analyzer.Pattern_Limit :=
+ Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size);
+
+ if Analyzer.Stack_Base >
+ To_Stack_Address (Current_Stack_Level'Address) - Guard
+ then
+ -- Reduce pattern size to prevent local frame overwrite
+
+ Analyzer.Pattern_Size :=
+ Integer (To_Stack_Address (Current_Stack_Level'Address) - Guard
+ - Analyzer.Pattern_Limit);
+ end if;
+
+ Analyzer.Pattern_Overlay_Address :=
+ To_Address (Analyzer.Pattern_Limit);
+ else
+ if Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size) <
+ To_Stack_Address (Current_Stack_Level'Address) + Guard
+ then
+ -- No room for a pattern
+
+ Analyzer.Pattern_Size := 0;
+ return;
+ end if;
+
+ Analyzer.Pattern_Limit :=
+ Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size);
+
+ if Analyzer.Stack_Base <
+ To_Stack_Address (Current_Stack_Level'Address) + Guard
+ then
+ -- Reduce pattern size to prevent local frame overwrite
+
+ Analyzer.Pattern_Size :=
+ Integer
+ (Analyzer.Pattern_Limit -
+ (To_Stack_Address (Current_Stack_Level'Address) + Guard));
+ end if;
+
+ Analyzer.Pattern_Overlay_Address :=
+ To_Address (Analyzer.Pattern_Limit -
+ Stack_Address (Analyzer.Pattern_Size));
+ end if;
+
+ -- Declare and fill the pattern buffer
+
+ declare
+ Pattern : aliased Stack_Slots
+ (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
+ for Pattern'Address use Analyzer.Pattern_Overlay_Address;
+
+ begin
+ if System.Parameters.Stack_Grows_Down then
+ for J in reverse Pattern'Range loop
+ Pattern (J) := Analyzer.Pattern;
+ end loop;
+
+ else
+ for J in Pattern'Range loop
+ Pattern (J) := Analyzer.Pattern;
+ end loop;
+ end if;
+ end;
+ end Fill_Stack;
+
+ -------------------------
+ -- Initialize_Analyzer --
+ -------------------------
+
+ procedure Initialize_Analyzer
+ (Analyzer : in out Stack_Analyzer;
+ Task_Name : String;
+ Stack_Size : Natural;
+ Stack_Base : Stack_Address;
+ Pattern_Size : Natural;
+ Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#)
+ is
+ begin
+ -- Initialize the analyzer fields
+
+ Analyzer.Stack_Base := Stack_Base;
+ Analyzer.Stack_Size := Stack_Size;
+ Analyzer.Pattern_Size := Pattern_Size;
+ Analyzer.Pattern := Pattern;
+ Analyzer.Result_Id := Next_Id;
+ Analyzer.Task_Name := (others => ' ');
+
+ -- Compute the task name, and truncate if bigger than Task_Name_Length
+
+ 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;
+
+ 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);
+ else
+ return Natural (SP_High - SP_Low);
+ 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.
+
+ Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
+ for Stack'Address use Analyzer.Pattern_Overlay_Address;
+
+ begin
+ -- Value if the pattern was not modified
+
+ if Parameters.Stack_Grows_Down then
+ Analyzer.Topmost_Touched_Mark :=
+ Analyzer.Pattern_Limit + Stack_Address (Analyzer.Pattern_Size);
+ else
+ Analyzer.Topmost_Touched_Mark :=
+ Analyzer.Pattern_Limit - Stack_Address (Analyzer.Pattern_Size);
+ end if;
+
+ if Analyzer.Pattern_Size = 0 then
+ return;
+ end if;
+
+ -- Look backward from the topmost possible end of the marked stack to
+ -- the bottom of it. The first index not equals to the patterns marks
+ -- the beginning of the used stack.
+
+ if System.Parameters.Stack_Grows_Down then
+ for J in Stack'Range loop
+ if Stack (J) /= Analyzer.Pattern then
+ Analyzer.Topmost_Touched_Mark :=
+ To_Stack_Address (Stack (J)'Address);
+ exit;
+ end if;
+ end loop;
+
+ else
+ for J in reverse Stack'Range loop
+ if Stack (J) /= Analyzer.Pattern then
+ Analyzer.Topmost_Touched_Mark :=
+ To_Stack_Address (Stack (J)'Address);
+ exit;
+ end if;
+ end loop;
+
+ end if;
+ end Compute_Result;
+
+ ---------------------
+ -- Output_Result --
+ ---------------------
+
+ procedure Output_Result
+ (Result_Id : Natural;
+ Result : Task_Result;
+ Max_Stack_Size_Len : Natural;
+ Max_Actual_Use_Len : Natural)
+ is
+ Result_Id_Str : constant String := Natural'Image (Result_Id);
+ Stack_Size_Str : constant String := Natural'Image (Result.Stack_Size);
+ Actual_Use_Str : constant String := Natural'Image (Result.Value);
+
+ Result_Id_Blanks : constant
+ String (1 .. Index_Str'Length - Result_Id_Str'Length) :=
+ (others => ' ');
+
+ Stack_Size_Blanks : constant
+ String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
+ (others => ' ');
+
+ Actual_Use_Blanks : constant
+ String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
+ (others => ' ');
+
+ begin
+ Set_Output (Standard_Error);
+ Put (Result_Id_Blanks & Natural'Image (Result_Id));
+ Put (" | ");
+ Put (Result.Task_Name);
+ Put (" | ");
+ Put (Stack_Size_Blanks & Stack_Size_Str);
+ Put (" | ");
+ Put (Actual_Use_Blanks & Actual_Use_Str);
+ New_Line;
+ end Output_Result;
+
+ ---------------------
+ -- Output_Results --
+ ---------------------
+
+ procedure Output_Results is
+ Max_Stack_Size : Natural := 0;
+ Max_Stack_Usage : Natural := 0;
+ Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
+
+ Task_Name_Blanks : constant
+ String
+ (1 .. Task_Name_Length - Task_Name_Str'Length) :=
+ (others => ' ');
+
+ begin
+ Set_Output (Standard_Error);
+
+ if Compute_Environment_Task then
+ Compute_Result (Environment_Task_Analyzer);
+ Report_Result (Environment_Task_Analyzer);
+ end if;
+
+ if Result_Array'Length > 0 then
+
+ -- Computes the size of the largest strings that will get displayed,
+ -- in order to do correct column alignment.
+
+ for J in Result_Array'Range loop
+ exit when J >= Next_Id;
+
+ if Result_Array (J).Value > Max_Stack_Usage then
+ Max_Stack_Usage := Result_Array (J).Value;
+ end if;
+
+ if Result_Array (J).Stack_Size > Max_Stack_Size then
+ Max_Stack_Size := Result_Array (J).Stack_Size;
+ end if;
+ end loop;
+
+ Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
+
+ Max_Actual_Use_Len := Natural'Image (Max_Stack_Usage)'Length;
+
+ -- Display the output header. Blanks will be added in front of the
+ -- labels if needed.
+
+ declare
+ Stack_Size_Blanks : constant
+ String (1 .. Max_Stack_Size_Len -
+ Stack_Size_Str'Length) :=
+ (others => ' ');
+
+ Stack_Usage_Blanks : constant
+ String (1 .. Max_Actual_Use_Len -
+ Actual_Size_Str'Length) :=
+ (others => ' ');
+
+ begin
+ if Stack_Size_Str'Length > Max_Stack_Size_Len then
+ Max_Stack_Size_Len := Stack_Size_Str'Length;
+ end if;
+
+ if Actual_Size_Str'Length > Max_Actual_Use_Len then
+ Max_Actual_Use_Len := Actual_Size_Str'Length;
+ end if;
+
+ Put
+ (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
+ & Stack_Size_Str & Stack_Size_Blanks & " | "
+ & Stack_Usage_Blanks & Actual_Size_Str);
+ end;
+
+ New_Line;
+
+ -- Now display the individual results
+
+ for J in Result_Array'Range loop
+ exit when J >= Next_Id;
+ Output_Result
+ (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
+ end loop;
+
+ -- Case of no result stored, still display the labels
+
+ else
+ Put
+ (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
+ & Stack_Size_Str & " | " & Actual_Size_Str);
+ New_Line;
+ end if;
+ end Output_Results;
+
+ -------------------
+ -- Report_Result --
+ -------------------
+
+ procedure Report_Result (Analyzer : Stack_Analyzer) is
+ Result : Task_Result := (Task_Name => Analyzer.Task_Name,
+ Stack_Size => Analyzer.Stack_Size,
+ Value => 0);
+ begin
+ if Analyzer.Pattern_Size = 0 then
+
+ -- If we have that result, it means that we didn't do any computation
+ -- at all (i.e. we used at least everything (and possibly more).
+
+ Result.Value := Analyzer.Stack_Size;
+
+ else
+ Result.Value := Stack_Size (Analyzer.Topmost_Touched_Mark,
+ Analyzer.Stack_Base);
+ end if;
+
+ if Analyzer.Result_Id in Result_Array'Range then
+
+ -- If the result can be stored, then store it in Result_Array
+
+ Result_Array (Analyzer.Result_Id) := Result;
+
+ else
+ -- If the result cannot be stored, then we display it right away
+
+ declare
+ Result_Str_Len : constant Natural :=
+ Natural'Image (Result.Value)'Length;
+ Size_Str_Len : constant Natural :=
+ Natural'Image (Analyzer.Stack_Size)'Length;
+
+ Max_Stack_Size_Len : Natural;
+ Max_Actual_Use_Len : Natural;
+
+ begin
+ -- Take either the label size or the number image size for the
+ -- size of the column "Stack Size".
+
+ Max_Stack_Size_Len :=
+ (if Size_Str_Len > Stack_Size_Str'Length
+ then Size_Str_Len
+ else Stack_Size_Str'Length);
+
+ -- Take either the label size or the number image size for the
+ -- size of the column "Stack Usage".
+
+ Max_Actual_Use_Len :=
+ (if Result_Str_Len > Actual_Size_Str'Length
+ then Result_Str_Len
+ else Actual_Size_Str'Length);
+
+ Output_Result
+ (Analyzer.Result_Id,
+ Result,
+ Max_Stack_Size_Len,
+ Max_Actual_Use_Len);
+ end;
+ end if;
+ end Report_Result;
+
+end System.Stack_Usage;