aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.2.1/gcc/ada/s-stausa.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.2.1/gcc/ada/s-stausa.adb')
-rw-r--r--gcc-4.2.1/gcc/ada/s-stausa.adb330
1 files changed, 330 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/s-stausa.adb b/gcc-4.2.1/gcc/ada/s-stausa.adb
new file mode 100644
index 000000000..bede5a37f
--- /dev/null
+++ b/gcc-4.2.1/gcc/ada/s-stausa.adb
@@ -0,0 +1,330 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;