File : s-stausa.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M - S T A C K _ U S A G E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with System.Parameters;
33 with System.CRTL;
34 with System.IO;
35
36 package body System.Stack_Usage is
37 use System.Storage_Elements;
38 use System;
39 use System.IO;
40 use Interfaces;
41
42 -----------------
43 -- Stack_Slots --
44 -----------------
45
46 -- Stackl_Slots is an internal data type to represent a sequence of real
47 -- stack slots initialized with a provided pattern, with operations to
48 -- abstract away the target call stack growth direction.
49
50 type Stack_Slots is array (Integer range <>) of Pattern_Type;
51 for Stack_Slots'Component_Size use Pattern_Type'Object_Size;
52
53 -- We will carefully handle the initializations ourselves and might want
54 -- to remap an initialized overlay later on with an address clause.
55
56 pragma Suppress_Initialization (Stack_Slots);
57
58 -- The abstract Stack_Slots operations all operate over the simple array
59 -- memory model:
60
61 -- memory addresses increasing ---->
62
63 -- Slots('First) Slots('Last)
64 -- | |
65 -- V V
66 -- +------------------------------------------------------------------+
67 -- |####| |####|
68 -- +------------------------------------------------------------------+
69
70 -- What we call Top or Bottom always denotes call chain leaves or entry
71 -- points respectively, and their relative positions in the stack array
72 -- depends on the target stack growth direction:
73
74 -- Stack_Grows_Down
75
76 -- <----- calls push frames towards decreasing addresses
77
78 -- Top(most) Slot Bottom(most) Slot
79 -- | |
80 -- V V
81 -- +------------------------------------------------------------------+
82 -- |####| | leaf frame | ... | entry frame |
83 -- +------------------------------------------------------------------+
84
85 -- Stack_Grows_Up
86
87 -- calls push frames towards increasing addresses ----->
88
89 -- Bottom(most) Slot Top(most) Slot
90 -- | |
91 -- V V
92 -- +------------------------------------------------------------------+
93 -- | entry frame | ... | leaf frame | |####|
94 -- +------------------------------------------------------------------+
95
96 -------------------
97 -- Unit Services --
98 -------------------
99
100 -- Now the implementation of the services offered by this unit, on top of
101 -- the Stack_Slots abstraction above.
102
103 Index_Str : constant String := "Index";
104 Task_Name_Str : constant String := "Task Name";
105 Stack_Size_Str : constant String := "Stack Size";
106 Actual_Size_Str : constant String := "Stack usage";
107
108 procedure Output_Result
109 (Result_Id : Natural;
110 Result : Task_Result;
111 Max_Stack_Size_Len : Natural;
112 Max_Actual_Use_Len : Natural);
113 -- Prints the result on the standard output. Result Id is the number of
114 -- the result in the array, and Result the contents of the actual result.
115 -- Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
116 -- proper layout. They hold the maximum length of the string representing
117 -- the Stack_Size and Actual_Use values.
118
119 ----------------
120 -- Initialize --
121 ----------------
122
123 procedure Initialize (Buffer_Size : Natural) is
124 Stack_Size_Chars : System.Address;
125
126 begin
127 -- Initialize the buffered result array
128
129 Result_Array := new Result_Array_Type (1 .. Buffer_Size);
130 Result_Array.all :=
131 (others =>
132 (Task_Name => (others => ASCII.NUL),
133 Value => 0,
134 Stack_Size => 0));
135
136 -- Set the Is_Enabled flag to true, so that the task wrapper knows that
137 -- it has to handle dynamic stack analysis
138
139 Is_Enabled := True;
140
141 Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
142
143 -- If variable GNAT_STACK_LIMIT is set, then we will take care of the
144 -- environment task, using GNAT_STASK_LIMIT as the size of the stack.
145 -- It doesn't make sens to process the stack when no bound is set (e.g.
146 -- limit is typically up to 4 GB).
147
148 if Stack_Size_Chars /= Null_Address then
149 declare
150 My_Stack_Size : Integer;
151
152 begin
153 My_Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
154
155 Initialize_Analyzer
156 (Environment_Task_Analyzer,
157 "ENVIRONMENT TASK",
158 My_Stack_Size,
159 0,
160 My_Stack_Size);
161
162 Fill_Stack (Environment_Task_Analyzer);
163
164 Compute_Environment_Task := True;
165 end;
166
167 -- GNAT_STACK_LIMIT not set
168
169 else
170 Compute_Environment_Task := False;
171 end if;
172 end Initialize;
173
174 ----------------
175 -- Fill_Stack --
176 ----------------
177
178 procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is
179
180 -- Change the local variables and parameters of this function with
181 -- super-extra care. The more the stack frame size of this function is
182 -- big, the more an "instrumentation threshold at writing" error is
183 -- likely to happen.
184
185 Current_Stack_Level : aliased Integer;
186
187 Guard : constant := 256;
188 -- Guard space between the Current_Stack_Level'Address and the last
189 -- allocated byte on the stack.
190 begin
191 if Parameters.Stack_Grows_Down then
192 if Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size) >
193 To_Stack_Address (Current_Stack_Level'Address) - Guard
194 then
195 -- No room for a pattern
196
197 Analyzer.Pattern_Size := 0;
198 return;
199 end if;
200
201 Analyzer.Pattern_Limit :=
202 Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size);
203
204 if Analyzer.Stack_Base >
205 To_Stack_Address (Current_Stack_Level'Address) - Guard
206 then
207 -- Reduce pattern size to prevent local frame overwrite
208
209 Analyzer.Pattern_Size :=
210 Integer (To_Stack_Address (Current_Stack_Level'Address) - Guard
211 - Analyzer.Pattern_Limit);
212 end if;
213
214 Analyzer.Pattern_Overlay_Address :=
215 To_Address (Analyzer.Pattern_Limit);
216 else
217 if Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size) <
218 To_Stack_Address (Current_Stack_Level'Address) + Guard
219 then
220 -- No room for a pattern
221
222 Analyzer.Pattern_Size := 0;
223 return;
224 end if;
225
226 Analyzer.Pattern_Limit :=
227 Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size);
228
229 if Analyzer.Stack_Base <
230 To_Stack_Address (Current_Stack_Level'Address) + Guard
231 then
232 -- Reduce pattern size to prevent local frame overwrite
233
234 Analyzer.Pattern_Size :=
235 Integer
236 (Analyzer.Pattern_Limit -
237 (To_Stack_Address (Current_Stack_Level'Address) + Guard));
238 end if;
239
240 Analyzer.Pattern_Overlay_Address :=
241 To_Address (Analyzer.Pattern_Limit -
242 Stack_Address (Analyzer.Pattern_Size));
243 end if;
244
245 -- Declare and fill the pattern buffer
246
247 declare
248 Pattern : aliased Stack_Slots
249 (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
250 for Pattern'Address use Analyzer.Pattern_Overlay_Address;
251
252 begin
253 if System.Parameters.Stack_Grows_Down then
254 for J in reverse Pattern'Range loop
255 Pattern (J) := Analyzer.Pattern;
256 end loop;
257
258 else
259 for J in Pattern'Range loop
260 Pattern (J) := Analyzer.Pattern;
261 end loop;
262 end if;
263 end;
264 end Fill_Stack;
265
266 -------------------------
267 -- Initialize_Analyzer --
268 -------------------------
269
270 procedure Initialize_Analyzer
271 (Analyzer : in out Stack_Analyzer;
272 Task_Name : String;
273 Stack_Size : Natural;
274 Stack_Base : Stack_Address;
275 Pattern_Size : Natural;
276 Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#)
277 is
278 begin
279 -- Initialize the analyzer fields
280
281 Analyzer.Stack_Base := Stack_Base;
282 Analyzer.Stack_Size := Stack_Size;
283 Analyzer.Pattern_Size := Pattern_Size;
284 Analyzer.Pattern := Pattern;
285 Analyzer.Result_Id := Next_Id;
286 Analyzer.Task_Name := (others => ' ');
287
288 -- Compute the task name, and truncate if bigger than Task_Name_Length
289
290 if Task_Name'Length <= Task_Name_Length then
291 Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
292 else
293 Analyzer.Task_Name :=
294 Task_Name (Task_Name'First ..
295 Task_Name'First + Task_Name_Length - 1);
296 end if;
297
298 Next_Id := Next_Id + 1;
299 end Initialize_Analyzer;
300
301 ----------------
302 -- Stack_Size --
303 ----------------
304
305 function Stack_Size
306 (SP_Low : Stack_Address;
307 SP_High : Stack_Address) return Natural
308 is
309 begin
310 if SP_Low > SP_High then
311 return Natural (SP_Low - SP_High);
312 else
313 return Natural (SP_High - SP_Low);
314 end if;
315 end Stack_Size;
316
317 --------------------
318 -- Compute_Result --
319 --------------------
320
321 procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
322
323 -- Change the local variables and parameters of this function with
324 -- super-extra care. The larger the stack frame size of this function
325 -- is, the more an "instrumentation threshold at reading" error is
326 -- likely to happen.
327
328 Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
329 for Stack'Address use Analyzer.Pattern_Overlay_Address;
330
331 begin
332 -- Value if the pattern was not modified
333
334 if Parameters.Stack_Grows_Down then
335 Analyzer.Topmost_Touched_Mark :=
336 Analyzer.Pattern_Limit + Stack_Address (Analyzer.Pattern_Size);
337 else
338 Analyzer.Topmost_Touched_Mark :=
339 Analyzer.Pattern_Limit - Stack_Address (Analyzer.Pattern_Size);
340 end if;
341
342 if Analyzer.Pattern_Size = 0 then
343 return;
344 end if;
345
346 -- Look backward from the topmost possible end of the marked stack to
347 -- the bottom of it. The first index not equals to the patterns marks
348 -- the beginning of the used stack.
349
350 if System.Parameters.Stack_Grows_Down then
351 for J in Stack'Range loop
352 if Stack (J) /= Analyzer.Pattern then
353 Analyzer.Topmost_Touched_Mark :=
354 To_Stack_Address (Stack (J)'Address);
355 exit;
356 end if;
357 end loop;
358
359 else
360 for J in reverse Stack'Range loop
361 if Stack (J) /= Analyzer.Pattern then
362 Analyzer.Topmost_Touched_Mark :=
363 To_Stack_Address (Stack (J)'Address);
364 exit;
365 end if;
366 end loop;
367
368 end if;
369 end Compute_Result;
370
371 ---------------------
372 -- Output_Result --
373 ---------------------
374
375 procedure Output_Result
376 (Result_Id : Natural;
377 Result : Task_Result;
378 Max_Stack_Size_Len : Natural;
379 Max_Actual_Use_Len : Natural)
380 is
381 Result_Id_Str : constant String := Natural'Image (Result_Id);
382 Stack_Size_Str : constant String := Natural'Image (Result.Stack_Size);
383 Actual_Use_Str : constant String := Natural'Image (Result.Value);
384
385 Result_Id_Blanks : constant
386 String (1 .. Index_Str'Length - Result_Id_Str'Length) :=
387 (others => ' ');
388
389 Stack_Size_Blanks : constant
390 String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
391 (others => ' ');
392
393 Actual_Use_Blanks : constant
394 String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
395 (others => ' ');
396
397 begin
398 Set_Output (Standard_Error);
399 Put (Result_Id_Blanks & Natural'Image (Result_Id));
400 Put (" | ");
401 Put (Result.Task_Name);
402 Put (" | ");
403 Put (Stack_Size_Blanks & Stack_Size_Str);
404 Put (" | ");
405 Put (Actual_Use_Blanks & Actual_Use_Str);
406 New_Line;
407 end Output_Result;
408
409 ---------------------
410 -- Output_Results --
411 ---------------------
412
413 procedure Output_Results is
414 Max_Stack_Size : Natural := 0;
415 Max_Stack_Usage : Natural := 0;
416 Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
417
418 Task_Name_Blanks : constant
419 String
420 (1 .. Task_Name_Length - Task_Name_Str'Length) :=
421 (others => ' ');
422
423 begin
424 Set_Output (Standard_Error);
425
426 if Compute_Environment_Task then
427 Compute_Result (Environment_Task_Analyzer);
428 Report_Result (Environment_Task_Analyzer);
429 end if;
430
431 if Result_Array'Length > 0 then
432
433 -- Computes the size of the largest strings that will get displayed,
434 -- in order to do correct column alignment.
435
436 for J in Result_Array'Range loop
437 exit when J >= Next_Id;
438
439 if Result_Array (J).Value > Max_Stack_Usage then
440 Max_Stack_Usage := Result_Array (J).Value;
441 end if;
442
443 if Result_Array (J).Stack_Size > Max_Stack_Size then
444 Max_Stack_Size := Result_Array (J).Stack_Size;
445 end if;
446 end loop;
447
448 Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
449
450 Max_Actual_Use_Len := Natural'Image (Max_Stack_Usage)'Length;
451
452 -- Display the output header. Blanks will be added in front of the
453 -- labels if needed.
454
455 declare
456 Stack_Size_Blanks : constant
457 String (1 .. Max_Stack_Size_Len -
458 Stack_Size_Str'Length) :=
459 (others => ' ');
460
461 Stack_Usage_Blanks : constant
462 String (1 .. Max_Actual_Use_Len -
463 Actual_Size_Str'Length) :=
464 (others => ' ');
465
466 begin
467 if Stack_Size_Str'Length > Max_Stack_Size_Len then
468 Max_Stack_Size_Len := Stack_Size_Str'Length;
469 end if;
470
471 if Actual_Size_Str'Length > Max_Actual_Use_Len then
472 Max_Actual_Use_Len := Actual_Size_Str'Length;
473 end if;
474
475 Put
476 (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
477 & Stack_Size_Str & Stack_Size_Blanks & " | "
478 & Stack_Usage_Blanks & Actual_Size_Str);
479 end;
480
481 New_Line;
482
483 -- Now display the individual results
484
485 for J in Result_Array'Range loop
486 exit when J >= Next_Id;
487 Output_Result
488 (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
489 end loop;
490
491 -- Case of no result stored, still display the labels
492
493 else
494 Put
495 (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
496 & Stack_Size_Str & " | " & Actual_Size_Str);
497 New_Line;
498 end if;
499 end Output_Results;
500
501 -------------------
502 -- Report_Result --
503 -------------------
504
505 procedure Report_Result (Analyzer : Stack_Analyzer) is
506 Result : Task_Result := (Task_Name => Analyzer.Task_Name,
507 Stack_Size => Analyzer.Stack_Size,
508 Value => 0);
509 begin
510 if Analyzer.Pattern_Size = 0 then
511
512 -- If we have that result, it means that we didn't do any computation
513 -- at all (i.e. we used at least everything (and possibly more).
514
515 Result.Value := Analyzer.Stack_Size;
516
517 else
518 Result.Value := Stack_Size (Analyzer.Topmost_Touched_Mark,
519 Analyzer.Stack_Base);
520 end if;
521
522 if Analyzer.Result_Id in Result_Array'Range then
523
524 -- If the result can be stored, then store it in Result_Array
525
526 Result_Array (Analyzer.Result_Id) := Result;
527
528 else
529 -- If the result cannot be stored, then we display it right away
530
531 declare
532 Result_Str_Len : constant Natural :=
533 Natural'Image (Result.Value)'Length;
534 Size_Str_Len : constant Natural :=
535 Natural'Image (Analyzer.Stack_Size)'Length;
536
537 Max_Stack_Size_Len : Natural;
538 Max_Actual_Use_Len : Natural;
539
540 begin
541 -- Take either the label size or the number image size for the
542 -- size of the column "Stack Size".
543
544 Max_Stack_Size_Len :=
545 (if Size_Str_Len > Stack_Size_Str'Length
546 then Size_Str_Len
547 else Stack_Size_Str'Length);
548
549 -- Take either the label size or the number image size for the
550 -- size of the column "Stack Usage".
551
552 Max_Actual_Use_Len :=
553 (if Result_Str_Len > Actual_Size_Str'Length
554 then Result_Str_Len
555 else Actual_Size_Str'Length);
556
557 Output_Result
558 (Analyzer.Result_Id,
559 Result,
560 Max_Stack_Size_Len,
561 Max_Actual_Use_Len);
562 end;
563 end if;
564 end Report_Result;
565
566 end System.Stack_Usage;