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