diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/s-stausa.adb')
-rw-r--r-- | gcc-4.2.1/gcc/ada/s-stausa.adb | 330 |
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; |