1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M - S T A C K _ U S A G E --
9 -- Copyright (C) 2004-2008, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 with System
.Parameters
;
38 package body System
.Stack_Usage
is
39 use System
.Storage_Elements
;
48 -- Stackl_Slots is an internal data type to represent a sequence of real
49 -- stack slots initialized with a provided pattern, with operations to
50 -- abstract away the target call stack growth direction.
52 type Stack_Slots
is array (Integer range <>) of Pattern_Type
;
53 for Stack_Slots
'Component_Size use Pattern_Type
'Object_Size;
55 -- We will carefully handle the initializations ourselves and might want
56 -- to remap an initialized overlay later on with an address clause.
58 pragma Suppress_Initialization
(Stack_Slots
);
60 -- The abstract Stack_Slots operations all operate over the simple array
63 -- memory addresses increasing ---->
65 -- Slots('First) Slots('Last)
68 -- +------------------------------------------------------------------+
70 -- +------------------------------------------------------------------+
72 -- What we call Top or Bottom always denotes call chain leaves or entry
73 -- points respectively, and their relative positions in the stack array
74 -- depends on the target stack growth direction:
78 -- <----- calls push frames towards decreasing addresses
80 -- Top(most) Slot Bottom(most) Slot
83 -- +------------------------------------------------------------------+
84 -- |####| | leaf frame | ... | entry frame |
85 -- +------------------------------------------------------------------+
89 -- calls push frames towards increasing addresses ----->
91 -- Bottom(most) Slot Top(most) Slot
94 -- +------------------------------------------------------------------+
95 -- | entry frame | ... | leaf frame | |####|
96 -- +------------------------------------------------------------------+
98 function Top_Slot_Index_In
(Stack
: Stack_Slots
) return Integer;
99 -- Index of the stack Top slot in the Slots array, denoting the latest
100 -- possible slot available to call chain leaves.
102 function Bottom_Slot_Index_In
(Stack
: Stack_Slots
) return Integer;
103 -- Index of the stack Bottom slot in the Slots array, denoting the first
104 -- possible slot available to call chain entry points.
106 function Push_Index_Step_For
(Stack
: Stack_Slots
) return Integer;
107 -- By how much do we need to update a Slots index to Push a single slot on
110 function Pop_Index_Step_For
(Stack
: Stack_Slots
) return Integer;
111 -- By how much do we need to update a Slots index to Pop a single slot off
114 pragma Inline_Always
(Top_Slot_Index_In
);
115 pragma Inline_Always
(Bottom_Slot_Index_In
);
116 pragma Inline_Always
(Push_Index_Step_For
);
117 pragma Inline_Always
(Pop_Index_Step_For
);
119 -----------------------
120 -- Top_Slot_Index_In --
121 -----------------------
123 function Top_Slot_Index_In
(Stack
: Stack_Slots
) return Integer is
125 if System
.Parameters
.Stack_Grows_Down
then
130 end Top_Slot_Index_In
;
132 ----------------------------
133 -- Bottom_Slot_Index_In --
134 ----------------------------
136 function Bottom_Slot_Index_In
(Stack
: Stack_Slots
) return Integer is
138 if System
.Parameters
.Stack_Grows_Down
then
143 end Bottom_Slot_Index_In
;
145 -------------------------
146 -- Push_Index_Step_For --
147 -------------------------
149 function Push_Index_Step_For
(Stack
: Stack_Slots
) return Integer is
150 pragma Unreferenced
(Stack
);
152 if System
.Parameters
.Stack_Grows_Down
then
157 end Push_Index_Step_For
;
159 ------------------------
160 -- Pop_Index_Step_For --
161 ------------------------
163 function Pop_Index_Step_For
(Stack
: Stack_Slots
) return Integer is
165 return -Push_Index_Step_For
(Stack
);
166 end Pop_Index_Step_For
;
172 -- Now the implementation of the services offered by this unit, on top of
173 -- the Stack_Slots abstraction above.
175 Index_Str
: constant String := "Index";
176 Task_Name_Str
: constant String := "Task Name";
177 Stack_Size_Str
: constant String := "Stack Size";
178 Actual_Size_Str
: constant String := "Stack usage [min - max]";
180 function Get_Usage_Range
(Result
: Task_Result
) return String;
181 -- Return string representing the range of possible result of stack usage
183 procedure Output_Result
184 (Result_Id
: Natural;
185 Result
: Task_Result
;
186 Max_Stack_Size_Len
: Natural;
187 Max_Actual_Use_Len
: Natural);
188 -- Prints the result on the standard output. Result Id is the number of
189 -- the result in the array, and Result the contents of the actual result.
190 -- Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
191 -- proper layout. They hold the maximum length of the string representing
192 -- the Stack_Size and Actual_Use values.
198 procedure Initialize
(Buffer_Size
: Natural) is
199 Bottom_Of_Stack
: aliased Integer;
200 Stack_Size_Chars
: System
.Address
;
203 -- Initialize the buffered result array
205 Result_Array
:= new Result_Array_Type
(1 .. Buffer_Size
);
208 (Task_Name
=> (others => ASCII
.NUL
),
213 -- Set the Is_Enabled flag to true, so that the task wrapper knows that
214 -- it has to handle dynamic stack analysis
218 Stack_Size_Chars
:= System
.CRTL
.getenv
("GNAT_STACK_LIMIT" & ASCII
.NUL
);
220 -- If variable GNAT_STACK_LIMIT is set, then we will take care of the
221 -- environment task, using GNAT_STASK_LIMIT as the size of the stack.
222 -- It doesn't make sens to process the stack when no bound is set (e.g.
223 -- limit is typically up to 4 GB).
225 if Stack_Size_Chars
/= Null_Address
then
227 Stack_Size
: Integer;
230 Stack_Size
:= System
.CRTL
.atoi
(Stack_Size_Chars
) * 1024;
233 (Environment_Task_Analyzer
,
237 System
.Storage_Elements
.To_Integer
(Bottom_Of_Stack
'Address));
239 Fill_Stack
(Environment_Task_Analyzer
);
241 Compute_Environment_Task
:= True;
244 -- GNAT_STACK_LIMIT not set
247 Compute_Environment_Task
:= False;
255 procedure Fill_Stack
(Analyzer
: in out Stack_Analyzer
) is
256 -- Change the local variables and parameters of this function with
257 -- super-extra care. The more the stack frame size of this function is
258 -- big, the more an "instrumentation threshold at writing" error is
261 Current_Stack_Level
: aliased Integer;
264 -- Readjust the pattern size. When we arrive in this function, there is
265 -- already a given amount of stack used, that we won't analyze.
267 Analyzer
.Stack_Used_When_Filling
:=
269 (Analyzer
.Bottom_Of_Stack
,
270 To_Stack_Address
(Current_Stack_Level
'Address))
271 + Natural (Current_Stack_Level
'Size);
273 Analyzer
.Pattern_Size
:=
274 Analyzer
.Pattern_Size
- Analyzer
.Stack_Used_When_Filling
;
277 Stack
: aliased Stack_Slots
278 (1 .. Analyzer
.Pattern_Size
/ Bytes_Per_Pattern
);
281 Stack
:= (others => Analyzer
.Pattern
);
283 Analyzer
.Stack_Overlay_Address
:= Stack
'Address;
285 Analyzer
.Bottom_Pattern_Mark
:=
286 To_Stack_Address
(Stack
(Bottom_Slot_Index_In
(Stack
))'Address);
287 Analyzer
.Top_Pattern_Mark
:=
288 To_Stack_Address
(Stack
(Top_Slot_Index_In
(Stack
))'Address);
290 -- If Arr has been packed, the following assertion must be true (we
291 -- add the size of the element whose address is:
292 -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):
295 (Analyzer
.Pattern_Size
=
297 (Analyzer
.Top_Pattern_Mark
, Analyzer
.Bottom_Pattern_Mark
));
301 -------------------------
302 -- Initialize_Analyzer --
303 -------------------------
305 procedure Initialize_Analyzer
306 (Analyzer
: in out Stack_Analyzer
;
308 Stack_Size
: Natural;
309 Max_Pattern_Size
: Natural;
310 Bottom
: Stack_Address
;
311 Pattern
: Unsigned_32
:= 16#DEAD_BEEF#
)
314 -- Initialize the analyzer fields
316 Analyzer
.Bottom_Of_Stack
:= Bottom
;
317 Analyzer
.Stack_Size
:= Stack_Size
;
318 Analyzer
.Pattern_Size
:= Max_Pattern_Size
;
319 Analyzer
.Pattern
:= Pattern
;
320 Analyzer
.Result_Id
:= Next_Id
;
322 Analyzer
.Task_Name
:= (others => ' ');
324 -- Compute the task name, and truncate if bigger than Task_Name_Length
326 if Task_Name
'Length <= Task_Name_Length
then
327 Analyzer
.Task_Name
(1 .. Task_Name
'Length) := Task_Name
;
329 Analyzer
.Task_Name
:=
330 Task_Name
(Task_Name
'First ..
331 Task_Name
'First + Task_Name_Length
- 1);
334 Next_Id
:= Next_Id
+ 1;
335 end Initialize_Analyzer
;
342 (SP_Low
: Stack_Address
;
343 SP_High
: Stack_Address
) return Natural
346 if SP_Low
> SP_High
then
347 return Natural (SP_Low
- SP_High
+ 4);
349 return Natural (SP_High
- SP_Low
+ 4);
357 procedure Compute_Result
(Analyzer
: in out Stack_Analyzer
) is
359 -- Change the local variables and parameters of this function with
360 -- super-extra care. The larger the stack frame size of this function
361 -- is, the more an "instrumentation threshold at reading" error is
364 Stack
: Stack_Slots
(1 .. Analyzer
.Pattern_Size
/ Bytes_Per_Pattern
);
365 for Stack
'Address use Analyzer
.Stack_Overlay_Address
;
368 Analyzer
.Topmost_Touched_Mark
:= Analyzer
.Bottom_Pattern_Mark
;
370 -- Look backward from the topmost possible end of the marked stack to
371 -- the bottom of it. The first index not equals to the patterns marks
372 -- the beginning of the used stack.
375 Top_Index
: constant Integer := Top_Slot_Index_In
(Stack
);
376 Bottom_Index
: constant Integer := Bottom_Slot_Index_In
(Stack
);
377 Step
: constant Integer := Pop_Index_Step_For
(Stack
);
383 if Stack
(J
) /= Analyzer
.Pattern
then
384 Analyzer
.Topmost_Touched_Mark
385 := To_Stack_Address
(Stack
(J
)'Address);
389 exit when J
= Bottom_Index
;
395 ---------------------
396 -- Get_Usage_Range --
397 ---------------------
399 function Get_Usage_Range
(Result
: Task_Result
) return String is
400 Min_Used_Str
: constant String := Natural'Image (Result
.Min_Measure
);
401 Max_Used_Str
: constant String := Natural'Image (Result
.Max_Measure
);
403 return "[" & Min_Used_Str
(2 .. Min_Used_Str
'Last) & " -"
404 & Max_Used_Str
& "]";
407 ---------------------
409 ---------------------
411 procedure Output_Result
412 (Result_Id
: Natural;
413 Result
: Task_Result
;
414 Max_Stack_Size_Len
: Natural;
415 Max_Actual_Use_Len
: Natural)
417 Result_Id_Str
: constant String := Natural'Image (Result_Id
);
418 Stack_Size_Str
: constant String := Natural'Image (Result
.Max_Size
);
419 Actual_Use_Str
: constant String := Get_Usage_Range
(Result
);
421 Result_Id_Blanks
: constant
422 String (1 .. Index_Str
'Length - Result_Id_Str
'Length) :=
425 Stack_Size_Blanks
: constant
426 String (1 .. Max_Stack_Size_Len
- Stack_Size_Str
'Length) :=
429 Actual_Use_Blanks
: constant
430 String (1 .. Max_Actual_Use_Len
- Actual_Use_Str
'Length) :=
434 Set_Output
(Standard_Error
);
435 Put
(Result_Id_Blanks
& Natural'Image (Result_Id
));
437 Put
(Result
.Task_Name
);
439 Put
(Stack_Size_Blanks
& Stack_Size_Str
);
441 Put
(Actual_Use_Blanks
& Actual_Use_Str
);
445 ---------------------
447 ---------------------
449 procedure Output_Results
is
450 Max_Stack_Size
: Natural := 0;
451 Max_Actual_Use_Result_Id
: Natural := Result_Array
'First;
452 Max_Stack_Size_Len
, Max_Actual_Use_Len
: Natural := 0;
454 Task_Name_Blanks
: constant
455 String (1 .. Task_Name_Length
- Task_Name_Str
'Length) :=
459 Set_Output
(Standard_Error
);
461 if Compute_Environment_Task
then
462 Compute_Result
(Environment_Task_Analyzer
);
463 Report_Result
(Environment_Task_Analyzer
);
466 if Result_Array
'Length > 0 then
468 -- Computes the size of the largest strings that will get displayed,
469 -- in order to do correct column alignment.
471 for J
in Result_Array
'Range loop
472 exit when J
>= Next_Id
;
474 if Result_Array
(J
).Max_Measure
475 > Result_Array
(Max_Actual_Use_Result_Id
).Max_Measure
477 Max_Actual_Use_Result_Id
:= J
;
480 if Result_Array
(J
).Max_Size
> Max_Stack_Size
then
481 Max_Stack_Size
:= Result_Array
(J
).Max_Size
;
485 Max_Stack_Size_Len
:= Natural'Image (Max_Stack_Size
)'Length;
487 Max_Actual_Use_Len
:=
488 Get_Usage_Range
(Result_Array
(Max_Actual_Use_Result_Id
))'Length;
490 -- Display the output header. Blanks will be added in front of the
494 Stack_Size_Blanks
: constant
495 String (1 .. Max_Stack_Size_Len
- Stack_Size_Str
'Length) :=
498 Stack_Usage_Blanks
: constant
499 String (1 .. Max_Actual_Use_Len
- Actual_Size_Str
'Length) :=
503 if Stack_Size_Str
'Length > Max_Stack_Size_Len
then
504 Max_Stack_Size_Len
:= Stack_Size_Str
'Length;
507 if Actual_Size_Str
'Length > Max_Actual_Use_Len
then
508 Max_Actual_Use_Len
:= Actual_Size_Str
'Length;
512 (Index_Str
& " | " & Task_Name_Str
& Task_Name_Blanks
& " | "
513 & Stack_Size_Str
& Stack_Size_Blanks
& " | "
514 & Stack_Usage_Blanks
& Actual_Size_Str
);
519 -- Now display the individual results
521 for J
in Result_Array
'Range loop
522 exit when J
>= Next_Id
;
524 (J
, Result_Array
(J
), Max_Stack_Size_Len
, Max_Actual_Use_Len
);
527 -- Case of no result stored, still display the labels
531 (Index_Str
& " | " & Task_Name_Str
& Task_Name_Blanks
& " | "
532 & Stack_Size_Str
& " | " & Actual_Size_Str
);
541 procedure Report_Result
(Analyzer
: Stack_Analyzer
) is
542 Measure
: constant Natural :=
544 (Analyzer
.Topmost_Touched_Mark
,
545 Analyzer
.Bottom_Of_Stack
)
546 + Analyzer
.Stack_Used_When_Filling
;
548 Result
: constant Task_Result
:=
549 (Task_Name
=> Analyzer
.Task_Name
,
550 Max_Size
=> Analyzer
.Stack_Size
,
551 Min_Measure
=> Measure
,
552 Max_Measure
=> Measure
+ Analyzer
.Stack_Size
553 - Analyzer
.Pattern_Size
);
556 if Analyzer
.Result_Id
in Result_Array
'Range then
558 -- If the result can be stored, then store it in Result_Array
560 Result_Array
(Analyzer
.Result_Id
) := Result
;
563 -- If the result cannot be stored, then we display it right away
566 Result_Str_Len
: constant Natural :=
567 Get_Usage_Range
(Result
)'Length;
568 Size_Str_Len
: constant Natural :=
569 Natural'Image (Analyzer
.Stack_Size
)'Length;
571 Max_Stack_Size_Len
: Natural;
572 Max_Actual_Use_Len
: Natural;
575 -- Take either the label size or the number image size for the
576 -- size of the column "Stack Size".
578 if Size_Str_Len
> Stack_Size_Str
'Length then
579 Max_Stack_Size_Len
:= Size_Str_Len
;
581 Max_Stack_Size_Len
:= Stack_Size_Str
'Length;
584 -- Take either the label size or the number image size for the
585 -- size of the column "Stack Usage"
587 if Result_Str_Len
> Actual_Size_Str
'Length then
588 Max_Actual_Use_Len
:= Result_Str_Len
;
590 Max_Actual_Use_Len
:= Actual_Size_Str
'Length;
602 end System
.Stack_Usage
;