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-2017, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 with System
.Parameters
;
36 package body System
.Stack_Usage
is
37 use System
.Storage_Elements
;
45 -- Stackl_Slots is an internal data type to represent a sequence of real
46 -- stack slots initialized with a provided pattern, with operations to
47 -- abstract away the target call stack growth direction.
49 type Stack_Slots
is array (Integer range <>) of Pattern_Type
;
50 for Stack_Slots
'Component_Size use Pattern_Type
'Object_Size;
52 -- We will carefully handle the initializations ourselves and might want
53 -- to remap an initialized overlay later on with an address clause.
55 pragma Suppress_Initialization
(Stack_Slots
);
57 -- The abstract Stack_Slots operations all operate over the simple array
60 -- memory addresses increasing ---->
62 -- Slots('First) Slots('Last)
65 -- +------------------------------------------------------------------+
67 -- +------------------------------------------------------------------+
69 -- What we call Top or Bottom always denotes call chain leaves or entry
70 -- points respectively, and their relative positions in the stack array
71 -- depends on the target stack growth direction:
75 -- <----- calls push frames towards decreasing addresses
77 -- Top(most) Slot Bottom(most) Slot
80 -- +------------------------------------------------------------------+
81 -- |####| | leaf frame | ... | entry frame |
82 -- +------------------------------------------------------------------+
86 -- calls push frames towards increasing addresses ----->
88 -- Bottom(most) Slot Top(most) Slot
91 -- +------------------------------------------------------------------+
92 -- | entry frame | ... | leaf frame | |####|
93 -- +------------------------------------------------------------------+
99 -- Now the implementation of the services offered by this unit, on top of
100 -- the Stack_Slots abstraction above.
102 Index_Str
: constant String := "Index";
103 Task_Name_Str
: constant String := "Task Name";
104 Stack_Size_Str
: constant String := "Stack Size";
105 Actual_Size_Str
: constant String := "Stack usage";
107 procedure Output_Result
108 (Result_Id
: Natural;
109 Result
: Task_Result
;
110 Max_Stack_Size_Len
: Natural;
111 Max_Actual_Use_Len
: Natural);
112 -- Prints the result on the standard output. Result Id is the number of
113 -- the result in the array, and Result the contents of the actual result.
114 -- Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
115 -- proper layout. They hold the maximum length of the string representing
116 -- the Stack_Size and Actual_Use values.
122 procedure Initialize
(Buffer_Size
: Natural) is
123 Stack_Size_Chars
: System
.Address
;
126 -- Initialize the buffered result array
128 Result_Array
:= new Result_Array_Type
(1 .. Buffer_Size
);
131 (Task_Name
=> (others => ASCII
.NUL
),
135 -- Set the Is_Enabled flag to true, so that the task wrapper knows that
136 -- it has to handle dynamic stack analysis
140 Stack_Size_Chars
:= System
.CRTL
.getenv
("GNAT_STACK_LIMIT" & ASCII
.NUL
);
142 -- If variable GNAT_STACK_LIMIT is set, then we will take care of the
143 -- environment task, using GNAT_STASK_LIMIT as the size of the stack.
144 -- It doesn't make sens to process the stack when no bound is set (e.g.
145 -- limit is typically up to 4 GB).
147 if Stack_Size_Chars
/= Null_Address
then
149 My_Stack_Size
: Integer;
152 My_Stack_Size
:= System
.CRTL
.atoi
(Stack_Size_Chars
) * 1024;
155 (Environment_Task_Analyzer
,
161 Fill_Stack
(Environment_Task_Analyzer
);
163 Compute_Environment_Task
:= True;
166 -- GNAT_STACK_LIMIT not set
169 Compute_Environment_Task
:= False;
177 procedure Fill_Stack
(Analyzer
: in out Stack_Analyzer
) is
179 -- Change the local variables and parameters of this function with
180 -- super-extra care. The more the stack frame size of this function is
181 -- big, the more an "instrumentation threshold at writing" error is
184 Current_Stack_Level
: aliased Integer;
186 Guard
: constant := 256;
187 -- Guard space between the Current_Stack_Level'Address and the last
188 -- allocated byte on the stack.
190 if Parameters
.Stack_Grows_Down
then
191 if Analyzer
.Stack_Base
- Stack_Address
(Analyzer
.Pattern_Size
) >
192 To_Stack_Address
(Current_Stack_Level
'Address) - Guard
194 -- No room for a pattern
196 Analyzer
.Pattern_Size
:= 0;
200 Analyzer
.Pattern_Limit
:=
201 Analyzer
.Stack_Base
- Stack_Address
(Analyzer
.Pattern_Size
);
203 if Analyzer
.Stack_Base
>
204 To_Stack_Address
(Current_Stack_Level
'Address) - Guard
206 -- Reduce pattern size to prevent local frame overwrite
208 Analyzer
.Pattern_Size
:=
209 Integer (To_Stack_Address
(Current_Stack_Level
'Address) - Guard
210 - Analyzer
.Pattern_Limit
);
213 Analyzer
.Pattern_Overlay_Address
:=
214 To_Address
(Analyzer
.Pattern_Limit
);
216 if Analyzer
.Stack_Base
+ Stack_Address
(Analyzer
.Pattern_Size
) <
217 To_Stack_Address
(Current_Stack_Level
'Address) + Guard
219 -- No room for a pattern
221 Analyzer
.Pattern_Size
:= 0;
225 Analyzer
.Pattern_Limit
:=
226 Analyzer
.Stack_Base
+ Stack_Address
(Analyzer
.Pattern_Size
);
228 if Analyzer
.Stack_Base
<
229 To_Stack_Address
(Current_Stack_Level
'Address) + Guard
231 -- Reduce pattern size to prevent local frame overwrite
233 Analyzer
.Pattern_Size
:=
235 (Analyzer
.Pattern_Limit
-
236 (To_Stack_Address
(Current_Stack_Level
'Address) + Guard
));
239 Analyzer
.Pattern_Overlay_Address
:=
240 To_Address
(Analyzer
.Pattern_Limit
-
241 Stack_Address
(Analyzer
.Pattern_Size
));
244 -- Declare and fill the pattern buffer
247 Pattern
: aliased Stack_Slots
248 (1 .. Analyzer
.Pattern_Size
/ Bytes_Per_Pattern
);
249 for Pattern
'Address use Analyzer
.Pattern_Overlay_Address
;
252 if System
.Parameters
.Stack_Grows_Down
then
253 for J
in reverse Pattern
'Range loop
254 Pattern
(J
) := Analyzer
.Pattern
;
258 for J
in Pattern
'Range loop
259 Pattern
(J
) := Analyzer
.Pattern
;
265 -------------------------
266 -- Initialize_Analyzer --
267 -------------------------
269 procedure Initialize_Analyzer
270 (Analyzer
: in out Stack_Analyzer
;
272 Stack_Size
: Natural;
273 Stack_Base
: Stack_Address
;
274 Pattern_Size
: Natural;
275 Pattern
: Interfaces
.Unsigned_32
:= 16#DEAD_BEEF#
)
278 -- Initialize the analyzer fields
280 Analyzer
.Stack_Base
:= Stack_Base
;
281 Analyzer
.Stack_Size
:= Stack_Size
;
282 Analyzer
.Pattern_Size
:= Pattern_Size
;
283 Analyzer
.Pattern
:= Pattern
;
284 Analyzer
.Result_Id
:= Next_Id
;
285 Analyzer
.Task_Name
:= (others => ' ');
287 -- Compute the task name, and truncate if bigger than Task_Name_Length
289 if Task_Name
'Length <= Task_Name_Length
then
290 Analyzer
.Task_Name
(1 .. Task_Name
'Length) := Task_Name
;
292 Analyzer
.Task_Name
:=
293 Task_Name
(Task_Name
'First ..
294 Task_Name
'First + Task_Name_Length
- 1);
297 Next_Id
:= Next_Id
+ 1;
298 end Initialize_Analyzer
;
305 (SP_Low
: Stack_Address
;
306 SP_High
: Stack_Address
) return Natural
309 if SP_Low
> SP_High
then
310 return Natural (SP_Low
- SP_High
);
312 return Natural (SP_High
- SP_Low
);
320 procedure Compute_Result
(Analyzer
: in out Stack_Analyzer
) is
322 -- Change the local variables and parameters of this function with
323 -- super-extra care. The larger the stack frame size of this function
324 -- is, the more an "instrumentation threshold at reading" error is
327 Stack
: Stack_Slots
(1 .. Analyzer
.Pattern_Size
/ Bytes_Per_Pattern
);
328 for Stack
'Address use Analyzer
.Pattern_Overlay_Address
;
331 -- Value if the pattern was not modified
333 if Parameters
.Stack_Grows_Down
then
334 Analyzer
.Topmost_Touched_Mark
:=
335 Analyzer
.Pattern_Limit
+ Stack_Address
(Analyzer
.Pattern_Size
);
337 Analyzer
.Topmost_Touched_Mark
:=
338 Analyzer
.Pattern_Limit
- Stack_Address
(Analyzer
.Pattern_Size
);
341 if Analyzer
.Pattern_Size
= 0 then
345 -- Look backward from the topmost possible end of the marked stack to
346 -- the bottom of it. The first index not equals to the patterns marks
347 -- the beginning of the used stack.
349 if System
.Parameters
.Stack_Grows_Down
then
350 for J
in Stack
'Range loop
351 if Stack
(J
) /= Analyzer
.Pattern
then
352 Analyzer
.Topmost_Touched_Mark
:=
353 To_Stack_Address
(Stack
(J
)'Address);
359 for J
in reverse Stack
'Range loop
360 if Stack
(J
) /= Analyzer
.Pattern
then
361 Analyzer
.Topmost_Touched_Mark
:=
362 To_Stack_Address
(Stack
(J
)'Address);
370 ---------------------
372 ---------------------
374 procedure Output_Result
375 (Result_Id
: Natural;
376 Result
: Task_Result
;
377 Max_Stack_Size_Len
: Natural;
378 Max_Actual_Use_Len
: Natural)
380 Result_Id_Str
: constant String := Natural'Image (Result_Id
);
381 Stack_Size_Str
: constant String := Natural'Image (Result
.Stack_Size
);
382 Actual_Use_Str
: constant String := Natural'Image (Result
.Value
);
384 Result_Id_Blanks
: constant
385 String (1 .. Index_Str
'Length - Result_Id_Str
'Length) :=
388 Stack_Size_Blanks
: constant
389 String (1 .. Max_Stack_Size_Len
- Stack_Size_Str
'Length) :=
392 Actual_Use_Blanks
: constant
393 String (1 .. Max_Actual_Use_Len
- Actual_Use_Str
'Length) :=
397 Set_Output
(Standard_Error
);
398 Put
(Result_Id_Blanks
& Natural'Image (Result_Id
));
400 Put
(Result
.Task_Name
);
402 Put
(Stack_Size_Blanks
& Stack_Size_Str
);
404 Put
(Actual_Use_Blanks
& Actual_Use_Str
);
408 ---------------------
410 ---------------------
412 procedure Output_Results
is
413 Max_Stack_Size
: Natural := 0;
414 Max_Stack_Usage
: Natural := 0;
415 Max_Stack_Size_Len
, Max_Actual_Use_Len
: Natural := 0;
417 Task_Name_Blanks
: constant
419 (1 .. Task_Name_Length
- Task_Name_Str
'Length) :=
423 Set_Output
(Standard_Error
);
425 if Compute_Environment_Task
then
426 Compute_Result
(Environment_Task_Analyzer
);
427 Report_Result
(Environment_Task_Analyzer
);
430 if Result_Array
'Length > 0 then
432 -- Computes the size of the largest strings that will get displayed,
433 -- in order to do correct column alignment.
435 for J
in Result_Array
'Range loop
436 exit when J
>= Next_Id
;
438 if Result_Array
(J
).Value
> Max_Stack_Usage
then
439 Max_Stack_Usage
:= Result_Array
(J
).Value
;
442 if Result_Array
(J
).Stack_Size
> Max_Stack_Size
then
443 Max_Stack_Size
:= Result_Array
(J
).Stack_Size
;
447 Max_Stack_Size_Len
:= Natural'Image (Max_Stack_Size
)'Length;
449 Max_Actual_Use_Len
:= Natural'Image (Max_Stack_Usage
)'Length;
451 -- Display the output header. Blanks will be added in front of the
455 Stack_Size_Blanks
: constant
456 String (1 .. Max_Stack_Size_Len
-
457 Stack_Size_Str
'Length) :=
460 Stack_Usage_Blanks
: constant
461 String (1 .. Max_Actual_Use_Len
-
462 Actual_Size_Str
'Length) :=
466 if Stack_Size_Str
'Length > Max_Stack_Size_Len
then
467 Max_Stack_Size_Len
:= Stack_Size_Str
'Length;
470 if Actual_Size_Str
'Length > Max_Actual_Use_Len
then
471 Max_Actual_Use_Len
:= Actual_Size_Str
'Length;
475 (Index_Str
& " | " & Task_Name_Str
& Task_Name_Blanks
& " | "
476 & Stack_Size_Str
& Stack_Size_Blanks
& " | "
477 & Stack_Usage_Blanks
& Actual_Size_Str
);
482 -- Now display the individual results
484 for J
in Result_Array
'Range loop
485 exit when J
>= Next_Id
;
487 (J
, Result_Array
(J
), Max_Stack_Size_Len
, Max_Actual_Use_Len
);
490 -- Case of no result stored, still display the labels
494 (Index_Str
& " | " & Task_Name_Str
& Task_Name_Blanks
& " | "
495 & Stack_Size_Str
& " | " & Actual_Size_Str
);
504 procedure Report_Result
(Analyzer
: Stack_Analyzer
) is
505 Result
: Task_Result
:= (Task_Name
=> Analyzer
.Task_Name
,
506 Stack_Size
=> Analyzer
.Stack_Size
,
509 if Analyzer
.Pattern_Size
= 0 then
511 -- If we have that result, it means that we didn't do any computation
512 -- at all (i.e. we used at least everything (and possibly more).
514 Result
.Value
:= Analyzer
.Stack_Size
;
517 Result
.Value
:= Stack_Size
(Analyzer
.Topmost_Touched_Mark
,
518 Analyzer
.Stack_Base
);
521 if Analyzer
.Result_Id
in Result_Array
'Range then
523 -- If the result can be stored, then store it in Result_Array
525 Result_Array
(Analyzer
.Result_Id
) := Result
;
528 -- If the result cannot be stored, then we display it right away
531 Result_Str_Len
: constant Natural :=
532 Natural'Image (Result
.Value
)'Length;
533 Size_Str_Len
: constant Natural :=
534 Natural'Image (Analyzer
.Stack_Size
)'Length;
536 Max_Stack_Size_Len
: Natural;
537 Max_Actual_Use_Len
: Natural;
540 -- Take either the label size or the number image size for the
541 -- size of the column "Stack Size".
543 Max_Stack_Size_Len
:=
544 (if Size_Str_Len
> Stack_Size_Str
'Length
546 else Stack_Size_Str
'Length);
548 -- Take either the label size or the number image size for the
549 -- size of the column "Stack Usage".
551 Max_Actual_Use_Len
:=
552 (if Result_Str_Len
> Actual_Size_Str
'Length
554 else Actual_Size_Str
'Length);
565 end System
.Stack_Usage
;