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, 0 insertions, 330 deletions
diff --git a/gcc-4.2.1/gcc/ada/s-stausa.adb b/gcc-4.2.1/gcc/ada/s-stausa.adb deleted file mode 100644 index bede5a37f..000000000 --- a/gcc-4.2.1/gcc/ada/s-stausa.adb +++ /dev/null @@ -1,330 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |