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