?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gcc.dg/compat/struct-layout-1_generate.c (dg_options): New. Moved
[official-gcc.git] / gcc / ada / s-stausa.adb
blobff5f86e1668c7cfb19d2631e9384dae97f18dd24
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-2008, 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 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. --
21 -- --
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. --
28 -- --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 -- --
32 ------------------------------------------------------------------------------
33
34 with System.Parameters;
35 with System.CRTL;
36 with System.IO;
37
38 package body System.Stack_Usage is
39 use System.Storage_Elements;
40 use System;
41 use System.IO;
42 use Interfaces;
43
44 -----------------
45 -- Stack_Slots --
46 -----------------
47
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.
51
52 type Stack_Slots is array (Integer range <>) of Pattern_Type;
53 for Stack_Slots'Component_Size use Pattern_Type'Object_Size;
54
55 -- We will carefully handle the initializations ourselves and might want
56 -- to remap an initialized overlay later on with an address clause.
57
58 pragma Suppress_Initialization (Stack_Slots);
59
60 -- The abstract Stack_Slots operations all operate over the simple array
61 -- memory model:
62
63 -- memory addresses increasing ---->
64
65 -- Slots('First) Slots('Last)
66 -- | |
67 -- V V
68 -- +------------------------------------------------------------------+
69 -- |####| |####|
70 -- +------------------------------------------------------------------+
71
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:
75
76 -- Stack_Grows_Down
77
78 -- <----- calls push frames towards decreasing addresses
79
80 -- Top(most) Slot Bottom(most) Slot
81 -- | |
82 -- V V
83 -- +------------------------------------------------------------------+
84 -- |####| | leaf frame | ... | entry frame |
85 -- +------------------------------------------------------------------+
86
87 -- Stack_Grows_Up
88
89 -- calls push frames towards increasing addresses ----->
90
91 -- Bottom(most) Slot Top(most) Slot
92 -- | |
93 -- V V
94 -- +------------------------------------------------------------------+
95 -- | entry frame | ... | leaf frame | |####|
96 -- +------------------------------------------------------------------+
97
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.
101
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.
105
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
108 -- the stack.
109
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
112 -- the stack.
113
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);
118
119 -----------------------
120 -- Top_Slot_Index_In --
121 -----------------------
122
123 function Top_Slot_Index_In (Stack : Stack_Slots) return Integer is
124 begin
125 if System.Parameters.Stack_Grows_Down then
126 return Stack'First;
127 else
128 return Stack'Last;
129 end if;
130 end Top_Slot_Index_In;
131
132 ----------------------------
133 -- Bottom_Slot_Index_In --
134 ----------------------------
135
136 function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer is
137 begin
138 if System.Parameters.Stack_Grows_Down then
139 return Stack'Last;
140 else
141 return Stack'First;
142 end if;
143 end Bottom_Slot_Index_In;
144
145 -------------------------
146 -- Push_Index_Step_For --
147 -------------------------
148
149 function Push_Index_Step_For (Stack : Stack_Slots) return Integer is
150 pragma Unreferenced (Stack);
151 begin
152 if System.Parameters.Stack_Grows_Down then
153 return -1;
154 else
155 return +1;
156 end if;
157 end Push_Index_Step_For;
158
159 ------------------------
160 -- Pop_Index_Step_For --
161 ------------------------
162
163 function Pop_Index_Step_For (Stack : Stack_Slots) return Integer is
164 begin
165 return -Push_Index_Step_For (Stack);
166 end Pop_Index_Step_For;
167
168 -------------------
169 -- Unit Services --
170 -------------------
171
172 -- Now the implementation of the services offered by this unit, on top of
173 -- the Stack_Slots abstraction above.
174
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]";
179
180 function Get_Usage_Range (Result : Task_Result) return String;
181 -- Return string representing the range of possible result of stack usage
182
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.
193
194 ----------------
195 -- Initialize --
196 ----------------
197
198 procedure Initialize (Buffer_Size : Natural) is
199 Bottom_Of_Stack : aliased Integer;
200 Stack_Size_Chars : System.Address;
201
202 begin
203 -- Initialize the buffered result array
204
205 Result_Array := new Result_Array_Type (1 .. Buffer_Size);
206 Result_Array.all :=
207 (others =>
208 (Task_Name => (others => ASCII.NUL),
209 Min_Measure => 0,
210 Max_Measure => 0,
211 Max_Size => 0));
212
213 -- Set the Is_Enabled flag to true, so that the task wrapper knows that
214 -- it has to handle dynamic stack analysis
215
216 Is_Enabled := True;
217
218 Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL);
219
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).
224
225 if Stack_Size_Chars /= Null_Address then
226 declare
227 Stack_Size : Integer;
228
229 begin
230 Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024;
231
232 Initialize_Analyzer
233 (Environment_Task_Analyzer,
234 "ENVIRONMENT TASK",
235 Stack_Size,
236 Stack_Size,
237 System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address));
238
239 Fill_Stack (Environment_Task_Analyzer);
240
241 Compute_Environment_Task := True;
242 end;
243
244 -- GNAT_STACK_LIMIT not set
245
246 else
247 Compute_Environment_Task := False;
248 end if;
249 end Initialize;
250
251 ----------------
252 -- Fill_Stack --
253 ----------------
254
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
259 -- likely to happen.
260
261 Stack_Used_When_Filling : Integer;
262 Current_Stack_Level : aliased Integer;
263
264 begin
265 -- Readjust the pattern size. When we arrive in this function, there is
266 -- already a given amount of stack used, that we won't analyze.
267
268 Stack_Used_When_Filling :=
269 Stack_Size
270 (Analyzer.Bottom_Of_Stack,
271 To_Stack_Address (Current_Stack_Level'Address))
272 + Natural (Current_Stack_Level'Size);
273
274 if Stack_Used_When_Filling > Analyzer.Pattern_Size then
275 -- In this case, the known size of the stack is too small, we've
276 -- already taken more than expected, so there's no possible
277 -- computation
278
279 Analyzer.Pattern_Size := 0;
280 else
281 Analyzer.Pattern_Size :=
282 Analyzer.Pattern_Size - Stack_Used_When_Filling;
283 end if;
284
285 declare
286 Stack : aliased Stack_Slots
287 (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
288
289 begin
290 Stack := (others => Analyzer.Pattern);
291
292 Analyzer.Stack_Overlay_Address := Stack'Address;
293
294 if Analyzer.Pattern_Size /= 0 then
295 Analyzer.Bottom_Pattern_Mark :=
296 To_Stack_Address (Stack (Bottom_Slot_Index_In (Stack))'Address);
297 Analyzer.Top_Pattern_Mark :=
298 To_Stack_Address (Stack (Top_Slot_Index_In (Stack))'Address);
299 else
300 Analyzer.Bottom_Pattern_Mark := To_Stack_Address (Stack'Address);
301 Analyzer.Top_Pattern_Mark := To_Stack_Address (Stack'Address);
302 end if;
303
304 -- If Arr has been packed, the following assertion must be true (we
305 -- add the size of the element whose address is:
306 -- Min (Analyzer.Inner_Pattern_Mark, Analyzer.Outer_Pattern_Mark)):
307
308 pragma Assert
309 (Analyzer.Pattern_Size = 0 or else
310 Analyzer.Pattern_Size =
311 Stack_Size
312 (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Pattern_Mark));
313 end;
314 end Fill_Stack;
315
316 -------------------------
317 -- Initialize_Analyzer --
318 -------------------------
319
320 procedure Initialize_Analyzer
321 (Analyzer : in out Stack_Analyzer;
322 Task_Name : String;
323 Stack_Size : Natural;
324 Max_Pattern_Size : Natural;
325 Bottom : Stack_Address;
326 Pattern : Unsigned_32 := 16#DEAD_BEEF#)
327 is
328 begin
329 -- Initialize the analyzer fields
330
331 Analyzer.Bottom_Of_Stack := Bottom;
332 Analyzer.Stack_Size := Stack_Size;
333 Analyzer.Pattern_Size := Max_Pattern_Size;
334 Analyzer.Pattern := Pattern;
335 Analyzer.Result_Id := Next_Id;
336
337 Analyzer.Task_Name := (others => ' ');
338
339 -- Compute the task name, and truncate if bigger than Task_Name_Length
340
341 if Task_Name'Length <= Task_Name_Length then
342 Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name;
343 else
344 Analyzer.Task_Name :=
345 Task_Name (Task_Name'First ..
346 Task_Name'First + Task_Name_Length - 1);
347 end if;
348
349 Next_Id := Next_Id + 1;
350 end Initialize_Analyzer;
351
352 ----------------
353 -- Stack_Size --
354 ----------------
355
356 function Stack_Size
357 (SP_Low : Stack_Address;
358 SP_High : Stack_Address) return Natural
359 is
360 begin
361 if SP_Low > SP_High then
362 return Natural (SP_Low - SP_High + 4);
363 else
364 return Natural (SP_High - SP_Low + 4);
365 end if;
366 end Stack_Size;
367
368 --------------------
369 -- Compute_Result --
370 --------------------
371
372 procedure Compute_Result (Analyzer : in out Stack_Analyzer) is
373
374 -- Change the local variables and parameters of this function with
375 -- super-extra care. The larger the stack frame size of this function
376 -- is, the more an "instrumentation threshold at reading" error is
377 -- likely to happen.
378
379 Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
380 for Stack'Address use Analyzer.Stack_Overlay_Address;
381
382 begin
383 Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark;
384
385 if Analyzer.Pattern_Size = 0 then
386 return;
387 end if;
388
389 -- Look backward from the topmost possible end of the marked stack to
390 -- the bottom of it. The first index not equals to the patterns marks
391 -- the beginning of the used stack.
392
393 declare
394 Top_Index : constant Integer := Top_Slot_Index_In (Stack);
395 Bottom_Index : constant Integer := Bottom_Slot_Index_In (Stack);
396 Step : constant Integer := Pop_Index_Step_For (Stack);
397 J : Integer;
398
399 begin
400 J := Top_Index;
401 loop
402 if Stack (J) /= Analyzer.Pattern then
403 Analyzer.Topmost_Touched_Mark
404 := To_Stack_Address (Stack (J)'Address);
405 exit;
406 end if;
407
408 exit when J = Bottom_Index;
409 J := J + Step;
410 end loop;
411 end;
412 end Compute_Result;
413
414 ---------------------
415 -- Get_Usage_Range --
416 ---------------------
417
418 function Get_Usage_Range (Result : Task_Result) return String is
419 Min_Used_Str : constant String := Natural'Image (Result.Min_Measure);
420 Max_Used_Str : constant String := Natural'Image (Result.Max_Measure);
421 begin
422 return "[" & Min_Used_Str (2 .. Min_Used_Str'Last) & " -"
423 & Max_Used_Str & "]";
424 end Get_Usage_Range;
425
426 ---------------------
427 -- Output_Result --
428 ---------------------
429
430 procedure Output_Result
431 (Result_Id : Natural;
432 Result : Task_Result;
433 Max_Stack_Size_Len : Natural;
434 Max_Actual_Use_Len : Natural)
435 is
436 Result_Id_Str : constant String := Natural'Image (Result_Id);
437 Stack_Size_Str : constant String := Natural'Image (Result.Max_Size);
438 Actual_Use_Str : constant String := Get_Usage_Range (Result);
439
440 Result_Id_Blanks : constant
441 String (1 .. Index_Str'Length - Result_Id_Str'Length) :=
442 (others => ' ');
443
444 Stack_Size_Blanks : constant
445 String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
446 (others => ' ');
447
448 Actual_Use_Blanks : constant
449 String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) :=
450 (others => ' ');
451
452 begin
453 Set_Output (Standard_Error);
454 Put (Result_Id_Blanks & Natural'Image (Result_Id));
455 Put (" | ");
456 Put (Result.Task_Name);
457 Put (" | ");
458 Put (Stack_Size_Blanks & Stack_Size_Str);
459 Put (" | ");
460 Put (Actual_Use_Blanks & Actual_Use_Str);
461 New_Line;
462 end Output_Result;
463
464 ---------------------
465 -- Output_Results --
466 ---------------------
467
468 procedure Output_Results is
469 Max_Stack_Size : Natural := 0;
470 Max_Actual_Use_Result_Id : Natural := Result_Array'First;
471 Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
472
473 Task_Name_Blanks : constant
474 String (1 .. Task_Name_Length - Task_Name_Str'Length) :=
475 (others => ' ');
476
477 begin
478 Set_Output (Standard_Error);
479
480 if Compute_Environment_Task then
481 Compute_Result (Environment_Task_Analyzer);
482 Report_Result (Environment_Task_Analyzer);
483 end if;
484
485 if Result_Array'Length > 0 then
486
487 -- Computes the size of the largest strings that will get displayed,
488 -- in order to do correct column alignment.
489
490 for J in Result_Array'Range loop
491 exit when J >= Next_Id;
492
493 if Result_Array (J).Max_Measure
494 > Result_Array (Max_Actual_Use_Result_Id).Max_Measure
495 then
496 Max_Actual_Use_Result_Id := J;
497 end if;
498
499 if Result_Array (J).Max_Size > Max_Stack_Size then
500 Max_Stack_Size := Result_Array (J).Max_Size;
501 end if;
502 end loop;
503
504 Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
505
506 Max_Actual_Use_Len :=
507 Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'Length;
508
509 -- Display the output header. Blanks will be added in front of the
510 -- labels if needed.
511
512 declare
513 Stack_Size_Blanks : constant
514 String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
515 (others => ' ');
516
517 Stack_Usage_Blanks : constant
518 String (1 .. Max_Actual_Use_Len - Actual_Size_Str'Length) :=
519 (others => ' ');
520
521 begin
522 if Stack_Size_Str'Length > Max_Stack_Size_Len then
523 Max_Stack_Size_Len := Stack_Size_Str'Length;
524 end if;
525
526 if Actual_Size_Str'Length > Max_Actual_Use_Len then
527 Max_Actual_Use_Len := Actual_Size_Str'Length;
528 end if;
529
530 Put
531 (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
532 & Stack_Size_Str & Stack_Size_Blanks & " | "
533 & Stack_Usage_Blanks & Actual_Size_Str);
534 end;
535
536 New_Line;
537
538 -- Now display the individual results
539
540 for J in Result_Array'Range loop
541 exit when J >= Next_Id;
542 Output_Result
543 (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len);
544 end loop;
545
546 -- Case of no result stored, still display the labels
547
548 else
549 Put
550 (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | "
551 & Stack_Size_Str & " | " & Actual_Size_Str);
552 New_Line;
553 end if;
554 end Output_Results;
555
556 -------------------
557 -- Report_Result --
558 -------------------
559
560 procedure Report_Result (Analyzer : Stack_Analyzer) is
561 Result : Task_Result :=
562 (Task_Name => Analyzer.Task_Name,
563 Max_Size => Analyzer.Stack_Size,
564 Min_Measure => 0,
565 Max_Measure => 0);
566
567 Overflow_Guard : constant Integer :=
568 Analyzer.Stack_Size
569 - Stack_Size (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Of_Stack);
570
571 begin
572 if Analyzer.Pattern_Size = 0 then
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 Result.Min_Measure := Analyzer.Stack_Size - Overflow_Guard;
578 Result.Max_Measure := Analyzer.Stack_Size;
579 else
580 Result.Min_Measure := Stack_Size
581 (Analyzer.Topmost_Touched_Mark,
582 Analyzer.Bottom_Of_Stack);
583 Result.Max_Measure := Result.Min_Measure + Overflow_Guard;
584 end if;
585
586 if Analyzer.Result_Id in Result_Array'Range then
587
588 -- If the result can be stored, then store it in Result_Array
589
590 Result_Array (Analyzer.Result_Id) := Result;
591
592 else
593 -- If the result cannot be stored, then we display it right away
594
595 declare
596 Result_Str_Len : constant Natural :=
597 Get_Usage_Range (Result)'Length;
598 Size_Str_Len : constant Natural :=
599 Natural'Image (Analyzer.Stack_Size)'Length;
600
601 Max_Stack_Size_Len : Natural;
602 Max_Actual_Use_Len : Natural;
603
604 begin
605 -- Take either the label size or the number image size for the
606 -- size of the column "Stack Size".
607
608 if Size_Str_Len > Stack_Size_Str'Length then
609 Max_Stack_Size_Len := Size_Str_Len;
610 else
611 Max_Stack_Size_Len := Stack_Size_Str'Length;
612 end if;
613
614 -- Take either the label size or the number image size for the
615 -- size of the column "Stack Usage"
616
617 if Result_Str_Len > Actual_Size_Str'Length then
618 Max_Actual_Use_Len := Result_Str_Len;
619 else
620 Max_Actual_Use_Len := Actual_Size_Str'Length;
621 end if;
622
623 Output_Result
624 (Analyzer.Result_Id,
625 Result,
626 Max_Stack_Size_Len,
627 Max_Actual_Use_Len);
628 end;
629 end if;
630 end Report_Result;
631
632 end System.Stack_Usage;
Mirror of the offical gcc git repository hosted at gcc.gnu.org