File : s-secsta.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S Y S T E M . S E C O N D A R Y _ S T A C K --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT 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 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 pragma Compiler_Unit_Warning;
33
34 with System.Soft_Links;
35 with System.Parameters;
36
37 with Ada.Unchecked_Conversion;
38 with Ada.Unchecked_Deallocation;
39
40 package body System.Secondary_Stack is
41
42 package SSL renames System.Soft_Links;
43
44 use type SSE.Storage_Offset;
45 use type System.Parameters.Size_Type;
46
47 SS_Ratio_Dynamic : constant Boolean :=
48 Parameters.Sec_Stack_Percentage = Parameters.Dynamic;
49 -- There are two entirely different implementations of the secondary
50 -- stack mechanism in this unit, and this Boolean is used to select
51 -- between them (at compile time, so the generated code will contain
52 -- only the code for the desired variant). If SS_Ratio_Dynamic is
53 -- True, then the secondary stack is dynamically allocated from the
54 -- heap in a linked list of chunks. If SS_Ration_Dynamic is False,
55 -- then the secondary stack is allocated statically by grabbing a
56 -- section of the primary stack and using it for this purpose.
57
58 type Memory is array (SS_Ptr range <>) of SSE.Storage_Element;
59 for Memory'Alignment use Standard'Maximum_Alignment;
60 -- This is the type used for actual allocation of secondary stack
61 -- areas. We require maximum alignment for all such allocations.
62
63 ---------------------------------------------------------------
64 -- Data Structures for Dynamically Allocated Secondary Stack --
65 ---------------------------------------------------------------
66
67 -- The following is a diagram of the data structures used for the
68 -- case of a dynamically allocated secondary stack, where the stack
69 -- is allocated as a linked list of chunks allocated from the heap.
70
71 -- +------------------+
72 -- | Next |
73 -- +------------------+
74 -- | | Last (200)
75 -- | |
76 -- | |
77 -- | |
78 -- | |
79 -- | |
80 -- | | First (101)
81 -- +------------------+
82 -- +----------> | | |
83 -- | +--------- | ------+
84 -- | ^ |
85 -- | | |
86 -- | | V
87 -- | +------ | ---------+
88 -- | | | |
89 -- | +------------------+
90 -- | | | Last (100)
91 -- | | C |
92 -- | | H |
93 -- +-----------------+ | +------->| U |
94 -- | Current_Chunk ----+ | | N |
95 -- +-----------------+ | | K |
96 -- | Top --------+ | | First (1)
97 -- +-----------------+ +------------------+
98 -- | Default_Size | | Prev |
99 -- +-----------------+ +------------------+
100 --
101
102 type Chunk_Id (First, Last : SS_Ptr);
103 type Chunk_Ptr is access all Chunk_Id;
104
105 type Chunk_Id (First, Last : SS_Ptr) is record
106 Prev, Next : Chunk_Ptr;
107 Mem : Memory (First .. Last);
108 end record;
109
110 type Stack_Id is record
111 Top : SS_Ptr;
112 Default_Size : SSE.Storage_Count;
113 Current_Chunk : Chunk_Ptr;
114 end record;
115
116 type Stack_Ptr is access Stack_Id;
117 -- Pointer to record used to represent a dynamically allocated secondary
118 -- stack descriptor for a secondary stack chunk.
119
120 procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
121 -- Free a dynamically allocated chunk
122
123 function To_Stack_Ptr is new
124 Ada.Unchecked_Conversion (Address, Stack_Ptr);
125 function To_Addr is new
126 Ada.Unchecked_Conversion (Stack_Ptr, Address);
127 -- Convert to and from address stored in task data structures
128
129 --------------------------------------------------------------
130 -- Data Structures for Statically Allocated Secondary Stack --
131 --------------------------------------------------------------
132
133 -- For the static case, the secondary stack is a single contiguous
134 -- chunk of storage, carved out of the primary stack, and represented
135 -- by the following data structure
136
137 type Fixed_Stack_Id is record
138 Top : SS_Ptr;
139 -- Index of next available location in Mem. This is initialized to
140 -- 0, and then incremented on Allocate, and Decremented on Release.
141
142 Last : SS_Ptr;
143 -- Length of usable Mem array, which is thus the index past the
144 -- last available location in Mem. Mem (Last-1) can be used. This
145 -- is used to check that the stack does not overflow.
146
147 Max : SS_Ptr;
148 -- Maximum value of Top. Initialized to 0, and then may be incremented
149 -- on Allocate, but is never Decremented. The last used location will
150 -- be Mem (Max - 1), so Max is the maximum count of used stack space.
151
152 Mem : Memory (0 .. 0);
153 -- This is the area that is actually used for the secondary stack.
154 -- Note that the upper bound is a dummy value properly defined by
155 -- the value of Last. We never actually allocate objects of type
156 -- Fixed_Stack_Id, so the bounds declared here do not matter.
157 end record;
158
159 Dummy_Fixed_Stack : Fixed_Stack_Id;
160 pragma Warnings (Off, Dummy_Fixed_Stack);
161 -- Well it is not quite true that we never allocate an object of the
162 -- type. This dummy object is allocated for the purpose of getting the
163 -- offset of the Mem field via the 'Position attribute (such a nuisance
164 -- that we cannot apply this to a field of a type).
165
166 type Fixed_Stack_Ptr is access Fixed_Stack_Id;
167 -- Pointer to record used to describe statically allocated sec stack
168
169 function To_Fixed_Stack_Ptr is new
170 Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr);
171 -- Convert from address stored in task data structures
172
173 --------------
174 -- Allocate --
175 --------------
176
177 procedure SS_Allocate
178 (Addr : out Address;
179 Storage_Size : SSE.Storage_Count)
180 is
181 Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
182 Max_Size : constant SS_Ptr :=
183 ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) *
184 Max_Align;
185
186 begin
187 -- Case of fixed allocation secondary stack
188
189 if not SS_Ratio_Dynamic then
190 declare
191 Fixed_Stack : constant Fixed_Stack_Ptr :=
192 To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
193
194 begin
195 -- Check if max stack usage is increasing
196
197 if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then
198
199 -- If so, check if max size is exceeded
200
201 if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
202 raise Storage_Error;
203 end if;
204
205 -- Record new max usage
206
207 Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;
208 end if;
209
210 -- Set resulting address and update top of stack pointer
211
212 Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
213 Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;
214 end;
215
216 -- Case of dynamically allocated secondary stack
217
218 else
219 declare
220 Stack : constant Stack_Ptr :=
221 To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
222 Chunk : Chunk_Ptr;
223
224 To_Be_Released_Chunk : Chunk_Ptr;
225
226 begin
227 Chunk := Stack.Current_Chunk;
228
229 -- The Current_Chunk may not be the good one if a lot of release
230 -- operations have taken place. Go down the stack if necessary.
231
232 while Chunk.First > Stack.Top loop
233 Chunk := Chunk.Prev;
234 end loop;
235
236 -- Find out if the available memory in the current chunk is
237 -- sufficient, if not, go to the next one and eventually create
238 -- the necessary room.
239
240 while Chunk.Last - Stack.Top + 1 < Max_Size loop
241 if Chunk.Next /= null then
242
243 -- Release unused non-first empty chunk
244
245 if Chunk.Prev /= null and then Chunk.First = Stack.Top then
246 To_Be_Released_Chunk := Chunk;
247 Chunk := Chunk.Prev;
248 Chunk.Next := To_Be_Released_Chunk.Next;
249 To_Be_Released_Chunk.Next.Prev := Chunk;
250 Free (To_Be_Released_Chunk);
251 end if;
252
253 -- Create new chunk of default size unless it is not sufficient
254 -- to satisfy the current request.
255
256 elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
257 Chunk.Next :=
258 new Chunk_Id
259 (First => Chunk.Last + 1,
260 Last => Chunk.Last + SS_Ptr (Stack.Default_Size));
261
262 Chunk.Next.Prev := Chunk;
263
264 -- Otherwise create new chunk of requested size
265
266 else
267 Chunk.Next :=
268 new Chunk_Id
269 (First => Chunk.Last + 1,
270 Last => Chunk.Last + Max_Size);
271
272 Chunk.Next.Prev := Chunk;
273 end if;
274
275 Chunk := Chunk.Next;
276 Stack.Top := Chunk.First;
277 end loop;
278
279 -- Resulting address is the address pointed by Stack.Top
280
281 Addr := Chunk.Mem (Stack.Top)'Address;
282 Stack.Top := Stack.Top + Max_Size;
283 Stack.Current_Chunk := Chunk;
284 end;
285 end if;
286 end SS_Allocate;
287
288 -------------
289 -- SS_Free --
290 -------------
291
292 procedure SS_Free (Stk : in out Address) is
293 begin
294 -- Case of statically allocated secondary stack, nothing to free
295
296 if not SS_Ratio_Dynamic then
297 return;
298
299 -- Case of dynamically allocated secondary stack
300
301 else
302 declare
303 Stack : Stack_Ptr := To_Stack_Ptr (Stk);
304 Chunk : Chunk_Ptr;
305
306 procedure Free is
307 new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr);
308
309 begin
310 Chunk := Stack.Current_Chunk;
311
312 while Chunk.Prev /= null loop
313 Chunk := Chunk.Prev;
314 end loop;
315
316 while Chunk.Next /= null loop
317 Chunk := Chunk.Next;
318 Free (Chunk.Prev);
319 end loop;
320
321 Free (Chunk);
322 Free (Stack);
323 Stk := Null_Address;
324 end;
325 end if;
326 end SS_Free;
327
328 ----------------
329 -- SS_Get_Max --
330 ----------------
331
332 function SS_Get_Max return Long_Long_Integer is
333 begin
334 if SS_Ratio_Dynamic then
335 return -1;
336 else
337 declare
338 Fixed_Stack : constant Fixed_Stack_Ptr :=
339 To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
340 begin
341 return Long_Long_Integer (Fixed_Stack.Max);
342 end;
343 end if;
344 end SS_Get_Max;
345
346 -------------
347 -- SS_Info --
348 -------------
349
350 procedure SS_Info is
351 begin
352 Put_Line ("Secondary Stack information:");
353
354 -- Case of fixed secondary stack
355
356 if not SS_Ratio_Dynamic then
357 declare
358 Fixed_Stack : constant Fixed_Stack_Ptr :=
359 To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
360
361 begin
362 Put_Line (
363 " Total size : "
364 & SS_Ptr'Image (Fixed_Stack.Last)
365 & " bytes");
366
367 Put_Line (
368 " Current allocated space : "
369 & SS_Ptr'Image (Fixed_Stack.Top - 1)
370 & " bytes");
371 end;
372
373 -- Case of dynamically allocated secondary stack
374
375 else
376 declare
377 Stack : constant Stack_Ptr :=
378 To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
379 Nb_Chunks : Integer := 1;
380 Chunk : Chunk_Ptr := Stack.Current_Chunk;
381
382 begin
383 while Chunk.Prev /= null loop
384 Chunk := Chunk.Prev;
385 end loop;
386
387 while Chunk.Next /= null loop
388 Nb_Chunks := Nb_Chunks + 1;
389 Chunk := Chunk.Next;
390 end loop;
391
392 -- Current Chunk information
393
394 Put_Line (
395 " Total size : "
396 & SS_Ptr'Image (Chunk.Last)
397 & " bytes");
398
399 Put_Line (
400 " Current allocated space : "
401 & SS_Ptr'Image (Stack.Top - 1)
402 & " bytes");
403
404 Put_Line (
405 " Number of Chunks : "
406 & Integer'Image (Nb_Chunks));
407
408 Put_Line (
409 " Default size of Chunks : "
410 & SSE.Storage_Count'Image (Stack.Default_Size));
411 end;
412 end if;
413 end SS_Info;
414
415 -------------
416 -- SS_Init --
417 -------------
418
419 procedure SS_Init
420 (Stk : in out Address;
421 Size : Natural := Default_Secondary_Stack_Size)
422 is
423 begin
424 -- Case of fixed size secondary stack
425
426 if not SS_Ratio_Dynamic then
427 declare
428 Fixed_Stack : constant Fixed_Stack_Ptr :=
429 To_Fixed_Stack_Ptr (Stk);
430
431 begin
432 Fixed_Stack.Top := 0;
433 Fixed_Stack.Max := 0;
434
435 if Size < Dummy_Fixed_Stack.Mem'Position then
436 Fixed_Stack.Last := 0;
437 else
438 Fixed_Stack.Last :=
439 SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
440 end if;
441 end;
442
443 -- Case of dynamically allocated secondary stack
444
445 else
446 declare
447 Stack : Stack_Ptr;
448 begin
449 Stack := new Stack_Id;
450 Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
451 Stack.Top := 1;
452 Stack.Default_Size := SSE.Storage_Count (Size);
453 Stk := To_Addr (Stack);
454 end;
455 end if;
456 end SS_Init;
457
458 -------------
459 -- SS_Mark --
460 -------------
461
462 function SS_Mark return Mark_Id is
463 Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
464 begin
465 if SS_Ratio_Dynamic then
466 return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
467 else
468 return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
469 end if;
470 end SS_Mark;
471
472 ----------------
473 -- SS_Release --
474 ----------------
475
476 procedure SS_Release (M : Mark_Id) is
477 begin
478 if SS_Ratio_Dynamic then
479 To_Stack_Ptr (M.Sstk).Top := M.Sptr;
480 else
481 To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
482 end if;
483 end SS_Release;
484
485 -------------------------
486 -- Package Elaboration --
487 -------------------------
488
489 -- Allocate a secondary stack for the main program to use
490
491 -- We make sure that the stack has maximum alignment. Some systems require
492 -- this (e.g. Sparc), and in any case it is a good idea for efficiency.
493
494 Stack : aliased Stack_Id;
495 for Stack'Alignment use Standard'Maximum_Alignment;
496
497 Static_Secondary_Stack_Size : constant := 10 * 1024;
498 -- Static_Secondary_Stack_Size must be static so that Chunk is allocated
499 -- statically, and not via dynamic memory allocation.
500
501 Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size);
502 for Chunk'Alignment use Standard'Maximum_Alignment;
503 -- Default chunk used, unless gnatbind -D is specified with a value greater
504 -- than Static_Secondary_Stack_Size.
505
506 begin
507 declare
508 Chunk_Address : Address;
509 Chunk_Access : Chunk_Ptr;
510
511 begin
512 if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then
513
514 -- Normally we allocate the secondary stack for the main program
515 -- statically, using the default secondary stack size.
516
517 Chunk_Access := Chunk'Access;
518
519 else
520 -- Default_Secondary_Stack_Size was increased via gnatbind -D, so we
521 -- need to allocate a chunk dynamically.
522
523 Chunk_Access :=
524 new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
525 end if;
526
527 if SS_Ratio_Dynamic then
528 Stack.Top := 1;
529 Stack.Current_Chunk := Chunk_Access;
530 Stack.Default_Size :=
531 SSE.Storage_Offset (Default_Secondary_Stack_Size);
532 System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
533
534 else
535 Chunk_Address := Chunk_Access.all'Address;
536 SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
537 System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
538 end if;
539 end;
540 end System.Secondary_Stack;