From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/s-stausa.adb | 677 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 677 insertions(+) create mode 100644 gcc/ada/s-stausa.adb (limited to 'gcc/ada/s-stausa.adb') diff --git a/gcc/ada/s-stausa.adb b/gcc/ada/s-stausa.adb new file mode 100644 index 000000000..e85bc46bf --- /dev/null +++ b/gcc/ada/s-stausa.adb @@ -0,0 +1,677 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2010, 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 -- +-- . -- +-- -- +-- 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 | |####| + -- +------------------------------------------------------------------+ + + function Top_Slot_Index_In (Stack : Stack_Slots) return Integer; + -- Index of the stack Top slot in the Slots array, denoting the latest + -- possible slot available to call chain leaves. + + function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer; + -- Index of the stack Bottom slot in the Slots array, denoting the first + -- possible slot available to call chain entry points. + + function Push_Index_Step_For (Stack : Stack_Slots) return Integer; + -- By how much do we need to update a Slots index to Push a single slot on + -- the stack. + + function Pop_Index_Step_For (Stack : Stack_Slots) return Integer; + -- By how much do we need to update a Slots index to Pop a single slot off + -- the stack. + + pragma Inline_Always (Top_Slot_Index_In); + pragma Inline_Always (Bottom_Slot_Index_In); + pragma Inline_Always (Push_Index_Step_For); + pragma Inline_Always (Pop_Index_Step_For); + + ----------------------- + -- Top_Slot_Index_In -- + ----------------------- + + function Top_Slot_Index_In (Stack : Stack_Slots) return Integer is + begin + if System.Parameters.Stack_Grows_Down then + return Stack'First; + else + return Stack'Last; + end if; + end Top_Slot_Index_In; + + ---------------------------- + -- Bottom_Slot_Index_In -- + ---------------------------- + + function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer is + begin + if System.Parameters.Stack_Grows_Down then + return Stack'Last; + else + return Stack'First; + end if; + end Bottom_Slot_Index_In; + + ------------------------- + -- Push_Index_Step_For -- + ------------------------- + + function Push_Index_Step_For (Stack : Stack_Slots) return Integer is + pragma Unreferenced (Stack); + begin + if System.Parameters.Stack_Grows_Down then + return -1; + else + return +1; + end if; + end Push_Index_Step_For; + + ------------------------ + -- Pop_Index_Step_For -- + ------------------------ + + function Pop_Index_Step_For (Stack : Stack_Slots) return Integer is + begin + return -Push_Index_Step_For (Stack); + end Pop_Index_Step_For; + + ------------------- + -- 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"; + + function Get_Usage_Range (Result : Task_Result) return String; + -- Return string representing the range of possible result of 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 + Bottom_Of_Stack : aliased Integer; + 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), + Variation => 0, + Value => 0, + Max_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, + My_Stack_Size, + System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address), + 0); + + 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. + + Stack_Used_When_Filling : Integer; + Current_Stack_Level : aliased Integer; + + Guard : constant Integer := 256; + -- Guard space between the Current_Stack_Level'Address and the last + -- allocated byte on the stack. + + begin + -- Easiest and most accurate method: the top of the stack is known. + + if Analyzer.Top_Pattern_Mark /= 0 then + Analyzer.Pattern_Size := + Stack_Size (Analyzer.Top_Pattern_Mark, + To_Stack_Address (Current_Stack_Level'Address)) + - Guard; + + if System.Parameters.Stack_Grows_Down then + Analyzer.Stack_Overlay_Address := + To_Address (Analyzer.Top_Pattern_Mark); + else + Analyzer.Stack_Overlay_Address := + To_Address (Analyzer.Top_Pattern_Mark + - Stack_Address (Analyzer.Pattern_Size)); + end if; + + declare + Pattern : aliased Stack_Slots + (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + for Pattern'Address use Analyzer.Stack_Overlay_Address; + + begin + if System.Parameters.Stack_Grows_Down then + for J in reverse Pattern'Range loop + Pattern (J) := Analyzer.Pattern; + end loop; + + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Pattern (Pattern'Last)'Address); + + else + for J in Pattern'Range loop + Pattern (J) := Analyzer.Pattern; + end loop; + + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Pattern (Pattern'First)'Address); + end if; + end; + + else + -- Readjust the pattern size. When we arrive in this function, there + -- is already a given amount of stack used, that we won't analyze. + + Stack_Used_When_Filling := + Stack_Size (Analyzer.Bottom_Of_Stack, + To_Stack_Address (Current_Stack_Level'Address)); + + if Stack_Used_When_Filling > Analyzer.Pattern_Size then + + -- In this case, the known size of the stack is too small, we've + -- already taken more than expected, so there's no possible + -- computation + + Analyzer.Pattern_Size := 0; + else + Analyzer.Pattern_Size := + Analyzer.Pattern_Size - Stack_Used_When_Filling; + end if; + + declare + Stack : aliased Stack_Slots + (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + + begin + Stack := (others => Analyzer.Pattern); + + Analyzer.Stack_Overlay_Address := Stack'Address; + + if Analyzer.Pattern_Size /= 0 then + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address + (Stack (Bottom_Slot_Index_In (Stack))'Address); + Analyzer.Top_Pattern_Mark := + To_Stack_Address + (Stack (Top_Slot_Index_In (Stack))'Address); + else + Analyzer.Bottom_Pattern_Mark := + To_Stack_Address (Stack'Address); + Analyzer.Top_Pattern_Mark := + To_Stack_Address (Stack'Address); + end if; + end; + end if; + end Fill_Stack; + + ------------------------- + -- Initialize_Analyzer -- + ------------------------- + + procedure Initialize_Analyzer + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + My_Stack_Size : Natural; + Max_Pattern_Size : Natural; + Bottom : Stack_Address; + Top : Stack_Address; + Pattern : Unsigned_32 := 16#DEAD_BEEF#) + is + begin + -- Initialize the analyzer fields + + Analyzer.Bottom_Of_Stack := Bottom; + Analyzer.Stack_Size := My_Stack_Size; + Analyzer.Pattern_Size := Max_Pattern_Size; + Analyzer.Pattern := Pattern; + Analyzer.Result_Id := Next_Id; + Analyzer.Task_Name := (others => ' '); + Analyzer.Top_Pattern_Mark := Top; + + -- 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 + 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. + + Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + for Stack'Address use Analyzer.Stack_Overlay_Address; + + begin + Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark; + + 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. + + declare + Top_Index : constant Integer := Top_Slot_Index_In (Stack); + Bottom_Index : constant Integer := Bottom_Slot_Index_In (Stack); + Step : constant Integer := Pop_Index_Step_For (Stack); + J : Integer; + + begin + J := Top_Index; + loop + if Stack (J) /= Analyzer.Pattern then + Analyzer.Topmost_Touched_Mark + := To_Stack_Address (Stack (J)'Address); + exit; + end if; + + exit when J = Bottom_Index; + J := J + Step; + end loop; + end; + end Compute_Result; + + --------------------- + -- Get_Usage_Range -- + --------------------- + + function Get_Usage_Range (Result : Task_Result) return String is + Variation_Used_Str : constant String := + Natural'Image (Result.Variation); + Value_Used_Str : constant String := + Natural'Image (Result.Value); + begin + return Value_Used_Str & " +/- " & Variation_Used_Str; + end Get_Usage_Range; + + --------------------- + -- 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); + My_Stack_Size_Str : constant String := Natural'Image (Result.Max_Size); + Actual_Use_Str : constant String := Get_Usage_Range (Result); + + Result_Id_Blanks : constant + String (1 .. Index_Str'Length - Result_Id_Str'Length) := + (others => ' '); + + Stack_Size_Blanks : constant + String (1 .. Max_Stack_Size_Len - My_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 & My_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_Actual_Use_Result_Id : Natural := Result_Array'First; + 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 > + Result_Array (Max_Actual_Use_Result_Id).Value + then + Max_Actual_Use_Result_Id := J; + end if; + + if Result_Array (J).Max_Size > Max_Stack_Size then + Max_Stack_Size := Result_Array (J).Max_Size; + end if; + end loop; + + Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length; + + Max_Actual_Use_Len := + Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'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, + Max_Size => Analyzer.Stack_Size, + Variation => 0, + Value => 0); + + Overflow_Guard : constant Integer := + Analyzer.Stack_Size + - Stack_Size (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Of_Stack); + Max, Min : Positive; + + begin + if Analyzer.Pattern_Size = 0 then + + -- If we have that result, it means that we didn't do any computation + -- at all. In other words, we used at least everything (and possibly + -- more). + + Min := Analyzer.Stack_Size - Overflow_Guard; + Max := Analyzer.Stack_Size; + + else + Min := + Stack_Size + (Analyzer.Topmost_Touched_Mark, Analyzer.Bottom_Of_Stack); + Max := Min + Overflow_Guard; + end if; + + Result.Value := (Max + Min) / 2; + Result.Variation := (Max - Min) / 2; + + 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 := + Get_Usage_Range (Result)'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; -- cgit v1.2.3