?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* toplev.h (floor_log2): If GCC_VERSION >= 3004, declare as static
[official-gcc.git] / gcc / ada / s-stausa.adb
blobdfa8a1fc6bb64f5b3327c765b85f93664e73f960
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-2009, 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 -- 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. --
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 function Top_Slot_Index_In (Stack : Stack_Slots) return Integer;
97 -- Index of the stack Top slot in the Slots array, denoting the latest
98 -- possible slot available to call chain leaves.
99
100 function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer;
101 -- Index of the stack Bottom slot in the Slots array, denoting the first
102 -- possible slot available to call chain entry points.
103
104 function Push_Index_Step_For (Stack : Stack_Slots) return Integer;
105 -- By how much do we need to update a Slots index to Push a single slot on
106 -- the stack.
107
108 function Pop_Index_Step_For (Stack : Stack_Slots) return Integer;
109 -- By how much do we need to update a Slots index to Pop a single slot off
110 -- the stack.
111
112 pragma Inline_Always (Top_Slot_Index_In);
113 pragma Inline_Always (Bottom_Slot_Index_In);
114 pragma Inline_Always (Push_Index_Step_For);
115 pragma Inline_Always (Pop_Index_Step_For);
116
117 -----------------------
118 -- Top_Slot_Index_In --
119 -----------------------
120
121 function Top_Slot_Index_In (Stack : Stack_Slots) return Integer is
122 begin
123 if System.Parameters.Stack_Grows_Down then
124 return Stack'First;
125 else
126 return Stack'Last;
127 end if;
128 end Top_Slot_Index_In;
129
130 ----------------------------
131 -- Bottom_Slot_Index_In --
132 ----------------------------
133
134 function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer is
135 begin
136 if System.Parameters.Stack_Grows_Down then
137 return Stack'Last;
138 else
139 return Stack'First;
140 end if;
141 end Bottom_Slot_Index_In;
142
143 -------------------------
144 -- Push_Index_Step_For --
145 -------------------------
146
147 function Push_Index_Step_For (Stack : Stack_Slots) return Integer is
148 pragma Unreferenced (Stack);
149 begin
150 if System.Parameters.Stack_Grows_Down then
151 return -1;
152 else
153 return +1;
154 end if;
155 end Push_Index_Step_For;
156
157 ------------------------
158 -- Pop_Index_Step_For --
159 ------------------------
160
161 function Pop_Index_Step_For (Stack : Stack_Slots) return Integer is
162 begin
163 return -Push_Index_Step_For (Stack);
164 end Pop_Index_Step_For;
165
166 -------------------
167 -- Unit Services --
168 -------------------
169
170 -- Now the implementation of the services offered by this unit, on top of
171 -- the Stack_Slots abstraction above.
172
173 Index_Str : constant String := "Index";
174 Task_Name_Str : constant String := "Task Name";
175 Stack_Size_Str : constant String := "Stack Size";
176 Actual_Size_Str : constant String := "Stack usage";
177
178 function Get_Usage_Range (Result : Task_Result) return String;
179 -- Return string representing the range of possible result of stack usage
180
181 procedure Output_Result
182 (Result_Id : Natural;
183 Result : Task_Result;
184 Max_Stack_Size_Len : Natural;
185 Max_Actual_Use_Len : Natural);
186 -- Prints the result on the standard output. Result Id is the number of
187 -- the result in the array, and Result the contents of the actual result.
188 -- Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the
189 -- proper layout. They hold the maximum length of the string representing
190 -- the Stack_Size and Actual_Use values.
191
192 ----------------
193 -- Initialize --
194 ----------------
195
196 procedure Initialize (Buffer_Size : Natural) is
197 Bottom_Of_Stack : aliased Integer;
198 Stack_Size_Chars : System.Address;
199
200 begin
201 -- Initialize the buffered result array
202
203 Result_Array := new Result_Array_Type (1 .. Buffer_Size);
204 Result_Array.all :=
205 (others =>
206 (Task_Name => (others => ASCII.NUL),
207 Variation => 0,
208 Value => 0,
209 Max_Size => 0));
210
211 -- Set the Is_Enabled flag to true, so that the task wrapper knows that
212 -- it has to handle dynamic stack analysis
213
214 Is_Enabled := True;
215
216 Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
217
218 -- If variable GNAT_STACK_LIMIT is set, then we will take care of the
219 -- environment task, using GNAT_STASK_LIMIT as the size of the stack.
220 -- It doesn't make sens to process the stack when no bound is set (e.g.
221 -- limit is typically up to 4 GB).
222
223 if Stack_Size_Chars /= Null_Address then
224 declare
225 My_Stack_Size : Integer;
226
227 begin
228 My_Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
229
230 Initialize_Analyzer
231 (Environment_Task_Analyzer,
232 "ENVIRONMENT TASK",
233 My_Stack_Size,
234 My_Stack_Size,
235 System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address));
236
237 Fill_Stack (Environment_Task_Analyzer);
238
239 Compute_Environment_Task := True;
240 end;
241
242 -- GNAT_STACK_LIMIT not set
243
244 else
245 Compute_Environment_Task := False;
246 end if;
247 end Initialize;
248
249 ----------------
250 -- Fill_Stack --
251 ----------------
252
253 procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is
254 -- Change the local variables and parameters of this function with
255 -- super-extra care. The more the stack frame size of this function is
256 -- big, the more an "instrumentation threshold at writing" error is
257 -- likely to happen.
258
259 Stack_Used_When_Filling : Integer;
260 Current_Stack_Level : aliased Integer;
261
262 begin
263 -- Readjust the pattern size. When we arrive in this function, there is
264 -- already a given amount of stack used, that we won't analyze.
265
266 Stack_Used_When_Filling :=
267 Stack_Size
268 (Analyzer.Bottom_Of_Stack,
269 To_Stack_Address (Current_Stack_Level'Address))
270 + Natural (Current_Stack_Level'Size);
271
272 if Stack_Used_When_Filling > Analyzer.Pattern_Size then
273 -- In this case, the known size of the stack is too small, we've
274 -- already taken more than expected, so there's no possible
275 -- computation
276
277 Analyzer.Pattern_Size := 0;
278 else
279 Analyzer.Pattern_Size :=
280 Analyzer.Pattern_Size - Stack_Used_When_Filling;
281 end if;
282
283 declare
284 Stack : aliased Stack_Slots
285 (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
286
287 begin
288 Stack := (others => Analyzer.Pattern);
289
290 Analyzer.Stack_Overlay_Address := Stack'Address;
291
292 if Analyzer.Pattern_Size /= 0 then
293 Analyzer.Bottom_Pattern_Mark :=
294 To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address);
295 Analyzer.Top_Pattern_Mark :=
296 To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address);
297 else
298 Analyzer.Bottom_Pattern_Mark := To_Stack_Address (Stack'Address);
299 Analyzer.Top_Pattern_Mark := To_Stack_Address (Stack'Address);
300 end if;
301
302 -- If Arr has been packed, the following assertion must be true (we
303 -- add the size of the element whose address is:
304 -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):
305
306 pragma Assert
307 (Analyzer.Pattern_Size = 0 or else
308 Analyzer.Pattern_Size =
309 Stack_Size
310 (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark));
311 end;
312 end Fill_Stack;
313
314 -------------------------
315 -- Initialize_Analyzer --
316 -------------------------
317
318 procedure Initialize_Analyzer
319 (Analyzer : in out Stack_Analyzer;
320 Task_Name : String;
321 My_Stack_Size : Natural;
322 Max_Pattern_Size : Natural;
323 Bottom : Stack_Address;
324 Pattern : Unsigned_32 := 16#DEAD_BEEF#)
325 is
326 begin
327 -- Initialize the analyzer fields
328
329 Analyzer.Bottom_Of_Stack := Bottom;
330 Analyzer.Stack_Size := My_Stack_Size;
331 Analyzer.Pattern_Size := Max_Pattern_Size;
332 Analyzer.Pattern := Pattern;
333 Analyzer.Result_Id := Next_Id;
334 Analyzer.Task_Name := (others => ' ');
335
336 -- Compute the task name, and truncate if bigger than Task_Name_Length
337
338 if Task_Name'Length <= Task_Name_Length then
339 Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
340 else
341 Analyzer.Task_Name :=
342 Task_Name (Task_Name'First ..
343 Task_Name'First + Task_Name_Length - 1);
344 end if;
345
346 Next_Id := Next_Id + 1;
347 end Initialize_Analyzer;
348
349 ----------------
350 -- Stack_Size --
351 ----------------
352
353 function Stack_Size
354 (SP_Low : Stack_Address;
355 SP_High : Stack_Address) return Natural
356 is
357 begin
358 if SP_Low > SP_High then
359 return Natural (SP_Low - SP_High + 4);
360 else
361 return Natural (SP_High - SP_Low + 4);
362 end if;
363 end Stack_Size;
364
365 --------------------
366 -- Compute_Result --
367 --------------------
368
369 procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
370
371 -- Change the local variables and parameters of this function with
372 -- super-extra care. The larger the stack frame size of this function
373 -- is, the more an "instrumentation threshold at reading" error is
374 -- likely to happen.
375
376 Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
377 for Stack'Address use Analyzer.Stack_Overlay_Address;
378
379 begin
380 Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark;
381
382 if Analyzer.Pattern_Size = 0 then
383 return;
384 end if;
385
386 -- Look backward from the topmost possible end of the marked stack to
387 -- the bottom of it. The first index not equals to the patterns marks
388 -- the beginning of the used stack.
389
390 declare
391 Top_Index : constant Integer := Top_Slot_Index_In (Stack);
392 Bottom_Index : constant Integer := Bottom_Slot_Index_In (Stack);
393 Step : constant Integer := Pop_Index_Step_For (Stack);
394 J : Integer;
395
396 begin
397 J := Top_Index;
398 loop
399 if Stack (J) /= Analyzer.Pattern then
400 Analyzer.Topmost_Touched_Mark
401 := To_Stack_Address (Stack (J)'Address);
402 exit;
403 end if;
404
405 exit when J = Bottom_Index;
406 J := J + Step;
407 end loop;
408 end;
409 end Compute_Result;
410
411 ---------------------
412 -- Get_Usage_Range --
413 ---------------------
414
415 function Get_Usage_Range (Result : Task_Result) return String is
416 Variation_Used_Str : constant String :=
417 Natural'Image (Result.Variation);
418 Value_Used_Str : constant String :=
419 Natural'Image (Result.Value);
420 begin
421 return Value_Used_Str & " +/- " & Variation_Used_Str;
422 end Get_Usage_Range;
423
424 ---------------------
425 -- Output_Result --
426 ---------------------
427
428 procedure Output_Result
429 (Result_Id : Natural;
430 Result : Task_Result;
431 Max_Stack_Size_Len : Natural;
432 Max_Actual_Use_Len : Natural)
433 is
434 Result_Id_Str : constant String := Natural'Image (Result_Id);
435 My_Stack_Size_Str : constant String := Natural'Image (Result.Max_Size);
436 Actual_Use_Str : constant String := Get_Usage_Range (Result);
437
438 Result_Id_Blanks : constant
439 String (1 .. Index_Str'Length - Result_Id_Str'Length) :=
440 (others => ' ');
441
442 Stack_Size_Blanks : constant
443 String (1 .. Max_Stack_Size_Len - My_Stack_Size_Str'Length) :=
444 (others => ' ');
445
446 Actual_Use_Blanks : constant
447 String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
448 (others => ' ');
449
450 begin
451 Set_Output (Standard_Error);
452 Put (Result_Id_Blanks & Natural'Image (Result_Id));
453 Put (" | ");
454 Put (Result.Task_Name);
455 Put (" | ");
456 Put (Stack_Size_Blanks & My_Stack_Size_Str);
457 Put (" | ");
458 Put (Actual_Use_Blanks & Actual_Use_Str);
459 New_Line;
460 end Output_Result;
461
462 ---------------------
463 -- Output_Results --
464 ---------------------
465
466 procedure Output_Results is
467 Max_Stack_Size : Natural := 0;
468 Max_Actual_Use_Result_Id : Natural := Result_Array'First;
469 Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
470
471 Task_Name_Blanks : constant
472 String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
473 (others => ' ');
474
475 begin
476 Set_Output (Standard_Error);
477
478 if Compute_Environment_Task then
479 Compute_Result (Environment_Task_Analyzer);
480 Report_Result (Environment_Task_Analyzer);
481 end if;
482
483 if Result_Array'Length > 0 then
484
485 -- Computes the size of the largest strings that will get displayed,
486 -- in order to do correct column alignment.
487
488 for J in Result_Array'Range loop
489 exit when J >= Next_Id;
490
491 if Result_Array (J).Value >
492 Result_Array (Max_Actual_Use_Result_Id).Value
493 then
494 Max_Actual_Use_Result_Id := J;
495 end if;
496
497 if Result_Array (J).Max_Size > Max_Stack_Size then
498 Max_Stack_Size := Result_Array (J).Max_Size;
499 end if;
500 end loop;
501
502 Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
503
504 Max_Actual_Use_Len :=
505 Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'Length;
506
507 -- Display the output header. Blanks will be added in front of the
508 -- labels if needed.
509
510 declare
511 Stack_Size_Blanks : constant
512 String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
513 (others => ' ');
514
515 Stack_Usage_Blanks : constant
516 String (1 .. Max_Actual_Use_Len - Actual_Size_Str'Length) :=
517 (others => ' ');
518
519 begin
520 if Stack_Size_Str'Length > Max_Stack_Size_Len then
521 Max_Stack_Size_Len := Stack_Size_Str'Length;
522 end if;
523
524 if Actual_Size_Str'Length > Max_Actual_Use_Len then
525 Max_Actual_Use_Len := Actual_Size_Str'Length;
526 end if;
527
528 Put
529 (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
530 & Stack_Size_Str & Stack_Size_Blanks & " | "
531 & Stack_Usage_Blanks & Actual_Size_Str);
532 end;
533
534 New_Line;
535
536 -- Now display the individual results
537
538 for J in Result_Array'Range loop
539 exit when J >= Next_Id;
540 Output_Result
541 (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
542 end loop;
543
544 -- Case of no result stored, still display the labels
545
546 else
547 Put
548 (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
549 & Stack_Size_Str & " | " & Actual_Size_Str);
550 New_Line;
551 end if;
552 end Output_Results;
553
554 -------------------
555 -- Report_Result --
556 -------------------
557
558 procedure Report_Result (Analyzer : Stack_Analyzer) is
559 Result : Task_Result :=
560 (Task_Name => Analyzer.Task_Name,
561 Max_Size => Analyzer.Stack_Size,
562 Variation => 0,
563 Value => 0);
564
565 Overflow_Guard : constant Integer :=
566 Analyzer.Stack_Size
567 - Stack_Size (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Of_Stack);
568 Max, Min : Positive;
569
570 begin
571 if Analyzer.Pattern_Size = 0 then
572
573 -- If we have that result, it means that we didn't do any computation
574 -- at all. In other words, we used at least everything (and possibly
575 -- more).
576
577 Min := Analyzer.Stack_Size - Overflow_Guard;
578 Max := Analyzer.Stack_Size;
579
580 else
581 Min :=
582 Stack_Size
583 (Analyzer.Topmost_Touched_Mark, Analyzer.Bottom_Of_Stack);
584 Max := Min + Overflow_Guard;
585 end if;
586
587 Result.Value := (Max + Min) / 2;
588 Result.Variation := (Max - Min) / 2;
589
590 if Analyzer.Result_Id in Result_Array'Range then
591
592 -- If the result can be stored, then store it in Result_Array
593
594 Result_Array (Analyzer.Result_Id) := Result;
595
596 else
597 -- If the result cannot be stored, then we display it right away
598
599 declare
600 Result_Str_Len : constant Natural :=
601 Get_Usage_Range (Result)'Length;
602 Size_Str_Len : constant Natural :=
603 Natural'Image (Analyzer.Stack_Size)'Length;
604
605 Max_Stack_Size_Len : Natural;
606 Max_Actual_Use_Len : Natural;
607
608 begin
609 -- Take either the label size or the number image size for the
610 -- size of the column "Stack Size".
611
612 if Size_Str_Len > Stack_Size_Str'Length then
613 Max_Stack_Size_Len := Size_Str_Len;
614 else
615 Max_Stack_Size_Len := Stack_Size_Str'Length;
616 end if;
617
618 -- Take either the label size or the number image size for the
619 -- size of the column "Stack Usage"
620
621 if Result_Str_Len > Actual_Size_Str'Length then
622 Max_Actual_Use_Len := Result_Str_Len;
623 else
624 Max_Actual_Use_Len := Actual_Size_Str'Length;
625 end if;
626
627 Output_Result
628 (Analyzer.Result_Id,
629 Result,
630 Max_Stack_Size_Len,
631 Max_Actual_Use_Len);
632 end;
633 end if;
634 end Report_Result;
635
636 end System.Stack_Usage;
Mirror of the offical gcc git repository hosted at gcc.gnu.org