------------------------------------------------------------------------------ -- -- -- 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;