1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S E C O N D A R Y _ S T A C K --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
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. --
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 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 pragma Compiler_Unit_Warning
;
34 with Ada
.Unchecked_Conversion
;
35 with Ada
.Unchecked_Deallocation
;
36 with System
.Soft_Links
;
38 package body System
.Secondary_Stack
is
40 package SSL
renames System
.Soft_Links
;
42 use type System
.Parameters
.Size_Type
;
44 procedure Free
is new Ada
.Unchecked_Deallocation
(Chunk_Id
, Chunk_Ptr
);
45 -- Free a dynamically allocated chunk
53 Storage_Size
: SSE
.Storage_Count
)
55 use type System
.Storage_Elements
.Storage_Count
;
57 Max_Align
: constant SS_Ptr
:= SS_Ptr
(Standard
'Maximum_Alignment);
60 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
62 -- Round up Storage_Size to the nearest multiple of the max alignment
63 -- value for the target. This ensures efficient stack access. First
64 -- perform a check to ensure that the rounding operation does not
67 if SSE
.Storage_Count
(SS_Ptr
'Last) - Standard
'Maximum_Alignment <
73 Mem_Request
:= ((SS_Ptr
(Storage_Size
) + Max_Align
- 1) / Max_Align
) *
76 -- Case of fixed secondary stack
78 if not SP
.Sec_Stack_Dynamic
then
79 -- Check if max stack usage is increasing
81 if Stack
.Max
- Stack
.Top
- Mem_Request
< 0 then
83 -- If so, check if the stack is exceeded, noting Stack.Top points
84 -- to the first free byte (so the value of Stack.Top on a fully
85 -- allocated stack will be Stack.Size + 1). The comparison is
86 -- formed to prevent integer overflows.
88 if Stack
.Size
- Stack
.Top
- Mem_Request
< -1 then
92 -- Record new max usage
94 Stack
.Max
:= Stack
.Top
+ Mem_Request
;
97 -- Set resulting address and update top of stack pointer
99 Addr
:= Stack
.Internal_Chunk
.Mem
(Stack
.Top
)'Address;
100 Stack
.Top
:= Stack
.Top
+ Mem_Request
;
102 -- Case of dynamic secondary stack
108 To_Be_Released_Chunk
: Chunk_Ptr
;
111 Chunk
:= Stack
.Current_Chunk
;
113 -- The Current_Chunk may not be the best one if a lot of release
114 -- operations have taken place. Go down the stack if necessary.
116 while Chunk
.First
> Stack
.Top
loop
120 -- Find out if the available memory in the current chunk is
121 -- sufficient, if not, go to the next one and eventually create
122 -- the necessary room.
124 while Chunk
.Last
- Stack
.Top
- Mem_Request
< -1 loop
125 if Chunk
.Next
/= null then
126 -- Release unused non-first empty chunk
128 if Chunk
.Prev
/= null and then Chunk
.First
= Stack
.Top
then
129 To_Be_Released_Chunk
:= Chunk
;
131 Chunk
.Next
:= To_Be_Released_Chunk
.Next
;
132 To_Be_Released_Chunk
.Next
.Prev
:= Chunk
;
133 Free
(To_Be_Released_Chunk
);
136 -- Create a new chunk
139 -- The new chunk should be no smaller than the default
140 -- chunk size to minimize the amount of secondary stack
143 if Mem_Request
<= Stack
.Size
then
144 Chunk_Size
:= Stack
.Size
;
146 Chunk_Size
:= Mem_Request
;
149 -- Check that the indexing limits are not exceeded
151 if SS_Ptr
'Last - Chunk
.Last
- Chunk_Size
< 0 then
157 (First
=> Chunk
.Last
+ 1,
158 Last
=> Chunk
.Last
+ Chunk_Size
);
160 Chunk
.Next
.Prev
:= Chunk
;
164 Stack
.Top
:= Chunk
.First
;
167 -- Resulting address is the address pointed by Stack.Top
169 Addr
:= Chunk
.Mem
(Stack
.Top
)'Address;
170 Stack
.Top
:= Stack
.Top
+ Mem_Request
;
171 Stack
.Current_Chunk
:= Chunk
;
173 -- Record new max usage
175 if Stack
.Top
> Stack
.Max
then
176 Stack
.Max
:= Stack
.Top
;
187 procedure SS_Free
(Stack
: in out SS_Stack_Ptr
) is
189 new Ada
.Unchecked_Deallocation
(SS_Stack
, SS_Stack_Ptr
);
191 -- If using dynamic secondary stack, free any external chunks
193 if SP
.Sec_Stack_Dynamic
then
198 new Ada
.Unchecked_Deallocation
(Chunk_Id
, Chunk_Ptr
);
201 Chunk
:= Stack
.Current_Chunk
;
203 -- Go to top of linked list and free backwards. Do not free the
204 -- internal chunk as it is part of SS_Stack.
206 while Chunk
.Next
/= null loop
210 while Chunk
.Prev
/= null loop
217 if Stack
.Freeable
then
226 function SS_Get_Max
return Long_Long_Integer is
227 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
229 -- Stack.Max points to the first untouched byte in the stack, thus the
230 -- maximum number of bytes that have been allocated on the stack is one
231 -- less the value of Stack.Max.
233 return Long_Long_Integer (Stack
.Max
- 1);
241 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
243 Put_Line
("Secondary Stack information:");
245 -- Case of fixed secondary stack
247 if not SP
.Sec_Stack_Dynamic
then
248 Put_Line
(" Total size : "
249 & SS_Ptr
'Image (Stack
.Size
)
252 Put_Line
(" Current allocated space : "
253 & SS_Ptr
'Image (Stack
.Top
- 1)
256 -- Case of dynamic secondary stack
260 Nb_Chunks
: Integer := 1;
261 Chunk
: Chunk_Ptr
:= Stack
.Current_Chunk
;
264 while Chunk
.Prev
/= null loop
268 while Chunk
.Next
/= null loop
269 Nb_Chunks
:= Nb_Chunks
+ 1;
273 -- Current Chunk information
275 -- Note that First of each chunk is one more than Last of the
276 -- previous one, so Chunk.Last is the total size of all chunks; we
277 -- don't need to walk all the chunks to compute the total size.
279 Put_Line
(" Total size : "
280 & SS_Ptr
'Image (Chunk
.Last
)
283 Put_Line
(" Current allocated space : "
284 & SS_Ptr
'Image (Stack
.Top
- 1)
287 Put_Line
(" Number of Chunks : "
288 & Integer'Image (Nb_Chunks
));
290 Put_Line
(" Default size of Chunks : "
291 & SP
.Size_Type
'Image (Stack
.Size
));
301 (Stack
: in out SS_Stack_Ptr
;
302 Size
: SP
.Size_Type
:= SP
.Unspecified_Size
)
306 Stack_Size
: Size_Type
;
308 -- If Stack is not null then the stack has been allocated outside the
309 -- package (by the compiler or the user) and all that is left to do is
310 -- initialize the stack. Otherwise, SS_Init will allocate a secondary
311 -- stack from either the heap or the default-sized secondary stack pool
312 -- generated by the binder. In the later case, this pool is generated
313 -- only when the either No_Implicit_Heap_Allocations
314 -- or No_Implicit_Task_Allocations are active, and SS_Init will allocate
315 -- all requests for a secondary stack of Unspecified_Size from this
319 if Size
= Unspecified_Size
then
320 -- Cover the case when bootstraping with an old compiler that does
321 -- not set Default_SS_Size.
323 if Default_SS_Size
> 0 then
324 Stack_Size
:= Default_SS_Size
;
326 Stack_Size
:= Runtime_Default_Sec_Stack_Size
;
333 if Size
= Unspecified_Size
334 and then Binder_SS_Count
> 0
335 and then Num_Of_Assigned_Stacks
< Binder_SS_Count
337 -- The default-sized secondary stack pool is passed from the
338 -- binder to this package as an Address since it is not possible
339 -- to have a pointer to an array of unconstrained objects. A
340 -- pointer to the pool is obtainable via an unchecked conversion
341 -- to a constrained array of SS_Stacks that mirrors the one used
344 -- However, Ada understandably does not allow a local pointer to
345 -- a stack in the pool to be stored in a pointer outside of this
346 -- scope. While the conversion is safe in this case, since a view
347 -- of a global object is being used, using Unchecked_Access
348 -- would prevent users from specifying the restriction
349 -- No_Unchecked_Access whenever the secondary stack is used. As
350 -- a workaround, the local stack pointer is converted to a global
351 -- pointer via System.Address.
354 type Stk_Pool_Array
is array (1 .. Binder_SS_Count
) of
355 aliased SS_Stack
(Default_SS_Size
);
356 type Stk_Pool_Access
is access Stk_Pool_Array
;
358 function To_Stack_Pool
is new
359 Ada
.Unchecked_Conversion
(Address
, Stk_Pool_Access
);
361 pragma Warnings
(Off
);
362 function To_Global_Ptr
is new
363 Ada
.Unchecked_Conversion
(Address
, SS_Stack_Ptr
);
364 pragma Warnings
(On
);
365 -- Suppress aliasing warning since the pointer we return will
366 -- be the only access to the stack.
368 Local_Stk_Address
: System
.Address
;
371 Num_Of_Assigned_Stacks
:= Num_Of_Assigned_Stacks
+ 1;
375 (Default_Sized_SS_Pool
) (Num_Of_Assigned_Stacks
)'Address;
376 Stack
:= To_Global_Ptr
(Local_Stk_Address
);
379 Stack
.Freeable
:= False;
381 Stack
:= new SS_Stack
(Stack_Size
);
382 Stack
.Freeable
:= True;
388 Stack
.Current_Chunk
:= Stack
.Internal_Chunk
'Access;
395 function SS_Mark
return Mark_Id
is
396 Stack
: constant SS_Stack_Ptr
:= SSL
.Get_Sec_Stack
.all;
398 return (Sec_Stack
=> Stack
, Sptr
=> Stack
.Top
);
405 procedure SS_Release
(M
: Mark_Id
) is
407 M
.Sec_Stack
.Top
:= M
.Sptr
;
410 end System
.Secondary_Stack
;